{ Base Google API code generator Copyright (C) 2015 Michael Van Canneyt michael@freepascal.org This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version with the following modification: As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules,and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. } unit googlediscoverytopas; {$mode objfpc}{$H+} interface uses typinfo, Classes, SysUtils, fpjson, restcodegen, restbase, googlebase; Type TTypeDef = Class; TSchema = Class; TSchemas = Array of TSchema; TPropertyDef = Class; TProperties = TSchemas; TRestMethod = Class; TRestMethods = Array of TRestMethod; TArrayPropertyDef = Class; { TIcons } TGoogleIcons = Class(TGoogleBaseObject) private Fx16: String; Fx32: String; Published Property x16 : String Read Fx16 Write fx16; Property x32 : String Read Fx32 Write fx32; end; { TGoogleAuth2 } TGoogleAuth2 = Class(TGoogleBaseObject) private FScopes: TSchemas; Published Property Scopes : TSchemas Read Fscopes Write Fscopes; end; { TGoogleAuth } TGoogleAuth = Class(TGoogleBaseObject) private Foauth2: TGoogleAuth2; Published Property oauth2 : TGoogleAuth2 Read Foauth2 Write Foauth2; end; { TDiscoveryJSONToPas } { TArrayPropertyDef } { TAnnotations } TAnnotations = Class(TGoogleBaseObject) private FRequired: TStringArray; Published Property required : TStringArray Read FRequired Write Frequired; end; { TSchema } TSchema = Class(TGoogleBaseObject) private FadditionalProperties: TSchema; FAnnotations: TAnnotations; FDefault: String; Fdescription: string; fdivisibleby: integer; FEnum: TJSONSchema; FenumDescriptions: TStringArray; fexclusivemaximum: boolean; fexclusiveminimum: boolean; Fextends: string; FFormat: string; fitems: TSchema; fmaximum: integer; fmaxItems: integer; fmaxlength: integer; Fmethods: TRestMethods; fminimum: integer; fminItems: integer; fminlength: integer; FName: String; FPattern: string; FProperties: TProperties; FPropertyName: String; FreadOnly: Boolean; Fref: string; FRefSchema: TSchema; frequired: Boolean; FResources: TSchemas; Fschema: String; FType: string; FID: String; FTypeDef: TTypeDef; FTypeName: String; funiqueItems: boolean; FVariant: TJSONSchema; function DoGetTypeName(PrependT: Boolean): String; function GetTypeName: String; Public Class function BaseType(ATypeName: String): Boolean; Class function GetBaseTypeName(AType,AFormat : String) : string; Function DebugName : String; function GetBaseTypeName : string; Function BaseType : Boolean; Function ClassProperties : TProperties; Property PropertyName : String Read FPropertyName Write FPropertyName; Property TypeName : String Read GetTypeName Write FTypeName; Property Refschema : TSchema Read FRefSchema Write FRefSchema; Property TypeDef : TTypeDef Read FTypeDef write FTypeDef; Published Property id : String Read FID Write FID; Property description : string read Fdescription Write Fdescription; Property _type : String Read FType Write FType; Property ref : String Read FRef Write FRef; Property schema: String Read Fschema Write Fschema; Property name : String Read FName Write FName; Property enum : TJSONSchema Read FEnum Write FEnum; Property enumDescriptions : TStringArray Read FenumDescriptions Write FenumDescriptions; Property properties : TProperties Read FProperties Write FProperties; Property items : TSchema Read fitems write fitems; Property default : String Read FDefault Write FDefault; property required : Boolean read frequired write frequired; Property annotations : TAnnotations Read FAnnotations Write FAnnotations; Property format : string Read FFormat Write FFormat; Property additionalProperties : TSchema Read FadditionalProperties Write FadditionalProperties; Property minLength : integer read fminlength write fminlength; Property maxLength : integer read fmaxlength write fmaxlength; Property minItems : integer read fminItems write fminItems; Property maxItems : integer read fmaxItems write fmaxItems; Property minimum : integer read fminimum write fminimum; Property pattern : string read FPattern write fPattern; Property exclusiveMaximum : boolean read fexclusivemaximum write fexclusivemaximum; Property exclusiveMinimum : boolean read fexclusiveminimum write fexclusiveminimum; Property uniqueItems : boolean read funiqueItems write funiqueItems; Property maximum : integer read fmaximum write fmaximum; Property divisibleBy : integer read fdivisibleby write fdivisibleby; Property extends : string Read Fextends Write Fextends; Property methods : TRestMethods Read Fmethods Write Fmethods; property readOnly : Boolean Read FreadOnly Write fReadOnly; Property resources : TSchemas Read FResources write FResources; Property variant : TJSONSchema Read FVariant Write FVariant; end; TArrayPropertyDef = Class(TSchema); TPropertyDef = Class(TSchema); TMediaUploadprotocolssimple = Class(TGoogleBaseObject) Private Fmultipart : boolean; Fpath : string; Published Property multipart : boolean Read Fmultipart Write Fmultipart; Property path : string Read Fpath Write Fpath; end; TMediaUploadProtocolsSimpleArray = Array of TMediaUploadProtocolsSimple; TMediaUploadProtocolsResumable = Class(TGoogleBaseObject) Private Fmultipart : boolean; Fpath : string; Published Property multipart : boolean Read Fmultipart Write Fmultipart; Property path : string Read Fpath Write Fpath; end; TMediaUploadProtocolsResumableArray = Array of TMediaUploadProtocolsResumable; { TMediaUploadProtocols } TMediaUploadProtocols = Class(TGoogleBaseObject) private Fresumable: TMediaUploadprotocolsresumable; Fsimple: TMediaUploadprotocolssimple; Published Property resumable : TMediaUploadprotocolsresumable Read Fresumable Write Fresumable; Property simple : TMediaUploadprotocolssimple Read Fsimple Write Fsimple; end; TMediaUploadProtocolsArray = Array of TMediaUploadProtocols; TMediaUpload = Class(TGoogleBaseObject) private FAccept: TStringArray; FMaxSize: String; Fprotocols: TMediaUploadProtocols; Published Property Accept : TStringArray Read FAccept Write FAccept; property MaxSize : String Read FMaxSize Write FMaxSize; Property protocols : TMediaUploadProtocols Read Fprotocols Write Fprotocols; end; { TRequest } TRequest = Class(TGoogleBaseObject) private fparameterName: string; fref: string; Published Property ref : string read fref write fref; Property parameterName : string read fparameterName write fparameterName; end; { TResponse } TResponse = Class(TGoogleBaseObject) private fref: string; Published Property ref : string read fref write fref; end; { TRestMethodParam } TRestMethodParam = Class(TSchema) private FLocation: string; FRepeated: boolean; FSourceName: String; Public Property SourceName : String Read FSourceName Write FSourceName; Published Property location : string Read FLocation Write FLocation; Property repeated : boolean Read FRepeated write FRepeated; end; TRestMethodParams = Array of TRestMethodParam; { TRestMethod } TRestMethod = Class(TGoogleBaseObject) private FDescription: String; FeTagrequired: Boolean; FflatPath: string; FhttpMethod: string; Fid: string; fMediaUpload: TMediaUpload; fname: string; FParameterOrder: TStringArray; fparameters: TRestMethodParams; fpath: string; frequest: trequest; fresponse: tresponse; Fscopes: TStringArray; FsupportsMediaDownload: Boolean; FsupportsMediaUpload: Boolean; FsupportsSubscription: Boolean; Published Property name : string read fname Write fname; Property description : String Read FDescription Write FDescription; Property etagRequired: Boolean read FeTagrequired write FeTagrequired; Property httpMethod: string read FhttpMethod write FhttpMethod; Property id : string read Fid Write fID; Property MediaUpload : TMediaUpload Read fMediaUpload Write fmediaUpload; Property parameterOrder : TStringArray Read FParameterOrder Write FParameterOrder; Property parameters : TRestMethodParams read fparameters write fparameters; Property path : string read fpath Write fpath; Property flatPath : string read FflatPath Write FflatPath; Property request : trequest read frequest write frequest; Property response : tresponse read fresponse write fresponse; property scopes : TStringArray Read Fscopes write Fscopes; property supportsMediaDownload : Boolean Read FsupportsMediaDownload Write FsupportsMediaDownload; property supportsMediaUpload : Boolean Read FsupportsMediaUpload Write FsupportsMediaUpload; property supportsSubscription : Boolean Read FsupportsSubscription Write FsupportsSubscription; end; { TGoogleRestDescription } TGoogleRestDescription = Class(TGoogleBaseObject) private Fauth: TGoogleAuth; fbasePath: string; fbaseURL: string; fbatchPath: string; FCanonicalName: String; FDescription: string; FdiscoveryVersion: String; FdocumentationLink: string; FEtag: String; Ffeatures: TstringArray; Ficons: TGoogleIcons; fid: String; FKind: String; Flabels: TstringArray; Fmethods: TRestMethods; Fname: String; fOwnerDomain: String; fOwnerName: String; FpackagePath: String; Fparameters: TJSONSchema; Fprotocol: string; FResources: TSchemas; FRevision: string; frootURL: string; FSchemas: TSchemas; fservicePath: string; FTitle: string; Fversion: String; Published property Auth : TGoogleAuth Read Fauth Write Fauth; property basePath : string read fbasePath write FbasePath; property baseUrl : string read fbaseURL write FbaseURL; property batchPath : string read fbatchPath write FbatchPath; Property canonicalName : String Read FCanonicalName Write FCanonicalName; Property description : string Read FDescription Write FDescription; Property discoveryVersion : String Read FdiscoveryVersion Write FdiscoveryVersion; Property documentationLink : string read FdocumentationLink Write FdocumentationLink; Property etag : String Read FEtag Write FEtag; Property features : TstringArray Read Ffeatures Write Ffeatures; property icons : TGoogleIcons Read Ficons Write Ficons; Property id: String Read fid Write Fid; Property kind: String Read FKind Write FKind; Property labels : TstringArray Read Flabels Write Flabels; Property methods : TRestMethods Read Fmethods Write Fmethods; Property name : String Read Fname Write Fname; Property ownerDomain : String Read fOwnerDomain Write FOwnerDomain; Property ownerName : String Read fOwnerName Write FOwnerName; Property packagePath : String Read FpackagePath Write FpackagePath; Property parameters : TJSONSchema Read Fparameters Write FParameters; property protocol : string Read Fprotocol write FProtocol; Property resources : TSchemas Read FResources write FResources; Property revision : string Read FRevision Write FRevision; property rootUrl : string read frootURL write FrootURL; property schemas : TSchemas read FSchemas write fschemas; property servicePath : string read fservicePath write FservicePath; Property title : string Read FTitle Write FTitle; Property version : String Read Fversion Write Fversion; end; TParamLocation = (plPath,plQuery); TParamLocations = Set of TParamLocation; TDataType = (dtalias,dtClass,dtarray); { TTypeDef } TTypeDef = Class(TCollectionItem) private FDataType: TDataType; FItemSchema: TSchema; FPascalName: String; FSchema: TSchema; FTopLevel: Boolean; Public Property PascalName : String Read FPascalName Write FPascalName; Property Schema : TSchema Read FSchema Write FSchema; Property DataType : TDataType Read FDataType Write FDataType; Property ItemSchema: TSchema Read FItemSchema Write FItemSchema; Property TopLevel : Boolean Read FTopLevel Write FTopLevel; end; { TTypeDefEnumerator } TTypeDefEnumerator = Class(TCollectionEnumerator) Public Function GetCurrent: TTypeDef; property Current: TTypeDef read GetCurrent; end; { TTypeDefs } TTypeDefs = Class(TCollection) private function GetD(AIndex : Integer): TTypeDef; Public Function GetEnumerator: TTypeDefEnumerator; Function IndexOf(ATypename : String) : Integer; Function Find(ATypename : String) : TTypeDef; Function AddTypeDef(ADataType : TDataType; APascalName : String; ASchema : TSchema) : TTypeDef; Property Defs[AIndex : Integer] : TTypeDef Read GetD; Default; end; TGoogleCodeOption = (gcoUseListForArray,gcoFlatResources); TGoogleCodeOptions = Set of TGoogleCodeOption; TDiscoveryJSONToPas = Class(TRestCodeGenerator) private FArrayItemSuffix: String; FCodeOptions: TGoogleCodeOptions; FDescription: TGoogleRestDescription; FPropertyTypeSuffix: String; FResourceSuffix: String; FTypes : TTypeDefs; Function AddType(ASchema: TSchema; NamePrefix: String; IsTopLevel : Boolean) : TTypeDef; procedure CollectType(S: TSchema; NamePrefix: String; IsTopLevel : Boolean); function GetFlat: Boolean; function GetSchemaDataType(S: TSchema): TDataType; function GetUseListForArray: Boolean; function ReservedMethod(ANAme: String): boolean; Protected procedure AssignParamNames(Res: TSchema; M: TRestMethod); virtual; Function BaseUnits : String; override; // Global functions Function GetPropertyType(AClassName: String; ASchema: TSchema): String; Procedure CollectTypes; Procedure CollectTypes(Schemas: TSchemas; NamePrefix : String); Procedure ResolveRefs; Procedure CreateInterface; Procedure CreateImplementation; // Schema Classes procedure CreateSetArrayLength(AClassName: String; ASchema, AItemSchema: TSchema); procedure CreateExportPropertyName(AClassName: String; ASchema, AItemSchema: TSchema); Procedure CreateClassDeclaration(AClassName: String; ASchema: TSchema); Procedure CreateArrayClassDeclaration(AClassName: String; ASchema,AItemSchema: TSchema); Procedure CreateClassImplementation(AClassName: String; ASchema,AItemSchema: TSchema); Procedure CreateArrayClassImplementation(AClassName: String; ASchema,AItemSchema: TSchema); Procedure CreateArrayClassEnumeratorImplementation(AClassName: String; ASchema,AItemSchema: TSchema); // API class Function GetAPIClassName: String; Procedure CreateAPIClassDeclaration; Procedure CreateAPIClassImplementation; // Resource classes Function ConstructResourcePrefix(Const APrefix: String; AResource: TSchema ): String; // Recursive calls Procedure CreateResourceClassImplementations(Const APrefix: String; Resources: TSchemas); Procedure CreateResourceAPIFunctionImplementations(Const AClassName: String; Const APrefix: String; Resources: TSchemas); virtual; Procedure CreateResourceInstanceFields(Const APrefix: String; Resources: TSchemas); Procedure CreateResourceInstanceGetters(Const APrefix: String; Resources: TSchemas); Procedure CreateResourceAPI(Const APrefix: String; Resources: TSchemas); Procedure CreateResourceProperties(Const APrefix: String; Resources: TSchemas); Function GetResourceClassName(Const APrefix : String; Res: TSchema): String; procedure CreateResourceDeclarations(Const APrefix: String; Resources: TSchemas); Procedure CreateResourceClassDeclaration(Const APrefix: String; Res: TSchema); Procedure CreateResourceClassImplementation(Const APrefix: String; Res: TSchema); Procedure CreateResourceClassMethodsImplementation(Res: TSchema; Const AClassName: String); Procedure CreateResourceMethodImplementation(AClassName: String; Res: TSchema; M: TRestMethod); // Query version Procedure CreateResourceMethodImplementationOptions(Const APrefix, AClassName: String; Res: TSchema; M: TRestMethod);// Options record version Function GetResourceMethodSignature(M: TRestmethod; Out IsFunction: Boolean; QueryOptionType : String; AddTypes : Boolean = True): String; Function DescribeMethodParams(M: TRestMethod): TParamLocations; Function HavePathParams(M: TRestMethod): Boolean; Function HaveQueryParams(M: TRestMethod): Boolean; Procedure CreateResourceMethodQueryParams(APrefix: String; Res: TSchema; M: TRestMethod); Public Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; Procedure LoadFromStream(Const AStream : TStream); override; Procedure LoadFromJSON(Const JSON : TJSONObject); virtual; Procedure Execute; override; Class Procedure RegisterAllObjects; Property APIClassName: String Read GetAPIClassName; Property UseListForArray : Boolean Read GetUseListForArray; Property FlatResources : Boolean Read GetFlat; Published Property Description : TGoogleRestDescription Read FDescription; Property ResourceSuffix : String Read FResourceSuffix Write FResourceSuffix; Property ArrayItemSuffix : String Read FArrayItemSuffix Write FArrayItemSuffix; Property PropertyTypeSuffix : String Read FPropertyTypeSuffix Write FPropertyTypeSuffix; Property CodeOptions : TGoogleCodeOptions Read FCodeOptions Write FCodeOptions; end; implementation { TTypeDefEnumerator } function TTypeDefEnumerator.GetCurrent: TTypeDef; begin Result:=(Inherited GetCurrent) as TTypeDef; end; { TTypeDefs } function TTypeDefs.GetD(AIndex : Integer): TTypeDef; begin Result:=Items[AIndex] as TTypeDef; end; function TTypeDefs.GetEnumerator: TTypeDefEnumerator; begin Result:=TTypeDefEnumerator.Create(Self); end; function TTypeDefs.IndexOf(ATypename: String): Integer; begin Result:=Count-1; While (Result>=0) and (CompareText(ATypeName,GetD(Result).PascalName)<>0) do Dec(Result); end; function TTypeDefs.Find(ATypename: String): TTypeDef; Var I : Integer; begin I:=IndexOf(ATypeName); if (I=-1) then Result:=Nil else Result:=GetD(I); end; function TTypeDefs.AddTypeDef(ADataType: TDataType; APascalName: String; ASchema: TSchema): TTypeDef; begin Result:=Add as TTypeDef; Result.DataType:=ADataType; Result.PascalName:=APascalName; Result.Schema:=ASchema; end; { TSchema } function TSchema.DoGetTypeName(PrependT : Boolean) : String; begin Result:=FTypeName; if (Result='') and Assigned(TypeDef) then Result:=TypeDef.PascalName; If Result='' then begin If BaseType then Result:=GetBaseTypeName else if (_type='array') and Assigned(Items) then begin Result:=Items.DoGetTypeName(False); if (Result<>'') and not Assigned(Items.TypeDef) then begin if PrependT and (items._type<>'object') and (items._type<>'array') then Result:='T'+Result; Result:=Result+'Array'; end; end; end; end; function TSchema.GetTypeName: String; begin Result:=DoGetTypeName(True); end; Function TSchema.ClassProperties: TProperties; begin If Length(FProperties)>0 then Result:=FProperties //else if Assigned(Items) then // Result:=Items.properties else Result:=Nil end; { TGoogleRestDescription } { TDiscoveryJSONToPas } Constructor TDiscoveryJSONToPas.Create(AOwner: TComponent); begin inherited Create(AOwner); FDescription:=TGoogleRestDescription.Create; BaseClassName:='TGoogleBaseObject'; BaseListClassName:='TGoogleBaseObjectList'; FResourceSuffix:='Resource'; ArrayItemSuffix:='Item'; PropertyTypeSuffix:='Type'; // UseListForArray:=True; end; Destructor TDiscoveryJSONToPas.Destroy; begin FreeAndNil(FDescription); inherited Destroy; end; Procedure TDiscoveryJSONToPas.LoadFromStream(Const AStream: TStream); Var D : TJSONData; begin D:=GetJSON(AStream,True); try if Not (D is TJSONObject) then Raise EGoogleAPI.Create('Source does not contain a valid JSON object'); LoadFromJSON(D as TJSONObject) finally D.Free; end; end; Procedure TDiscoveryJSONToPas.LoadFromJSON(Const JSON: TJSONObject); begin Description.LoadFromJSON(JSON); end; function TDiscoveryJSONToPas.GetSchemaDataType(S: TSchema): TDataType; begin if (S._type='array') then Result:=dtArray else if S._type='object' then Result:=dtClass else Result:=dtAlias; end; function TDiscoveryJSONToPas.GetUseListForArray: Boolean; begin Result:=gcoUseListForArray in CodeOPtions; end; Function TDiscoveryJSONToPas.AddType(ASchema: TSchema; NamePrefix: String; IsTopLevel: Boolean): TTypeDef; Function DoAdd(DT : TDataType; TCN : String; S,ITS : TSchema) : TTypeDef; Var Msg : String; begin Result:=Nil; if (FTypes.IndexOf(TCN)<>-1) then Raise Exception.CreateFmt('Type already exists : "%s"',[TCN]); Result:=FTypes.AddTypeDef(dt,TCN,S); Result.ItemSchema:=ITS; Result.Toplevel:=isTopLevel; Str(dt,Msg); Msg:=Format('[%s] : Adding %s (%s) from ',[NamePrefix,TCN,Msg]); if Assigned(S) then Msg:=Msg+S.DebugName; if Assigned(ItS) then Msg:=Msg+Format(' (Array item: %s)',[its.DebugName]); DoLog(Msg); end; Var CN,TCN : String; Dt : TDataType; begin dt:=GetSchemaDataType(ASchema); CN:=NamePrefix+ASchema.Name; if (dt=dtArray) and (NamePrefix<>'') then CN:=CN+'Array'; TCN:='T'+CN; Result:=doAdd(dt,TCN,ASchema,Aschema.Items); Aschema.TypeDef:=Result; if (dt=dtClass) and isToplevel then doAdd(dtArray,TCN+'Array',Nil,Aschema); end; procedure TDiscoveryJSONToPas.CollectType(S: TSchema; NamePrefix: String; IsTopLevel : Boolean); Var AE : String; Dt : TDataType; BaseArrayElement : Boolean; begin if (S.Name='Component') and (NamePrefix='') then NamePrefix:='_'; dt:=GetSchemaDataType(S); BaseArrayElement:=(dt=dtArray) and S.Items.BaseType; DoLog('[%s] Examining : %s (Ref : %s type: %s) Toplevel %s',[NamePrefix,S.Name,S.ref,S._type,BoolToStr(IsTopLevel,'True','False')]); case dt of dtArray : if Not BaseArrayElement and (S.Items.Ref='') then begin AE:=S.Name; if S.Items.Name='' then AE:=AE+ArrayItemSuffix; DoLog('Array, adding array item type first (%s)',[AE]); CollectType(S.Items,NamePrefix+AE,isTopLevel); end; dtClass : if (S.Ref='') then begin DoLog('Class type, adding properties first'); CollectTypes(S.Properties,NamePrefix+S.Name+PropertyTypeSuffix); end; else //no other cases to handle end; if (NamePrefix='') then AddType(S,'',True) else if (Not S.BaseType) and (Not BaseArrayElement) and (S.Ref='') then AddType(S,NamePrefix,IsTopLevel); end; function TDiscoveryJSONToPas.GetFlat: Boolean; begin Result:=gcoFlatResources in CodeOPtions; end; Procedure TDiscoveryJSONToPas.CollectTypes(Schemas: TSchemas; NamePrefix: String ); Var S : TSchema; begin For S in Schemas do CollectType(S,NamePrefix,NamePrefix=''); end; Procedure TDiscoveryJSONToPas.ResolveRefs; Var Lookup : TStringList; Function DoFind (S : TSchema; C : String) : TSchema; Var idx : Integer; begin Idx:=Lookup.IndexOf(S.Ref); if idx<>-1 then Result:=TSchema(Lookup.Objects[idx]) else Raise Exception.CreateFmt('Could not find reference %s (Context: %s)',[S.Name,C]); end; Procedure AddSchema(ASchema : TSchema); begin if Assigned(ASchema) then begin if (ASchema.Name<>'') then begin Lookup.AddObject(ASchema.Name,ASchema) end; end end; Procedure DoResolve(ASchema : TSchema); Var S2 : TSchema; begin if Assigned(ASchema) then begin if (ASchema.Ref<>'') and (ASchema.Refschema=Nil) then ASchema.Refschema:=DoFind(ASchema,ASchema.Name); if Assigned(ASchema.Items) then DoResolve(ASchema.Items); if Length(ASchema.Properties)<>0 then For S2 in ASchema.Properties do begin DoResolve(S2); DoResolve(S2.Items); end; end; end; Var T : TTypeDef; S : TSchema; begin Lookup:=TStringList.Create; try for S in Description.Schemas do AddSchema(S); Lookup.Sorted:=True; For T in FTypes do begin DoResolve(T.Schema); DoResolve(T.ItemSchema); end; finally Lookup.Free; end; end; Procedure TDiscoveryJSONToPas.CollectTypes; Var S : TTypeDef; Msg : String; begin CollectTypes(Description.Schemas,ClassPrefix); For S in FTypes do begin Str(S.DataType,Msg); DoLog('Created data type %s (%s)',[S.PascalName,Msg]); end; ResolveRefs; end; Function TDiscoveryJSONToPas.BaseUnits: String; begin Result:='sysutils, classes, googleservice, restbase, googlebase'; end; Class function TSchema.BaseType(ATypeName: String): Boolean; begin Result:=(ATypeName='boolean') or (ATypeName='string') or (ATypeName='number') or (ATypeName='any') or (ATypeName='integer'); end; Class function TSchema.GetBaseTypeName(AType, AFormat: String): string; begin Result:=AType; if Result='any' then Result:='TJSONSchema' else if Result='integer' then begin if (AFormat='int64') then Result:='int64' else Result:='integer' end else if Result='number' then begin if (AFormat='double') then Result:='double' else Result:='integer' end else if Result='string' then if Aformat='date-time' then Result:='TDatetime' else if Aformat='date' then Result:='TDate' else Result:='String'; end; Function TSchema.DebugName: String; begin Result:=sysutils.Format('(Name: %s, Pascal Type : %s, type : %s, Ref: %s)',[Name,TypeName,_type,Ref]); end; function TSchema.GetBaseTypeName: string; begin Result:=GetBaseTypeName(_type,Format); end; Function TSchema.BaseType: Boolean; begin Result:=BaseType(_type) end; Function TDiscoveryJSONToPas.GetPropertyType(AClassName: String; ASchema: TSchema): String; begin DoLog('Checking property type "%s" property schema %s',[AClassName,ASchema.DebugName]); Result:=ASchema.TypeName; if (Result='') then begin Result:=ASchema.ref; if Result='' then begin Result:=ASchema._type; if TSchema.BaseType(Result) then Result:=ASchema.GetBaseTypeName; end else if Not Assigned(ASchema.Refschema) then Raise Exception.CreateFmt('%s : Unresolved property schema (%s) type reference : %s',[AClassName,ASchema.Name,ASchema.Ref]) else Result:=ASchema.Refschema.TypeName; end; if Result='array' then begin if Aschema.Items.TypeDef<>Nil then Result:=Aschema.Items.TypeDef.PascalName else if (ASchema.Items.Ref<>'') then begin if not Assigned(ASchema.Items.Refschema) then Raise Exception.CreateFmt('%s : Unresolved property (%s) type reference : %s',[AClassName,ASchema.Name,ASchema.Ref]); Result:=Aschema.Items.RefSchema.TypeName+'Array'; end else Result:=ASchema.Items.TypeName; end else if Result='object' then if (ASchema.ref<>'') then Result:='T'+ClassPrefix+ASchema.ref else Result:=AClassName+ASchema.Name; end; Procedure TDiscoveryJSONToPas.CreateClassDeclaration(AClassName: String; ASchema: TSchema); Var S : TSchema; N : String; NeedSetArrayLength, NeedGetWritename : Boolean; TN : String; Idx,PropertyIndex,PropertyOptions : Integer; L : TStringList; begin if ASchema=Nil then Raise Exception.Create(AClassName+' : no Schema'); ClassComment(AClassName); AddLn('%s = Class(%s)',[AClassName,BaseClassName]); AddLn('Private'); NeedGetWriteName:=False; NeedSetArrayLength:=False; IncIndent; L:=TStringList.Create; try For S in ASchema.Properties do begin N:=TBaseObject.CleanPropertyName(S.Name); Repeat Idx:=L.IndexOf(N); if (idx=-1) then Idx:=L.IndexOf('F'+N); if (idx<>-1) then begin N:='_'+N; end; Until Idx=-1; NeedGetWritename:=NeedGetWritename or (CompareText(N,S.Name)<>0); NeedSetArrayLength:=NeedSetArrayLength or (S._type='array'); S.PropertyName:=N; tn:=GetPropertyType(AClassName,S); AddLn('F%s : %s;',[N,tn]); L.Add(N); L.Add('F'+N); end; finally L.Free; end; DecIndent; AddLn('Protected'); IncIndent; if NeedGetWriteName then AddLn('Class Function ExportPropertyName(Const AName : String) : string; override;'); Comment('Property setters'); For S in ASchema.ClassProperties do begin N:=S.PropertyName; tn:=GetPropertyType(AClassName,S); AddLn('Procedure Set%s(AIndex : Integer; const AValue : %s); virtual;',[N,tn]); end; DecIndent; AddLn('Public'); IncIndent; if Assigned(ASchema.additionalProperties) then AddLn('Class Function AllowAdditionalProperties : Boolean; override;'); DecIndent; AddLn('Published'); IncIndent; PropertyIndex:=0; For S in ASchema.ClassProperties do begin N:=S.PropertyName; Tn:=GetPropertyType(AClassName,S); PropertyOptions:=0; Idx:=(PropertyIndex shl IndexShift) or PropertyOptions; AddLn('Property %s : %s Index %d Read F%s Write Set%s;',[N,TN,Idx, N,N]); Inc(PropertyIndex); end; DecIndent; AddLn('end;'); AddLn('%sClass = Class of %s;',[AClassName,AClassName]); end; Procedure TDiscoveryJSONToPas.CreateArrayClassDeclaration(AClassName: String; ASchema, AItemSchema: TSchema); Var AEnumeratorName,AItemName : String; begin if AItemSchema=Nil then Raise Exception.Create(AClassName+' : no item Schema'); AItemName:=GetPropertyType('',AItemSchema); AEnumeratorName:=AClassName+'Enumerator'; ClassComment(AEnumeratorName); AddLn('%s = Class(%s)',[AEnumeratorName,'TBaseListEnumerator']); AddLn('Public'); IncIndent; AddLn('Function GetCurrent : %s; ',[AItemName]); AddLn('Property Current : %s Read GetCurrent;',[AItemName]); DecIndent; AddLn('end;'); AddLn(''); AddLn(''); ClassComment(AClassName); AddLn('%s = Class(%s)',[AClassName,BaseListClassName]); AddLn('Private'); IncINdent; Addln('Function GetI (AIndex : Integer) : %s;',[AItemName]); Addln('Procedure SetI (AIndex : Integer; Const AValue: %s);',[AItemName]); DecIndent; AddLn('Protected'); IncIndent; AddLn('Class Function ObjectClass : TBaseObjectClass; override;'); DecIndent; AddLn('Public'); IncIndent; AddLn('Function GetEnumerator : %s;',[AEnumeratorName]); AddLn('Property Items[AIndex : Integer] : %s Read GetI Write SetI; default;',[AItemName]); DecIndent; AddLn('end;'); AddLn('%sClass = Class of %s;',[AClassName,AClassName]); end; procedure TDiscoveryJSONToPas.CreateSetArrayLength(AClassName: String; ASchema, AItemSchema: TSchema); begin //not used end; procedure TDiscoveryJSONToPas.CreateExportPropertyName(AClassName: String; ASchema, AItemSchema: TSchema); Var S : TSchema; N : String; begin begin Addln(''); AddLn('Class Function %s.ExportPropertyName(Const AName : String) :String;',[AClassName]); Addln(''); AddLn('begin'); IncIndent; AddLn('Case AName of'); For S in ASchema.ClassProperties do begin N:=S.PropertyName; if (CompareText(N,S.Name)<>0) then AddLn('''%s'' : Result:=''%s'';',[N,S.Name]); end; AddLn('else'); IncIndent; AddLn('Result:=Inherited ExportPropertyName(AName);'); DecIndent; AddLn('end;'); DecIndent; AddLn('end;'); Addln(''); end; end; Procedure TDiscoveryJSONToPas.CreateClassImplementation(AClassName: String; ASchema, AItemSchema: TSchema); Var S : TSchema; N : String; NeedSetArrayLength,NeedGetWritename : Boolean; TN : String; begin NeedGetWriteName:=False; NeedSetArrayLength:=False; ClassComment(AClassName); For S in ASchema.ClassProperties do begin N:=S.PropertyName; NeedSetArrayLength:=NeedSetArrayLength or (S._type='array'); NeedGetWritename:=NeedGetWritename or (CompareText(N,S.Name)<>0); TN:=GetPropertyType(AClassName,S); Addln(''); AddLn('Procedure %s.Set%s(AIndex : Integer; const AValue : %s); ',[AClassName,N,tn]); SimpleMethodBody([Format('If (F%s=AValue) then exit;',[N]), Format('F%s:=AValue;',[N]), 'MarkPropertyChanged(AIndex);']); Addln(''); end; if NeedGetWriteName then CreateExportPropertyName(AClassName,ASchema, AItemSchema); if NeedSetArrayLength and not UseListForArray then CreateSetArrayLength(AClassName,ASchema, AItemSchema); Addln(''); if Assigned(ASchema.additionalProperties) then begin AddLn('Class Function %s.AllowAdditionalProperties : Boolean;',[AClassName]); SimpleMethodBody(['Result:=True;']); end; Addln(''); end; Procedure TDiscoveryJSONToPas.CreateArrayClassImplementation( AClassName: String; ASchema, AItemSchema: TSchema); Var AEnumeratorName,AItemName : String; begin if AItemSchema=Nil then Raise Exception.Create(AClassName+' : no Schema'); CreateArrayClassEnumeratorImplementation(ACLassName,ASchema,AItemSchema); AItemName:=GetPropertyType('',AItemSchema); AEnumeratorName:=AClassName+'Enumerator'; ClassComment(AClassName); Addln(''); Addln('Function %s.GetI (AIndex : Integer) : %s;',[AClassName,AItemName]); SimpleMethodBody([Format('Result:=%s(Objects[AIndex]);',[AItemName])]); Addln(''); Addln('Procedure %s.SetI (AIndex : Integer; Const AValue: %s);',[AClassName,AItemName]); SimpleMethodBody(['Objects[AIndex]:=AValue;']); Addln(''); AddLn('Class Function %s.ObjectClass : TBaseObjectClass;',[ACLassName]); SimpleMethodBody([Format('Result:=%s;',[AItemName])]); Addln(''); AddLn('Function %S.GetEnumerator : %s;',[ACLassName,AEnumeratorName]); SimpleMethodBody([Format('Result:=%s(DoCreateEnumerator(%s));',[AEnumeratorName,AEnumeratorName])]); Addln(''); end; Procedure TDiscoveryJSONToPas.CreateArrayClassEnumeratorImplementation( AClassName: String; ASchema, AItemSchema: TSchema); Var AEnumeratorName,AItemName : String; begin if AItemSchema=Nil then Raise Exception.Create(AClassName+' : no ItemSchema'); AItemName:=GetPropertyType('',AItemSchema); AEnumeratorName:=AClassName+'Enumerator'; ClassComment(AEnumeratorName); AddLn('Function %s.GetCurrent : %s;',[AEnumeratorName,AItemName]); SimpleMethodBody([Format('Result:=%s(Inherited GetCurrent);',[AItemName])]); end; Function TDiscoveryJSONToPas.GetAPIClassName: String; begin Result:=Format('T%s%sAPI',[ClassPrefix,PrettyPrint(Description.Name)]) end; Procedure TDiscoveryJSONToPas.CreateInterface; procedure AddTypeDecl(S : TTypeDef); begin Case S.DataType of dtAlias : AddLn('%s = %s;',[S.PascalName,S.Schema.GetBaseTypeName]); dtArray : if UseListForArray then AddLn('%s = Class;',[S.PascalName]) else AddLn('%s = Array of %s;',[S.PascalName,GetPropertyType('',S.ItemSchema)]); dtClass : AddLn('%s = Class;',[S.PascalName]); end; end; Procedure DoTypeLoops(DoTopLevel : Boolean); Var S : TTypeDef; begin For S in FTypes do if (S.DataType=dtAlias) and (S.TopLevel=DoTopLevel) then AddTypeDecl(S); For S in FTypes do if (S.DataType=dtClass) and (S.TopLevel=DoTopLevel) then AddTypeDecl(S); For S in FTypes do if (S.DataType=dtArray) and (S.TopLevel=DoTopLevel) then AddTypeDecl(S); end; Var S : TTypeDef; begin Addln('type'); IncIndent; AddLn(''); Comment('Top-level schema types'); DoTypeLoops(True); Comment('Anonymous types, using auto-generated names'); DoTypeLoops(False); For S in FTypes do if S.DataType=dtClass then CreateClassDeclaration(S.PascalName,S.Schema) else if (S.DataType=dtArray) and UseListForArray then CreateArrayClassDeclaration(S.PascalName,S.Schema,S.ItemSchema); CreateResourceDeclarations('',Description.Resources); CreateAPIClassDeclaration; DecIndent; end; procedure TDiscoveryJSONToPas.CreateResourceDeclarations(Const APrefix : String; Resources : TSchemas); var R : TSchema; begin For R in Resources do begin if Assigned(R.resources) then if FlatResources then CreateResourceDeclarations(APrefix,R.Resources) else CreateResourceDeclarations(APrefix+PrettyPrint(R.Name),R.Resources); R.TypeName:=GetResourceClassName(APrefix,R); CreateResourceClassDeclaration(APrefix,R); end; end; Procedure TDiscoveryJSONToPas.CreateImplementation; Var S : TTypeDef; begin For S in FTypes do Case S.DataType of dtClass: CreateClassImplementation(S.PascalName,S.Schema,S.ItemSchema); dtArray: if UseListForArray then CreateArrayClassImplementation(S.PascalName,S.Schema,S.ItemSchema); else //no other cases to handle end; CreateResourceClassImplementations('',Description.Resources); CreateAPIClassImplementation; end; Procedure TDiscoveryJSONToPas.CreateResourceClassImplementations(Const APrefix : String; Resources : TSchemas); var R : TSchema; begin For R in Resources do begin if Assigned(R.Resources) then CreateResourceClassImplementations(ConstructResourcePrefix(APrefix,R),R.Resources); CreateResourceClassImplementation(APrefix,R); end; end; Function TDiscoveryJSONToPas.GetResourceMethodSignature(M: TRestmethod; Out IsFunction: Boolean; QueryOptionType: String; AddTypes: Boolean): String; Const Seps : Array[Boolean] of String = (',','; '); Procedure AddSep(Var S : String); begin if (S<>'') then S:=S+Seps[AddTypes]; end; Var P : TRestMethodParam; S : String; Q : Boolean; // Was AQuery encountered in options begin Q:=False; S:=''; For P in M.parameters do if (P.Location='path') and P.Required then begin Q:=Q or (CompareText(p.SourceName,'aquery')=0); AddSep(S); S:=S+P.SourceName; If AddTypes then S:=S+': '+P._type; end; For P in M.parameters do if (P.Location='path') and not P.Required then begin Q:=Q or (CompareText(p.SourceName,'aquery')=0); AddSep(S); S:=S+P.SourceName; if AddTypes then begin S:=S+': '+P._type + ' = '; Case p._type of 'string' : S:=S+''''''; 'number' : S:=S+'0'; 'object' : S:=S+'nil'; end; end; end; if M.Request<>Nil then begin AddSep(S); S:=S+'a'+M.request.ref; If AddTypes then S:=S+' : T'+ClassPrefix+M.request.ref; end; if (QueryOptionType<>'') then begin AddSep(S); if AddTypes then S:=S+'AQuery : '+QueryOptionType else S:=S+QueryOptionType; // Will be name instead of type; end; if (S<>'') then S:='('+S+')'; S:=PrettyPrint(TBaseObject.CleanPropertyName(M.Name))+S; isFunction:=M.Response<>Nil; if isFunction and AddTypes then S:=S+' : T'+ClassPrefix+M.response.ref; Result:=S; end; Function TDiscoveryJSONToPas.DescribeMethodParams(M: TRestMethod ): TParamLocations; Var P : TRestMethodParam; begin Result:=[]; For P in M.Parameters do Case P.location of 'path' : Include(Result,plPath); 'query' : Include(Result,plQuery); end; end; Function TDiscoveryJSONToPas.HavePathParams(M: TRestMethod): Boolean; begin Result:=plPath in DescribeMethodParams(M); end; Procedure TDiscoveryJSONToPas.CreateResourceMethodQueryParams(APrefix : String; Res: TSchema; M: TRestMethod); Var P : TRestMethodParam; RN,RCN,MN : String; begin RN:=APrefix+PrettyPrint(Res.Name); RCN:=Res.TypeName; MN:=PrettyPrint(M.Name); Addln(''); Comment(Format('Optional query Options for %s, method %s',[RCN,MN])); Addln(''); Addln('T%s%sOptions = Record',[RN,MN]); IncIndent; For P in M.parameters do begin if (P.location='query') then if p.format='int64' then AddLn('%s : int64;',[P.Sourcename]) else AddLn('%s : %s;',[P.sourcename,P.GetBaseTypeName]); end; DecIndent; Addln('end;'); Addln(''); end; Function TDiscoveryJSONToPas.HaveQueryParams(M: TRestMethod): Boolean; begin Result:=plQuery in DescribeMethodParams(M); end; Function TDiscoveryJSONToPas.GetResourceClassName(Const APrefix: String; Res: TSchema): String; Var Suffix : String; begin if (Res.TypeName<>'') and (Res.TypeName<>Res.Name) then Result:=Res.TypeName else begin Suffix:='Resource'; Repeat Result:=Format('T%s%s%s%s',[ClassPrefix,APrefix,PrettyPrint(Res.Name),Suffix]); Suffix:='_'+Suffix; Until FTypes.IndexOf(Result)=-1; end end; procedure TDiscoveryJSONToPas.AssignParamNames(Res: TSchema; M: TRestMethod); // Google API has case sensitive names. We need to make sure the names are unique in a case insensitive manner. // This is done by assigning the 'source name' Var T : TStringList; P : TRestMethodParam; N : String; begin T:=TStringList.Create; try // The request also has a parameter name If Assigned(M.request) then T.Add('a'+M.request.ref); // Some identifiers that are 'reserved' by the base classes. With T do begin Add('Name'); Add('ResourceName'); Add('DefaultAPI'); Add('API'); Add('Notification'); Add('UpdateAction'); Add('ExecuteAction'); end; // Actual paramters For P in M.parameters do begin N:=P.Name; While T.IndexOf(N)<>-1 do begin N:='_'+N; end; T.Add(N); P.SourceName:=TbaseObject.CleanPropertyName(N); end; finally T.Free; end; end; function TDiscoveryJSONToPas.ReservedMethod(ANAme: String): boolean; begin AName:=';'+lowerCase(AName)+';'; Result:=Pos(AName,';create;destroy;free;')<>0; end; Procedure TDiscoveryJSONToPas.CreateResourceClassDeclaration( Const APrefix: String; Res: TSchema); Var M : TRestMethod; CN,S : String; HaveOpt : Boolean; IsFunc : Boolean; begin CN:=Res.TypeName; ClassComment(CN); For M in Res.methods do begin AssignParamNames(Res,M); if HaveQueryParams(M) then begin CreateResourceMethodQueryParams(APrefix,Res,M); end; end; Addln('%s = Class(TGoogleResource)',[CN]); if Assigned(Res.Resources) then begin Addln('Private'); IncIndent; CreateResourceInstanceFields('',Res.Resources); CreateResourceInstanceGetters('',Res.Resources); DecIndent; end; Addln('Public'); IncIndent; AddLn('Class Function ResourceName : String; override;'); AddLn('Class Function DefaultAPI : TGoogleAPIClass; override;'); For M in Res.methods do begin HaveOpt:=HaveQueryParams(M); if HaveOpt then S:=GetResourceMethodSignature(M,IsFunc,'string = ''''') else S:=GetResourceMethodSignature(M,IsFunc,''); if IsFunc then S:='Function '+S else S:='Procedure '+S; if ReservedMethod(M.Name) then S:=S+';overload'; AddLn(S+';'); if HaveOpt then begin S:=GetResourceMethodSignature(M,IsFunc,Format('T%s%sOptions',[APrefix+PrettyPrint(Res.Name),M.Name])); if IsFunc then S:='Function '+S else S:='Procedure '+S; if ReservedMethod(M.Name) then S:=S+';overload'; AddLn(S+';'); end; end; if Assigned(Res.Resources) then begin CreateResourceAPI('',Res.resources); CreateResourceProperties('',Res.resources); end; DecIndent; Addln('end;',[Res.name]); AddLn(''); end; Procedure TDiscoveryJSONToPas.CreateResourceClassMethodsImplementation( Res: TSchema; Const AClassName: String); begin AddLn(''); Addln('Class Function %s.ResourceName : String;',[AClassName]); AddLn(''); AddLn('begin'); IncIndent; AddLn('Result:=''%s'';',[Res.name]); DecIndent; AddLn('end;'); AddLn(''); Addln('Class Function %s.DefaultAPI : TGoogleAPIClass;',[AClassName]); AddLn(''); AddLn('begin'); IncIndent; AddLn('Result:=T%s%sAPI;',[ClassPrefix,Description.Name]); DecIndent; AddLn('end;'); AddLn(''); end; Procedure TDiscoveryJSONToPas.CreateResourceMethodImplementationOptions(Const APrefix,AClassName: String; Res: TSchema; M: TRestMethod); Var P : TRestMethodParam; S: String; IsFunc : Boolean; begin S:=GetResourceMethodSignature(M,IsFunc,Format('T%s%sOptions',[APrefix+PrettyPrint(Res.Name),M.Name])); S:=AClassName+'.'+S; if IsFunc then S:='Function '+S else S:='Procedure '+S; Addln(''); AddLn(S+';'); Addln(''); AddLn('Var'); IncIndent; Addln('_Q : String;'); DecIndent; Addln(''); AddLn('begin'); IncIndent; AddLn('_Q:='''';'); For P in M.parameters do begin if (P.location='query') then AddLn('AddToQuery(_Q,''%s'',AQuery.%s);',[P.name,P.SourceName]); end; S:=GetResourceMethodSignature(M,IsFunc,'_Q',False); if IsFunc then S:='Result:='+S; AddLn(S+';'); DecIndent; AddLn('end;'); Addln(''); end; Procedure TDiscoveryJSONToPas.CreateResourceMethodImplementation( AClassName: String; Res: TSchema; M: TRestMethod); Var P : TRestMethodParam; Q,RC,O,S,PA : String; IsFunc : Boolean; PL: TParamLocations; begin PL:=DescribeMethodParams(M); if plQuery in PL then S:=GetResourceMethodSignature(M,IsFunc,'string = ''''') else S:=GetResourceMethodSignature(M,IsFunc,''); S:=AClassName+'.'+S; if IsFunc then S:='Function '+S else S:='Procedure '+S; AddLn(S+';'); AddLn(''); AddLn('Const'); IncIndent; AddLn('_HTTPMethod = ''%s'';',[M.httpMethod]); AddLn('_Path = ''%s'';',[M.path]); AddLn('_Methodid = ''%s'';',[M.id]); DecIndent; AddLn(''); if (plPath in PL) then begin AddLn('Var'); IncIndent; Addln('_P : String;'); DecIndent; Addln(''); end; Addln('begin'); IncIndent; S:=''; PA:='_Path'; if (plPath in PL) then begin for P in M.parameters do if P.location='path' then begin if (S<>'') then S:=S+','; S:=S+Format('''%s'',%s',[p.name,p.sourcename]); end; AddLn('_P:=SubstitutePath(_Path,[%s]);',[S]); PA:='_P'; end; if M.request<>Nil then O:='a'+M.request.ref else O:='Nil'; if (M.response<>Nil) then RC:='T'+ClassPrefix+M.response.ref else RC:='Nil'; if (plQuery in PL) then Q:='AQuery' else Q:=''''''; S:=Format('ServiceCall(_HTTPMethod,%s,%s,%s,%s)',[PA,Q,O,RC]); if isFunc then S:='Result:='+S+' as T'+ClassPrefix+M.response.ref; AddLn(S+';'); DecIndent; Addln('end;'); Addln(''); end; Procedure TDiscoveryJSONToPas.CreateResourceClassImplementation(Const APrefix : String; Res: TSchema); Var CN : String; M : TRestMethod; PL: TParamLocations; begin CN:=Res.TypeName; ClassComment(CN); CreateResourceClassMethodsImplementation(Res,CN); For M in Res.methods do begin PL:=DescribeMethodParams(M); CreateResourceMethodImplementation(CN,Res,M); if plQuery in PL then CreateResourceMethodImplementationOptions(APrefix,CN,Res,M); end; AddLn(''); if Assigned(Res.resources) then CreateResourceAPIFunctionImplementations(CN,'',Res.resources); end; Procedure TDiscoveryJSONToPas.CreateResourceInstanceFields(Const APrefix : String;Resources : TSchemas); Var R : TSchema; begin For R in Resources do begin If Assigned(R.Resources) then CreateResourceInstanceFields(ConstructResourcePrefix(APrefix,R),R.Resources); AddLn('F%sInstance : %s;',[APrefix+PrettyPrint(R.Name),R.TypeName]); end; end; Function TDiscoveryJSONToPas.ConstructResourcePrefix(Const APrefix : String; AResource : TSchema) : String; begin if FlatResources then Result:=APrefix else Result:=APrefix+PrettyPrint(AResource.Name); end; Procedure TDiscoveryJSONToPas.CreateResourceInstanceGetters(Const APrefix : String; Resources : TSchemas); Var R : TSchema; begin For R in Resources do begin If Assigned(R.Resources) then CreateResourceInstanceGetters(ConstructResourcePrefix(APrefix,R),R.Resources); AddLn('Function Get%sInstance : %s;virtual;',[APrefix+PrettyPrint(R.Name),R.TypeName]); end; end; Procedure TDiscoveryJSONToPas.CreateResourceProperties(Const APrefix : String; Resources : TSchemas); Var R : TSchema; begin For R in Resources do begin If Assigned(R.Resources) then CreateResourceProperties(ConstructResourcePrefix(APrefix,R),R.Resources); AddLn('Property %sResource : %s Read Get%sInstance;',[APrefix+PrettyPrint(R.Name),R.TypeName,APrefix+PrettyPrint(R.Name)]); end; end; Procedure TDiscoveryJSONToPas.CreateResourceAPI(Const APrefix : String; Resources : TSchemas); Var R : TSchema; begin For R in Resources do begin If Assigned(R.Resources) then CreateResourceAPI(ConstructResourcePrefix(APrefix,R),R.Resources); AddLn('Function Create%sResource(AOwner : TComponent) : %s;virtual;overload;',[APrefix+PrettyPrint(R.Name),R.TypeName]); AddLn('Function Create%sResource : %s;virtual;overload;',[APrefix+PrettyPrint(R.Name),R.TypeName]); end; end; Procedure TDiscoveryJSONToPas.CreateAPIClassDeclaration; Var CN : String; begin CN:=GetAPIClassName; ClassComment(CN); AddLn('%s = Class(TGoogleAPI)',[CN]); AddLn('Private'); IncIndent; CreateResourceInstanceFields('',Description.resources); CreateResourceInstanceGetters('',Description.resources); DecINdent; AddLn('Public'); IncIndent; Comment('Override class functions with API info'); AddLn('Class Function APIName : String; override;'); AddLn('Class Function APIVersion : String; override;'); AddLn('Class Function APIRevision : String; override;'); AddLn('Class Function APIID : String; override;'); AddLn('Class Function APITitle : String; override;'); AddLn('Class Function APIDescription : String; override;'); AddLn('Class Function APIOwnerDomain : String; override;'); AddLn('Class Function APIOwnerName : String; override;'); AddLn('Class Function APIIcon16 : String; override;'); AddLn('Class Function APIIcon32 : String; override;'); AddLn('Class Function APIdocumentationLink : String; override;'); AddLn('Class Function APIrootUrl : string; override;'); AddLn('Class Function APIbasePath : string;override;'); AddLn('Class Function APIbaseURL : String;override;'); AddLn('Class Function APIProtocol : string;override;'); AddLn('Class Function APIservicePath : string;override;'); AddLn('Class Function APIbatchPath : String;override;'); AddLn('Class Function APIAuthScopes : TScopeInfoArray;override;'); AddLn('Class Function APINeedsAuth : Boolean;override;'); AddLn('Class Procedure RegisterAPIResources; override;'); Comment('Add create function for resources'); CreateResourceAPI('',Description.resources); Comment('Add default on-demand instances for resources'); CreateResourceProperties('',Description.resources); DecIndent; AddLn('end;'); end; Procedure TDiscoveryJSONToPas.CreateAPIClassImplementation; Procedure StringRes(AValue : String); Var S : String; begin S:=MakePascalString(AValue,True); S:=StringReplace(S,#13#10,'''#13#10''',[rfReplaceAll]); S:=StringReplace(S,#10,'''#10''',[rfReplaceAll]); S:=StringReplace(S,#13,'''#13''',[rfReplaceAll]); SimpleMethodBody([Format('Result:=%s;',[S])]); end; Var CN : String; S : TSchema; I : Integer; begin CN:=GetAPIClassName; ClassComment(CN); AddLn('Class Function %s.APIName : String;',[CN]); StringRes(Description.name); AddLn('Class Function %s.APIVersion : String;',[CN]); StringRes(Description.version); AddLn('Class Function %s.APIRevision : String;',[CN]); StringRes(Description.revision); AddLn('Class Function %s.APIID : String;',[CN]); StringRes(Description.id); AddLn('Class Function %s.APITitle : String;',[CN]); StringRes(Description.Title); AddLn('Class Function %s.APIDescription : String;',[CN]); StringRes(Description.Description); AddLn('Class Function %s.APIOwnerDomain : String;',[CN]); StringRes(Description.ownerDomain); AddLn('Class Function %s.APIOwnerName : String;',[CN]); StringRes(Description.ownerName); AddLn('Class Function %s.APIIcon16 : String;',[CN]); StringRes(Description.icons.x16); AddLn('Class Function %s.APIIcon32 : String;',[CN]); StringRes(Description.icons.x32); AddLn('Class Function %s.APIdocumentationLink : String;',[CN]); StringRes(Description.documentationLink); AddLn('Class Function %s.APIrootUrl : string;',[CN]); StringRes(Description.rootUrl); AddLn('Class Function %s.APIbasePath : string;',[CN]); StringRes(Description.BasePath); AddLn('Class Function %s.APIbaseURL : String;',[CN]); StringRes(Description.BaseURL); AddLn('Class Function %s.APIProtocol : string;',[CN]); StringRes(Description.protocol); AddLn('Class Function %s.APIservicePath : string;',[CN]); StringRes(Description.servicePath); AddLn('Class Function %s.APIbatchPath : String;',[CN]); StringRes(Description.batchPath); AddLn('Class Function %s.APIAuthScopes : TScopeInfoArray;',[CN]); Addln(''); AddLn('begin'); IncIndent; if not (Assigned(Description.Auth) and Assigned(Description.Auth.oauth2)) then AddLn('SetLength(Result,0);') else begin AddLn('SetLength(Result,%d);',[Length(Description.Auth.oauth2.Scopes)]); For I:=0 to Length(Description.Auth.oauth2.Scopes)-1 do begin S:=Description.Auth.oauth2.Scopes[i]; AddLn('Result[%d].Name:=%s;',[I,MakePascalString(S.Name,True)]); AddLn('Result[%d].Description:=%s;',[I,MakePascalString(S.Description,True)]); end; end; Addln(''); DecIndent; Addln('end;'); Addln(''); AddLn('Class Function %s.APINeedsAuth : Boolean;',[CN]); SimpleMethodBody([Format('Result:=%s;',[BoolToStr(Assigned(Description.Auth) and Assigned(Description.Auth.oauth2),'True','False')])]); AddLn('Class Procedure %s.RegisterAPIResources;',[CN]); Addln(''); AddLn('begin'); IncIndent; For I:=0 to FTypes.Count-1 do if FTypes[i].DataType=dtClass then AddLn('%s.RegisterObject;',[FTypes[i].PascalName]); DecIndent; Addln('end;'); Addln(''); CreateResourceAPIFunctionImplementations(GetAPIClassName,'',Description.resources); end; Procedure TDiscoveryJSONToPas.CreateResourceAPIFunctionImplementations(Const AClassName : String; Const APrefix : String; Resources : TSchemas); Var RN,CN,RCN : String; R : TSchema; begin CN:=AClassName; For R in Resources do begin if Assigned(R.Resources) then CreateResourceAPIFunctionImplementations(CN,ConstructResourcePrefix(APrefix,R),R.Resources); RN:=APrefix+PrettyPrint(R.Name); RCN:=R.TypeName; AddLn(''); AddLn('Function %s.Get%sInstance : %s;',[CN,RN,RCN]); AddLn(''); AddLn('begin'); IncIndent; AddLn('if (F%sInstance=Nil) then',[RN]); IncIndent; AddLn('F%sInstance:=Create%sResource;',[RN,RN]); DecIndent; AddLn('Result:=F%sInstance;',[RN]); DecIndent; AddLn('end;'); AddLn(''); AddLn('Function %s.Create%sResource : %s;',[CN,RN,RCN]); SimpleMethodBody([Format('Result:=Create%sResource(Self);',[RN])]); AddLn(''); AddLn('Function %s.Create%sResource(AOwner : TComponent) : %s;',[CN,RN,RCN]); SimpleMethodBody([Format('Result:=%s.Create(AOwner);',[RCN]), 'Result.API:=Self.API;']); AddLn(''); end; end; Procedure TDiscoveryJSONToPas.Execute; begin Source.Clear; CreateUnitClause; CreateHeader; FTypes:=TTypeDefs.Create(TTypeDef); try CollectTypes; CreateInterface; AddLn(''); AddLn('implementation'); AddLn(''); CreateImplementation; Addln(''); AddLn('initialization'); Addln(' %s.RegisterAPI;',[GetAPIClassName]); finally FTypes.Free; end; AddLn('end.'); end; Class Procedure TDiscoveryJSONToPas.RegisterAllObjects; begin TGoogleIcons.RegisterObject; TGoogleAuth2.RegisterObject; TGoogleAuth.RegisterObject; TArrayPropertyDef.RegisterObject; TPropertyDef.RegisterObject; TSchema.RegisterObject; TGoogleRestDescription.RegisterObject; TAnnotations.RegisterObject; TRestMethod.RegisterObject; TRestMethodParam.RegisterObject; TMediaUpload.RegisterObject; TMediaUploadProtocols.RegisterObject; TMediaUploadProtocolsSimple.RegisterObject; TMediaUploadProtocolsResumable.RegisterObject; TRequest.RegisterObject; TResponse.RegisterObject; end; end.