paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 20:59:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Extensions for enumerators and lists

Browse Source 
git-svn-id: trunk@30868 -
This commit is contained in:
michael 2015-05-16 11:04:00 +00:00
parent 5a49d4e7b1
commit 0eddef3d09
2 changed files with 79 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
packages/fcl-web/src/base/restbase.pp
View File

@ -60,6 +60,13 @@ Type
procedure SetObjectOptions(AValue: TObjectOptions);
Function GetAdditionalProperties : TJSONObject;
protected
{$ifdef ver2_6}
// Version 2.6.4 has a bug for i386 where the array cannot be set through RTTI.
// This is a helper method that sets the length of the array to the desired length,
// After which the new array pointer is read again.
// AName is guaranteed to be lowercase
Procedure SetArrayLength(const AName : String; ALength : Longint); virtual;
{$endif}
Procedure MarkPropertyChanged(AIndex : Integer);
Function IsDateTimeProp(Info : PTypeInfo) : Boolean;
Function DateTimePropType(Info : PTypeInfo) : TDateTimeType;
@ -120,6 +127,18 @@ Type
TObjectArray = Array of TBaseObject;
TObjectArrayArray = Array of TObjectArray;
TBaseListEnumerator = class
private
FList: TFPObjectList;
FPosition: Integer;
public
constructor Create(AList: TFPObjectList);
function GetCurrent: TBaseObject; virtual;
function MoveNext: Boolean;
property Current: TBaseObject read GetCurrent;
end;
TBaseListEnumeratorClass = Class of TBaseListEnumerator;
{ TBaseObjectList }
TBaseObjectList = Class(TBaseObject)
@ -129,9 +148,11 @@ Type
function GetO(Aindex : Integer): TBaseObject;
procedure SetO(Aindex : Integer; AValue: TBaseObject);
Class Function ObjectClass : TBaseObjectClass; virtual;
Function DoCreateEnumerator(AEnumClass : TBaseListEnumeratorClass) : TBaseListEnumerator;
Public
Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Override;
Destructor Destroy; override;
function GetEnumerator : TBaseListEnumerator;
Function AddObject(Const AKind : String) : TBaseObject; virtual;
Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO; default;
end;
@ -447,24 +468,35 @@ begin
FList[AIndex]:=AValue;
end;
Class Function TBaseObjectList.ObjectClass: TBaseObjectClass;
class function TBaseObjectList.ObjectClass: TBaseObjectClass;
begin
Result:=TBaseObject;
end;
Constructor TBaseObjectList.Create(AOptions : TObjectOptions = DefaultObjectOptions);
function TBaseObjectList.DoCreateEnumerator(AEnumClass: TBaseListEnumeratorClass
): TBaseListEnumerator;
begin
Result:=AEnumClass.Create(FList);
end;
constructor TBaseObjectList.Create(AOptions: TObjectOptions);
begin
inherited Create(AOptions);
FList:=TFPObjectList.Create;
end;
Destructor TBaseObjectList.Destroy;
destructor TBaseObjectList.Destroy;
begin
FreeAndNil(FList);
inherited Destroy;
end;
Function TBaseObjectList.AddObject(const AKind : String): TBaseObject;
function TBaseObjectList.GetEnumerator: TBaseListEnumerator;
begin
Result:=TBaseListEnumerator.Create(FList);
end;
function TBaseObjectList.AddObject(const AKind: String): TBaseObject;
Var
C : TBaseObjectClass;
@ -479,6 +511,24 @@ begin
FList.Add(Result);
end;
constructor TBAseListEnumerator.Create(AList: TFPObjectList);
begin
inherited Create;
FList := AList;
FPosition := -1;
end;
function TBaseListEnumerator.GetCurrent: TBaseObject;
begin
Result := TBaseObject(FList[FPosition]);
end;
function TBaseListEnumerator.MoveNext: Boolean;
begin
Inc(FPosition);
Result := FPosition < FList.Count;
end;
{ TBaseObject }
function TBaseObject.GetDynArrayProp(P: PPropInfo): Pointer;
@ -486,6 +536,7 @@ begin
Result:=Pointer(GetObjectProp(Self,P));
end;
procedure TBaseObject.SetDynArrayProp(P: PPropInfo; AValue: Pointer);
begin
SetObjectProp(Self,P,TObject(AValue));
@ -602,7 +653,7 @@ Var
I : Integer;
PA : ^pdynarraytypeinfo;
ET : PTypeInfo;
AN : String;
LPN,AN : String;
AP : Pointer;
S : TJSONSchema;
@ -644,13 +695,26 @@ begin
FreeAndNil(O[i]);
end;
// Clear array
{$ifdef ver2_6}
LPN:=Lowercase(P^.Name);
SetArrayLength(LPN,0);
{$else}
I:=0;
DynArraySetLength(AP,P^.PropType,1,@i);
{$endif}
// Now, set new length
I:=AValue.Count;
// Writeln(ClassName,' (Array) Setting length of array property ',P^.Name,' (type: ',P^.PropType^.Name,') to ',AValue.Count);
{$ifdef ver2_6}
// Workaround for bug in 2.6.4 that cannot set the array prop correctly.
// Call helper routine and re-get array value
SetArrayLength(LPN,i);
AP:=GetObjectProp(Self,P);
{$else}
DynArraySetLength(AP,P^.PropType,1,@i);
I:=Length(TObjectArray(AP));
SetDynArrayProp(P,AP);
{$endif}
// Fill in all elements
For I:=0 to AValue.Count-1 do
begin
@ -1065,6 +1129,13 @@ begin
Result:=fAdditionalProperties
end;
{$IFDEF VER2_6}
procedure TBaseObject.SetArrayLength(Const AName: String; ALength: Longint);
begin
Raise ERestAPI.CreateFmt('Unknown Array %s',[AName]);
end;
{$ENDIF}
class function TBaseObject.AllowAdditionalProperties: Boolean;
begin
Result:=False;
@ -1085,7 +1156,7 @@ Const
'to;type;unit;until;uses;var;while;with;xor;dispose;exit;false;new;true;'+
'as;class;dispinterface;except;exports;finalization;finally;initialization;'+
'inline;is;library;on;out;packed;property;raise;resourcestring;threadvar;try;'+
'private;published;';
'private;published;length;setlength;';
Var
I : Integer;

2
packages/fcl-web/src/base/restcodegen.pp
View File

@ -31,6 +31,7 @@ Type
Private
FAddTimeStamp: Boolean;
FBaseClassName: String;
FBaseListClassName: String;
FClassPrefix: String;
FExtraUnits: String;
FLicenseText: TStrings;
@ -68,6 +69,7 @@ Type
Property Source : TStrings Read FSource;
Published
Property BaseClassName : String Read FBaseClassName Write FBaseClassName;
Property BaseListClassName : String Read FBaseListClassName Write FBaseListClassName;
Property OutputUnitName : String Read FOutputUnitName Write FOutputUnitName;
Property ExtraUnits : String Read FExtraUnits Write FExtraUnits;
Property ClassPrefix : String Read FClassPrefix Write FClassPrefix;