{ This file is part of the Free Pascal run time library. Copyright (c) 2019 by the Free Pascal development team webdata interface See the file COPYING.FPC, included in this distribution, for details about the copyright. 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. **********************************************************************} {$IFNDEF FPC_DOTTEDUNITS} unit fpwebdata; {$ENDIF FPC_DOTTEDUNITS} {$mode objfpc}{$H+} interface {$IFDEF FPC_DOTTEDUNITS} uses System.Classes, System.SysUtils, FpWeb.Http.Defs, FpWeb.Http.Base, Data.Db; {$ELSE FPC_DOTTEDUNITS} uses Classes, SysUtils, httpdefs, fphttp, db; {$ENDIF FPC_DOTTEDUNITS} type { TWebdataInputAdaptor } // Translate web request to input for the dataprovider. // Descendents must adapt the methods so they fit the particular JS/HTML engine used. TWebDataAction = (wdaUnknown,wdaRead,wdaUpdate,wdaInsert,wdaDelete); { TCustomWebdataInputAdaptor } TTransCodeEvent = Procedure (Sender : TObject; Var S : String); TCustomWebdataInputAdaptor = class(TComponent) private FAction: TWebDataAction; FOntransCode: TTransCodeEvent; FRequest: TRequest; FBatchCount : Integer; FRequestPathInfo : String; function GetAction: TWebDataAction; procedure SetRequest(const AValue: TRequest); Protected procedure reset; virtual; Function GetActionFromRequest : TWebDataAction; virtual; Public Function GetNextBatch : Boolean; virtual; Function TryParamValue(Const AParamName : String; out AValue : String) : Boolean; virtual; Function TryFieldValue(Const AFieldName : String; out AValue : String) : Boolean; virtual; Function HaveParamValue(Const AParamName : String) : boolean; Function HaveFieldValue(Const AFieldName : String) : boolean; Function GetParamValue(Const AParamName : String) : String; Function GetFieldValue(Const AFieldName : String) : String; Property Request : TRequest Read FRequest Write SetRequest; Property Action : TWebDataAction Read GetAction Write FAction; Property OnTransCode : TTransCodeEvent Read FOntransCode Write FOnTransCode; end; TCustomWebdataInputAdaptorClass = Class of TCustomWebdataInputAdaptor; TWebdataInputAdaptor = Class(TCustomWebdataInputAdaptor) Private FInputFormat: String; FProxy : TCustomWebdataInputAdaptor; procedure SetInputFormat(const AValue: String); Protected Procedure ClearProxy; Procedure CheckProxy; Function CreateProxy : TCustomWebdataInputAdaptor; virtual; Function GetActionFromRequest : TWebDataAction; override; Public Destructor Destroy; override; Function GetNextBatch : Boolean; override; Function TryParamValue(Const AParamName : String; out AValue : String) : Boolean; override; Function TryFieldValue(Const AFieldName : String; out AValue : String) : Boolean; override; Published Property InputFormat : String Read FInputFormat Write SetInputFormat; end; // Manage the data for the content producer // return a dataset for data, handles update/delete/insert in a simple TDataset manner. { TFPCustomWebDataProvider } TWebDataProviderOption = (wdpReadOnly,wdpDisableDelete,wdpDisableEdit,wdpDisableInsert); TWebDataProviderOptions = set of TWebDataProviderOption; TFPCustomWebDataProvider = Class(TComponent) private FAdaptor: TCustomWebdataInputAdaptor; FIDFieldName: String; FOptions: TWebDataProviderOptions; Protected // Check if adaptor and dataset are available. procedure CheckAdaptor; // Copy data from input to fields in dataset. Can be overridden Procedure CopyFieldData; virtual; Procedure DoUpdate; virtual; Procedure DoDelete; virtual; Procedure DoInsert; virtual; // Locate current record. Assumes that Procedure LocateCurrent; virtual; Procedure DoApplyParams; virtual; Function GetDataset : TDataset; virtual; abstract; Public // Perform an update on the dataset. Correct record is located first. Procedure Update; // Perform a delete on the dataset. Correct record is located first. Procedure Delete; // Perform an insert on the dataset. Procedure Insert; // Apply any parameters passed from request to the dataset. Used only in read operations Procedure ApplyParams; // get ID Field instance from dataset function GetIDField: TField; // Get value of ID field as string. After insert, this should contain the newly inserted ID. Function IDFieldValue : String; virtual; // The dataset Property Dataset : TDataset Read GetDataset; // Input adaptor property Adaptor : TCustomWebdataInputAdaptor Read FAdaptor Write FAdaptor; // Fieldname of ID field. If empty, field with pfInKey is searched. Property IDFieldName : String Read FIDFieldName Write FIDFieldName; // options Property Options : TWebDataProviderOptions Read FOptions Write FOptions; end; TFPCustomWebDataProviderClass = Class of TFPCustomWebDataProvider; { TFPWebDataProvider } // Simple descendent that has a datasource property, can be dropped on a module. TFPWebDataProvider = Class(TFPCustomWebDataProvider) private FDatasource: TDatasource; procedure SetDataSource(const AValue: TDatasource); Protected Function GetDataset : TDataset; override; Public procedure Notification(AComponent: TComponent; Operation: TOperation);override; Published Property DataSource : TDatasource Read FDatasource Write SetDataSource; end; // Handle request for read/create/update/delete and return a result. { TCustomHTTPDataContentProducer } // Support for transcoding from/to UTF-8. If outbound is true, the value is going from server to browser. TOnTranscodeEvent = Procedure (Sender : TObject; F : TField; Var S : String; Outbound : Boolean) of object; TCustomHTTPDataContentProducer = Class(THTTPContentProducer) Private FAllowPageSize: Boolean; FBeforeDelete: TNotifyEvent; FBeforeInsert: TNotifyEvent; FBeforeUpdate: TNotifyEvent; FDataProvider: TFPCustomWebDataProvider; FMetadata: Boolean; FOnTranscode: TOnTranscodeEvent; FPageSize: Integer; FPageStart: Integer; FSD: Boolean; FSortField: String; FAdaptor : TCustomWebdataInputAdaptor; function GetDataset: TDataset; procedure SetAdaptor(const AValue: TCustomWebDataInputAdaptor); procedure SetDataProvider(const AValue: TFPCustomWebDataProvider); Protected Procedure StartBatch(ResponseContent : TStream); virtual; Procedure NextBatchItem(ResponseContent : TStream); virtual; Procedure EndBatch(ResponseContent : TStream); virtual; Function GetDataContentType : String; virtual; procedure DatasetToStream(Stream: TStream); virtual;abstract; Function CreateAdaptor(ARequest : TRequest) : TCustomWebdataInputAdaptor; virtual; Procedure DoGetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); override; Procedure DoHandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean); override; Procedure DoUpdateRecord(ResponseContent : TStream); virtual; Procedure DoInsertRecord(ResponseContent : TStream); virtual; Procedure DoDeleteRecord(ResponseContent : TStream); virtual; Procedure DoReadRecords(ResponseContent : TStream); virtual; Procedure DoExceptionToStream(E : Exception; ResponseContent : TStream); virtual; abstract; procedure Notification(AComponent: TComponent; Operation: TOperation);override; Property Dataset: TDataset Read GetDataSet; // Before a record is about to be updated Property BeforeUpdate : TNotifyEvent Read FBeforeUpdate Write FBeforeUpdate; // Before a record is about to be inserted Property BeforeInsert : TNotifyEvent Read FBeforeInsert Write FBeforeInsert; // Before a record is about to be deleted Property BeforeDelete : TNotifyEvent Read FBeforeDelete Write FBeforeDelete; Public Constructor Create(AOwner : TComponent); override; Property Adaptor : TCustomWebDataInputAdaptor Read FAdaptor Write SetAdaptor; Property Provider : TFPCustomWebDataProvider read FDataProvider write SetDataProvider; Property DataContentType : String Read GetDataContentType; Published Property PageStart : Integer Read FPageStart Write FPageStart default 0; Property PageSize : Integer Read FPageSize Write FPageSize default 0; Property MetaData : Boolean Read FMetadata Write FMetaData Default False; Property SortField : String Read FSortField Write FSortField; Property SortDescending : Boolean Read FSD Write FSD default False; Property AllowPageSize : Boolean Read FAllowPageSize Write FAllowPageSize default True; Property OnTransCode : TOnTranscodeEvent Read FOnTranscode Write FOnTranscode; end; TCustomHTTPDataContentProducerClass = Class of TCustomHTTPDataContentProducer; { THTTPDataContentProducer } THTTPDataContentProducer = Class(TCustomHTTPDataContentProducer) private FOnConfigure: TNotifyEvent; FProxy : TCustomHTTPDataContentProducer; FOutputFormat: String; procedure SetOutputFormat(const AValue: String); Protected Procedure ClearProxy; Procedure CheckProxy; Function CreateProxy : TCustomHTTPDataContentProducer; virtual; procedure ConfigureProxy(AProxy: TCustomHTTPDataContentProducer); virtual; Public Destructor destroy; override; Published Property Adaptor; Property Provider; Property OutputFormat : String Read FOutputFormat Write SetOutputFormat; Property OnConfigureFormat : TNotifyEvent Read FOnConfigure Write FOnConfigure; end; TBeforeCreateWebDataProviderEvent = Procedure (Sender : TObject; Var AClass : TFPCustomWebDataProviderClass) of object; TWebDataProviderEvent = Procedure (Sender : TObject; AProvider : TFPCustomWebDataProvider) of object; //TWebDataCreateProviderEvent = Procedure (Sender : TObject; Const AProviderName : String; Out AnInstance : TFPCustomWebDataProvider) of object; TDataModuleClass = Class of TDataModule; { TWebInputAdaptorDef } TWebInputAdaptorDef = Class(TCollectionItem) private FClass: TCustomWebdataInputAdaptorClass; FName: String; procedure SetName(const AValue: String); protected Function CreateInstance(AOwner : TComponent) :TCustomWebdataInputAdaptor; virtual; Public Property AdaptorClass : TCustomWebdataInputAdaptorClass Read FClass Write FClass; Property Name : String Read FName Write SetName; end; { TWebInputAdaptorDefs } TWebInputAdaptorDefs = Class(TCollection) private function GetD(Index : Integer): TWebInputAdaptorDef; procedure SetD(Index : Integer; const AValue: TWebInputAdaptorDef); Public Function IndexOfAdaptor(Const AAdaptorName : String) : Integer; Function AddAdaptor(Const AAdaptorName : String; AClass : TCustomWebdataInputAdaptorClass) : TWebInputAdaptorDef; Property AdaptorDefs[Index : Integer] : TWebInputAdaptorDef Read GetD Write SetD; default; end; { THttpDataProducerDef } THttpDataProducerDef = Class(TCollectionItem) private FClass: TCustomHTTPDataContentProducerClass; FName: String; procedure SetName(const AValue: String); protected Function CreateInstance(AOwner : TComponent) :TCustomHTTPDataContentProducer; virtual; Public Property ProducerClass : TCustomHTTPDataContentProducerClass Read FClass Write FClass; Property Name : String Read FName Write SetName; end; { THttpDataProducerDefs } THttpDataProducerDefs = Class(TCollection) private function GetD(Index : Integer): THttpDataProducerDef; procedure SetD(Index : Integer; const AValue: THttpDataProducerDef); Public Function IndexOfProducer(Const AProducerName : String) : Integer; Function AddProducer(Const AProducerName : String; AClass : TCustomHTTPDataContentProducerClass) : THttpDataProducerDef; Property ProducerDefs[Index : Integer] : THttpDataProducerDef Read GetD Write SetD; default; end; { TWebDataProviderDef } TWebDataProviderDef = Class(TCollectionItem) private FAfterCreate: TWebDataProviderEvent; FBeforeCreate: TBeforeCreateWebDataProviderEvent; FPClass: TFPCustomWebDataProviderClass; FDataModuleClass : TDataModuleClass; FProviderName: String; procedure SetFPClass(const AValue: TFPCustomWebDataProviderClass); procedure SetProviderName(const AValue: String); protected Function CreateInstance(AOwner : TComponent; Out AContainer : TComponent) : TFPCUstomWebDataProvider; virtual; Property DataModuleClass : TDataModuleClass Read FDataModuleClass; Public Property ProviderName : String Read FProviderName Write SetProviderName; Property ProviderClass : TFPCustomWebDataProviderClass Read FPClass Write SetFPClass; Property BeforeCreate : TBeforeCreateWebDataProviderEvent Read FBeforeCreate Write FBeforeCreate; Property AfterCreate : TWebDataProviderEvent Read FAfterCreate Write FAfterCreate; end; { TWebDataProviderDefs } TWebDataProviderDefs = Class(TCollection) private function GetD(Index : Integer): TWebDataProviderDef; procedure SetD(Index : Integer; const AValue: TWebDataProviderDef); Public Function IndexOfProvider(Const AProviderName : String) : Integer; Function AddProvider(Const AProviderName : String) : TWebDataProviderDef; overload; Function AddProvider(Const AProviderName : String; AClass :TFPCustomWebDataProviderClass) : TWebDataProviderDef; overload; Property WebDataProviderDefs[Index : Integer] : TWebDataProviderDef Read GetD Write SetD; default; end; { TFPCustomWebDataProviderManager } TFPCustomWebDataProviderManager = Class(TComponent) Private FRegistering: Boolean; Protected procedure Initialize; virtual; // Provider support Procedure RemoveProviderDef(Const Index : Integer); virtual; abstract; function AddProviderDef(Const AProviderName : String) : TWebDataProviderDef; virtual; abstract; function IndexOfProviderDef(Const AProviderName : String) : Integer; virtual; abstract; function GetProviderDef(Index : Integer): TWebDataProviderDef; virtual; abstract; function GetProviderDefCount: Integer; virtual; abstract; // Inputadaptor support function AddInputAdaptorDef(Const AAdaptorName : String; AClass : TCustomWebdataInputAdaptorClass) : TWebInputAdaptorDef; virtual; abstract; function IndexOfInputAdaptorDef(Const AAdaptorName : String) : Integer; virtual; abstract; Procedure RemoveInputAdaptorDef(Index : Integer); virtual; abstract; function GetInputAdaptorDef(Index : Integer): TWebInputAdaptorDef; virtual; abstract; function GetInputAdaptorDefCount: Integer; virtual; abstract; // Outputproducer support function AddHttpDataProducerDef(Const AProducerName : String; AClass : TCustomHTTPDataContentProducerClass) : THttpDataProducerDef; virtual; abstract; function IndexOfHttpDataProducerDef(Const AProducerName : String) : Integer; virtual; abstract; Procedure RemoveHttpDataProducerDef(Index : Integer); virtual; abstract; function GetHttpDataProducerDef(Index : Integer): THttpDataProducerDef; virtual; abstract; function GetHttpDataProducerDefCount: Integer; virtual; abstract; Public // Input Provider support Procedure Unregisterprovider(Const AProviderName : String); Procedure RegisterDatamodule(Const AClass : TDatamoduleClass); Function RegisterProvider(Const AProviderName : String; AClass : TFPCustomWebDataProviderClass) : TWebDataProviderDef; overload; Function FindProviderDefByName(Const AProviderName : String) : TWebDataProviderDef; Function GetProviderDefByName(Const AProviderName : String) : TWebDataProviderDef; Function GetProvider(Const ADef : TWebDataProviderDef; AOwner : TComponent; Out AContainer : TComponent): TFPCustomWebDataProvider; Function GetProvider(Const AProviderName : String; AOwner : TComponent; Out AContainer : TComponent): TFPCustomWebDataProvider; // Input Adaptor support Function RegisterInputAdaptor(Const AAdaptorName : String; AClass : TCustomWebdataInputAdaptorClass) : TWebInputAdaptorDef; Procedure UnRegisterInputAdaptor(Const AAdaptorName : String); Function FindInputAdaptorDefByName(Const AAdaptorName : String) : TWebInputAdaptorDef; Function GetInputAdaptorDefByName(Const AAdaptorName : String) : TWebInputAdaptorDef; Function GetInputAdaptor(Const ADef : TWebInputAdaptorDef; AOwner : TComponent = Nil): TCustomWebdataInputAdaptor; overload; Function GetInputAdaptor(Const AAdaptorName : String; AOwner : TComponent = Nil): TCustomWebdataInputAdaptor; overload; // Outputproducer support function RegisterDataProducer(Const AProducerName : String; AClass : TCustomHTTPDataContentProducerClass) : THttpDataProducerDef; Procedure UnRegisterDataProducer(Const AProducerName : String); function FindDataProducerDefByName(Const AProducerName : String) : THttpDataProducerDef; function GetDataProducerDefByName(Const AProducerName : String) : THttpDataProducerDef; function GetDataProducer(ADef : THttpDataProducerDef; AOwner : TComponent) : TCustomHTTPDataContentProducer; function GetDataProducer(Const AProducerName: String; AOwner : TComponent) : TCustomHTTPDataContentProducer; // properties Property Registering : Boolean Read FRegistering; Property ProviderCount : Integer Read GetProviderDefCount; Property ProviderDefs[Index : Integer] : TWebDataProviderDef Read GetProviderDef; Property InputAdaptorDefs[Index : Integer] : TWebInputAdaptorDef Read GetInputAdaptorDef; Property InputAdaptorDefCount : Integer Read GetInputAdaptorDefCount; Property DataProducerDefs[Index : Integer] : THttpDataProducerDef Read GetHttpDataProducerDef; Property DataProducerDefCount : Integer Read GetHttpDataProducerDefCount; end; TFPCustomWebDataProviderManagerClass = Class of TFPCustomWebDataProviderManager; { TFPWebDataProviderManager } TFPWebDataProviderManager = Class(TFPCustomWebDataProviderManager) Private FProviderDefs : TWebDataProviderDefs; FAdaptorDefs : TWebInputAdaptorDefs; FProducerDefs : THttpDataProducerDefs; Protected Procedure RemoveProviderDef(Const Index : Integer); override; function AddProviderDef(Const AProviderName : String) : TWebDataProviderDef; override; function IndexOfProviderDef(Const AProviderName : String) : Integer; override; function GetProviderDef(Index : Integer): TWebDataProviderDef; override; function GetProviderDefCount: Integer; override; // Inputadaptor support function AddInputAdaptorDef(Const AAdaptorName : String; AClass : TCustomWebdataInputAdaptorClass) : TWebInputAdaptorDef; Override; function IndexOfInputAdaptorDef(Const AAdaptorName : String) : Integer; Override; procedure RemoveInputAdaptorDef(Index : Integer); Override; function GetInputAdaptorDef(Index : Integer): TWebInputAdaptorDef; Override; function GetInputAdaptorDefCount: Integer; Override; // Outputproducer support function AddHttpDataProducerDef(Const AProducerName : String; AClass : TCustomHTTPDataContentProducerClass) : THttpDataProducerDef; Override; function IndexOfHttpDataProducerDef(Const AProducerName : String) : Integer; Override; Procedure RemoveHttpDataProducerDef(Index : Integer); Override; function GetHttpDataProducerDef(Index : Integer): THttpDataProducerDef; Override; function GetHttpDataProducerDefCount: Integer; Override; Public Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; end; THandleWebDataEvent = Procedure (Sender : TObject;AProvider : TFPCustomWebDataProvider; Var Handled : Boolean) of object; TWebDataEvent = Procedure (Sender : TObject; AProvider : TFPCustomWebDataProvider) of object; TContentProducerEvent = Procedure (Sender : TObject; Var AContentProducer: TCustomHTTPDataContentProducer) of object; TInputAdaptorEvent = Procedure (Sender : TObject; Var AInputAdaptor : TCustomWebdataInputAdaptor) of object; TContentEvent = Procedure (Sender : TObject; Content : TStream) of Object; TGetWebDataProviderEvent = Procedure (Sender : TObject; Const AProviderName : String; Var AnInstance : TFPCustomWebDataProvider) of object; { TFPCustomWebDataModule } { TFPCustomWebProviderDataModule } TFPCustomWebProviderDataModule = Class(TSessionHTTPModule) Private FAfterDelete: TWebDataEvent; FAfterInsert: TWebDataEvent; FAfterRead: TWebDataEvent; FAfterUpdate: TWebDataEvent; FBeforeDelete: THandleWebDataEvent; FBeforeInsert: THandleWebDataEvent; FBeforeRead: THandleWebDataEvent; FBeforeUpdate: THandleWebDataEvent; FContentProducer: TCustomHTTPDataContentProducer; FInputAdaptor: TCustomWebdataInputAdaptor; FOnContent: TContentEvent; FOnGetContentProducer: TContentProducerEvent; FOnGetInputAdaptor: TInputAdaptorEvent; FOnGetProvider: TGetWebDataProviderEvent; FRequest: TRequest; FResponse: TResponse; FUseProviderManager: Boolean; function GetAdaptor: TCustomWebDataInputAdaptor; function GetContentProducer: TCustomHTTPDataContentProducer; Procedure ReadWebData(AProvider : TFPCustomWebDataProvider); Procedure InsertWebData(AProvider : TFPCustomWebDataProvider); procedure SetContentProducer(const AValue: TCustomHTTPDataContentProducer); procedure SetInputAdaptor(const AValue: TCustomWebdataInputAdaptor); Procedure UpdateWebData(AProvider : TFPCustomWebDataProvider); Procedure DeleteWebData(AProvider : TFPCustomWebDataProvider); Protected function GetProvider(const AProviderName: String; Out AContainer : TComponent): TFPCustomWebDataProvider; virtual; procedure ProduceContent(AProvider : TFPCustomWebDataProvider); virtual; Procedure DoReadWebData(AProvider : TFPCustomWebDataProvider); virtual; Procedure DoInsertWebData(AProvider : TFPCustomWebDataProvider); virtual; Procedure DoUpdateWebData(AProvider : TFPCustomWebDataProvider); virtual; Procedure DoDeleteWebData(AProvider : TFPCustomWebDataProvider); virtual; // Input adaptor to use when processing request. Can be nil, and provided in OnGetInputAdaptor Property InputAdaptor : TCustomWebdataInputAdaptor Read FInputAdaptor Write SetInputAdaptor; // Content producer to produce response content Property ContentProducer : TCustomHTTPDataContentProducer Read FContentProducer Write SetContentProducer; // Triggered before a read request is started Property BeforeRead : THandleWebDataEvent Read FBeforeRead Write FBeforeRead; // Triggered after a read request completed Property AfterRead : TWebDataEvent Read FAfterRead Write FAfterRead; // Triggered before an insert request is started Property BeforeInsert : THandleWebDataEvent Read FBeforeInsert Write FBeforeInsert; // Triggered after an insert request completed Property AfterInsert : TWebDataEvent Read FAfterInsert Write FAfterInsert; // Triggered before an update request is started Property BeforeUpdate : THandleWebDataEvent Read FBeforeUpdate Write FBeforeUpdate; // Triggered after an update request completed Property AfterUpdate : TWebDataEvent Read FAfterUpdate Write FAfterUpdate; // Triggered before a delete request is started Property BeforeDelete : THandleWebDataEvent Read FBeforeDelete Write FBeforeDelete; // Triggered after an insert request completed Property AfterDelete : TWebDataEvent Read FAfterDelete Write FAfterDelete; // Triggered when the input adaptor needs to be determined. Property OnGetInputAdaptor : TInputAdaptorEvent Read FOnGetInputAdaptor Write FOnGetInputAdaptor; // Triggered when the WebDataProvider needs to be determined. Property OnGetProvider : TGetWebDataProviderEvent Read FOnGetProvider Write FOnGetprovider; // Triggered when the contentproducer needs to be determined Property OnGetContentProducer : TContentProducerEvent Read FOnGetContentProducer Write FOnGetContentProducer; // Triggered when the content has been created. Property OnContent : TContentEvent Read FOnContent Write FOnContent; // Set to False if the ProviderManager should not be searched for a provider Property UseProviderManager : Boolean Read FUseProviderManager Write FUseProviderManager default True; Public Constructor CreateNew(AOwner : TComponent; CreateMode : Integer); override; Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override; // Access to request Property Request: TRequest Read FRequest; // Access to response Property Response: TResponse Read FResponse; end; TFPWebProviderDataModule = Class(TFPCustomWebProviderDataModule) Published Property Kind; Property BaseURL; Property AfterInitModule; Property Session; Property CreateSession; Property InputAdaptor; Property ContentProducer; Property UseProviderManager; Property OnGetContentProducer; Property BeforeRead; Property AfterRead; Property BeforeInsert; Property AfterInsert; Property BeforeUpdate; Property AfterUpdate; Property BeforeDelete; Property AfterDelete; Property OnGetInputAdaptor; Property OnGetProvider; Property OnContent; Property OnNewSession; Property OnSessionExpired; property CORS; end; Var WebDataProviderManagerClass : TFPCustomWebDataProviderManagerClass = TFPWebDataProviderManager; Function WebDataProviderManager : TFPCustomWebDataProviderManager; implementation { $define wmdebug} {$ifdef wmdebug} uses dbugintf; {$endif} Resourcestring SErrNoIDField = 'No key field found'; SErrNoAdaptor = 'No adaptor assigned'; SErrNoDataset = 'No dataset assigned'; SErrNoIDValue = 'No key value specified'; SErrCouldNotLocateRecord = 'Could not locate record with value "%s" for key field "%s"'; SErrNoDatasource = 'No datasource property available'; SErrNoAction = 'Cannot determine action from request'; SErrDuplicateWebDataProvider = 'Duplicate webdata provider'; SErrUnknownWebDataProvider = 'Unknown webdata provider: "%s"'; SErrContentProviderRequest = 'Content provider "%s" does not handle request.'; SErrUnknownProviderAction = 'Cannot determine action for provider "%s".'; SErrDuplicateAdaptor = 'Duplicate input adaptor name: "%s"'; SErrDuplicateHTTPDataProducer = 'Duplicate web data output content producer name: "%s"'; SErrUnknownInputAdaptor = 'Unknown web data input adaptor name: "%s"'; SErrUnknownHTTPDataProducer = 'Unknown web data output content producer name: "%s"'; SErrActionNotAllowed = 'Options of provider %s do not allow %s.'; SEditing = 'editing'; SDeleting = 'deleting'; SInserting = 'inserting'; { TCustomWebdataInputAdaptor } { TFPCustomWebDataProvider } procedure TCustomWebdataInputAdaptor.SetRequest(const AValue: TRequest); begin If FRequest=AValue then Exit; FRequest:=AValue; Reset; end; procedure TCustomWebdataInputAdaptor.reset; begin {$ifdef wmdebug}SendDebugFmt('TCustomWebdataInputAdaptor.Reset (%s)',[FRequestPathInfo]);{$endif} FBatchCount:=0; Faction:=wdaUnknown; FRequestPathInfo:=''; end; function TCustomWebdataInputAdaptor.GetActionFromRequest: TWebDataAction; Var N : String; begin Result:=wdaUnknown; If (Request<>Nil) then begin if (FRequestPathInfo='') then FRequestPathInfo:=Request.GetNextPathInfo; N:=lowercase(FRequestPathInfo); {$ifdef wmdebug}SendDebugFmt('TCustomWebdataInputAdaptor.GetActionFromRequest : %s (%s)',[n,Request.Pathinfo]);{$endif} If (N='read') then Result:=wdaRead else If (N='insert') then Result:=wdaInsert else If (N='delete') then Result:=wdaDelete else If (N='update') then Result:=wdaUpdate; end; end; function TCustomWebdataInputAdaptor.GetAction: TWebDataAction; begin If (Faction=wdaUnknown) then FAction:=GetActionFromRequest; Result:=FAction; If (Result=wdaUnknown) then Raise EFPHTTPError.Create(SErrNoAction) end; function TCustomWebdataInputAdaptor.GetNextBatch: Boolean; begin Result:=(FBatchCount=0); Inc(FBatchCount); end; function TCustomWebdataInputAdaptor.TryParamValue(const AParamName: String; out AValue: String): Boolean; Var L : TStrings; I : Integer; N : String; begin Result:=False; If (Request.Method='GET') then L:=Request.QueryFields else // (Request.Method='POST') then L:=FRequest.ContentFields; I:=L.IndexOfName(AParamName); Result:=(I<>-1); If Result then L.GetNameValue(I,N,AValue); If (AValue<>'') and Assigned(FOnTranscode) then FOnTransCode(Self,Avalue); end; function TCustomWebdataInputAdaptor.TryFieldValue(const AFieldName: String; out AValue: String): Boolean; begin Result:=TryParamValue(AFieldName,AValue); end; function TCustomWebdataInputAdaptor.HaveParamValue(const AParamName: String ): boolean; Var S: String; begin Result:=TryParamValue(AParamName,S); end; function TCustomWebdataInputAdaptor.HaveFieldValue(const AFieldName: String ): Boolean; Var S: String; begin Result:=TryFieldValue(AFieldName,S); end; function TCustomWebdataInputAdaptor.GetParamValue(const AParamName: String): String; begin If not TryParamValue(AParamName,Result) then Result:=''; end; function TCustomWebdataInputAdaptor.GetFieldValue(const AFieldName: String): String; begin If not TryFieldValue(AFieldName,Result) then Result:=''; end; { TFPCustomWebDataProvider } procedure TFPCustomWebDataProvider.CopyFieldData; Var I : Integer; F : TField; S : String; DS : TDataset; begin DS:=Dataset; For I:=0 to DS.Fields.Count-1 do begin F:=DS.Fields[i]; If (F.DataType<>ftAutoInc) or (DS.State=dsInsert) then If ADaptor.TryFieldValue(F.FieldName,S) then begin If (S<>'') then F.AsString:=S else if DS.State=dsEdit then F.Clear; end; end; end; procedure TFPCustomWebDataProvider.DoUpdate; Var DS : TDataset; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.DoUpdate: Updating record');{$endif} DS:=Dataset; LocateCurrent; DS.Edit; CopyFieldData; DS.Post; {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.DoUpdate: Done Updating record');{$endif} end; procedure TFPCustomWebDataProvider.DoDelete; Var DS : TDataset; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.DoDelete: Deleting record');{$endif} LocateCurrent; DS:=Dataset; DS.Delete; end; procedure TFPCustomWebDataProvider.DoInsert; Var DS : TDataset; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.DoInsert: Inserting record');{$endif} DS:=Dataset; DS.Append; CopyFieldData; DS.Post; end; Function TFPCustomWebDataProvider.GetIDField : TField; Var FN : String; I : Integer; begin Result:=Nil; FN:=IDFieldName; If (FN='') then begin I:=0; While (Result=Nil) and (IV) do Dataset.Next; If Dataset.EOF and (F.AsString<>V) then Raise EFPHTTPError.CreateFmt(SErrCouldNotLocateRecord,[V,F.FieldName]); end; end; procedure TFPCustomWebDataProvider.DoApplyParams; begin // Do nothing end; procedure TFPCustomWebDataProvider.CheckAdaptor; begin if Not Assigned(Adaptor) then Raise EFPHTTPError.Create(SErrNoAdaptor); if Not Assigned(Dataset) then Raise EFPHTTPError.Create(SerrNoDataset); end; procedure TFPCustomWebDataProvider.Update; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Update enter');{$endif} If ((Options * [wdpReadOnly,wdpDisableEdit])<>[]) then Raise EFPHTTPError.CreateFmt(SErrActionNotAllowed,[Name,SEditing]); CheckAdaptor; DoUpdate; {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Update leave');{$endif} end; procedure TFPCustomWebDataProvider.Delete; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Delete enter');{$endif} If ((Options * [wdpReadOnly,wdpDisableDelete])<>[]) then Raise EFPHTTPError.CreateFmt(SErrActionNotAllowed,[Name,SDeleting]); CheckAdaptor; DoDelete; {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Delete leave');{$endif} end; procedure TFPCustomWebDataProvider.Insert; begin {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Insert enter');{$endif} If ((Options * [wdpReadOnly,wdpDisableInsert])<>[]) then Raise EFPHTTPError.CreateFmt(SErrActionNotAllowed,[Name,SInserting]); CheckAdaptor; DoInsert; {$ifdef wmdebug}SendDebug('TFPCustomWebDataProvider.Insert leave');{$endif} end; procedure TFPCustomWebDataProvider.ApplyParams; begin CheckAdaptor; DoApplyParams; end; function TFPCustomWebDataProvider.IDFieldValue: String; begin Result:=GetIDField.DisplayText; end; { TFPWebDataProvider } procedure TFPWebDataProvider.SetDataSource(const AValue: TDatasource); begin if FDataSource=AValue then exit; If Assigned(FDatasource) then FDataSource.RemoveFreeNotification(Self); FDataSource:=AValue; If Assigned(FDatasource) then FDataSource.FreeNotification(Self); end; function TFPWebDataProvider.GetDataset: TDataset; begin If Assigned(DataSource) then Result:=Datasource.Dataset else Raise EFPHTTPError.Create(SErrNoDatasource) end; procedure TFPWebDataProvider.Notification(AComponent: TComponent; Operation: TOperation); begin If (Operation=opRemove) and (AComponent=FDatasource) then FDatasource:=Nil; inherited Notification(AComponent, Operation); end; { TCustomHTTPDataContentProducer } function TCustomHTTPDataContentProducer.GetDataset: TDataset; begin If Assigned(FDataProvider) then Result:=FDataProvider.Dataset; end; procedure TCustomHTTPDataContentProducer.SetAdaptor( const AValue: TCustomWebDataInputAdaptor); begin If FAdaptor=AValue then exit; If Assigned(FAdaptor) then FAdaptor.RemoveFreeNotification(Self); FAdaptor:=AValue; If Assigned(FAdaptor) then FAdaptor.FreeNotification(Self); end; procedure TCustomHTTPDataContentProducer.Notification(AComponent: TComponent; Operation: TOperation); begin If (Operation=opRemove) then if (AComponent=FDataProvider) then FDataProvider:=Nil else if (AComponent=FAdaptor) then FAdaptor:=Nil; inherited Notification(AComponent, Operation); end; procedure TCustomHTTPDataContentProducer.SetDataProvider( const AValue: TFPCustomWebDataProvider); begin if FDataProvider=AValue then exit; If Assigned(FDataProvider) then FDataProvider.RemoveFreeNotification(Self); FDataProvider:=AValue; If Assigned(FDataProvider) then FDataProvider.FreeNotification(Self); end; procedure TCustomHTTPDataContentProducer.StartBatch(ResponseContent: TStream); begin // Do nothing end; procedure TCustomHTTPDataContentProducer.NextBatchItem(ResponseContent: TStream ); begin // do nothing end; procedure TCustomHTTPDataContentProducer.EndBatch(ResponseContent: TStream); begin // do nothing end; function TCustomHTTPDataContentProducer.GetDataContentType: String; begin Result:=''; end; function TCustomHTTPDataContentProducer.CreateAdaptor(ARequest : TRequest): TCustomWebdataInputAdaptor; begin Result:=TCustomWebdataInputAdaptor.Create(Self); Result.Request:=ARequest end; procedure TCustomHTTPDataContentProducer.DoGetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); Var B : Boolean; A : TCustomWebdataInputAdaptor; begin {$ifdef wmdebug}SendDebugFmt('Request content %s',[ARequest.Content]);{$endif} B:=(Adaptor=Nil); if B then begin A:=CreateAdaptor(ARequest); Adaptor:=A; end; try try Case Adaptor.Action of wdaRead : DoReadRecords(Content); wdaInsert, wdaUpdate, wdaDelete : begin {$ifdef wmdebug}SendDebug('Starting batch Loop');{$endif} StartBatch(Content); While Adaptor.GetNextBatch do begin {$ifdef wmdebug}SendDebug('Next batch item');{$endif} NextBatchItem(Content); Case Adaptor.Action of wdaInsert : DoInsertRecord(Content); wdaUpdate : DoUpdateRecord(Content); wdaDelete : DoDeleteRecord(Content); else inherited DoGetContent(ARequest, Content,Handled); end; end; EndBatch(Content); {$ifdef wmdebug}SendDebug('Ended batch Loop');{$endif} end; else Raise EFPHTTPError.Create(SErrNoAction); end; Handled:=true; except On E : Exception do begin DoExceptionToStream(E,Content); Handled:=True; end; end; finally If B then FreeAndNil(A); end; end; procedure TCustomHTTPDataContentProducer.DoHandleRequest(ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); Var S : String; begin inherited DoHandleRequest(ARequest, AResponse, Handled); If Handled then begin S:=GetDataContentType; If (S<>'') then AResponse.ContentType:=S; end; end; procedure TCustomHTTPDataContentProducer.DoUpdateRecord(ResponseContent: TStream); begin {$ifdef wmdebug}SendDebug('DoUpdateRecord: Updating record');{$endif} If Assigned(FBeforeUpdate) then FBeforeUpdate(Self); Provider.Update; {$ifdef wmdebug}SendDebug('DoUpdateRecord: Updated record');{$endif} end; procedure TCustomHTTPDataContentProducer.DoInsertRecord(ResponseContent: TStream); begin If Assigned(FBeforeInsert) then FBeforeInsert(Self); Provider.Insert; end; procedure TCustomHTTPDataContentProducer.DoDeleteRecord(ResponseContent: TStream); begin If Assigned(FBeforeDelete) then FBeforeDelete(Self); Provider.Delete; end; procedure TCustomHTTPDataContentProducer.DoReadRecords(ResponseContent: TStream); Var DS : TDataset; begin DS:=Provider.Dataset; If Not DS.Active then begin {$ifdef wmdebug}SendDebug('Doreadrecords: Applying parameters');{$endif} Provider.ApplyParams; {$ifdef wmdebug}SendDebug('Doreadrecords: Applied parameters');{$endif} DS.Open; {$ifdef wmdebug}SendDebug('Doreadrecords: opened dataset');{$endif} end; DatasetToStream(ResponseContent); end; constructor TCustomHTTPDataContentProducer.Create(AOwner: TComponent); begin inherited Create(AOwner); FAllowPagesize:=True; end; { TWebDataProviderDef } procedure TWebDataProviderDef.SetFPClass( const AValue: TFPCustomWebDataProviderClass); begin if FPClass=AValue then exit; FPClass:=AValue; end; procedure TWebDataProviderDef.SetProviderName(const AValue: String); begin if FProviderName=AValue then exit; FProviderName:=AValue; end; Function TWebDataProviderDef.CreateInstance(AOwner: TComponent; Out AContainer : TComponent) : TFPCUstomWebDataProvider; Var AClass : TFPCustomWebDataProviderClass; DM : TDataModule; C : TComponent; begin Result:=Nil; {$ifdef wmdebug}SendDebug(Format('Creating instance for %s',[Self.ProviderName]));{$endif} If Assigned(FDataModuleClass) then begin {$ifdef wmdebug}SendDebug(Format('Creating datamodule from class %d ',[Ord(Assigned(FDataModuleClass))]));{$endif} DM:=FDataModuleClass.Create(AOwner); {$ifdef wmdebug}SendDebug(Format('Created datamodule from class %s ',[DM.ClassName]));{$endif} C:=DM.FindComponent(FProviderName); If (C<>Nil) and (C is TFPCUstomWebDataProvider) then Result:=TFPCUstomWebDataProvider(C) else begin FreeAndNil(DM); Raise EFPHTTPError.CreateFmt(SErrUnknownWebDataProvider,[FProviderName]); end; end else DM:=TDataModule.CreateNew(AOwner,0); AContainer:=DM; If (Result=Nil) then begin {$ifdef wmdebug}SendDebug(Format('Creating from class pointer %d ',[Ord(Assigned(FPClass))]));{$endif} AClass:=FPCLass; If Assigned(FBeforeCreate) then FBeforeCreate(Self,AClass); Result:=AClass.Create(AContainer); end; If Assigned(FAfterCreate) then FAfterCreate(Self,Result); end; { TWebDataProviderDefs } function TWebDataProviderDefs.GetD(Index : Integer): TWebDataProviderDef; begin Result:=TWebDataProviderDef(Items[Index]) end; procedure TWebDataProviderDefs.SetD(Index : Integer; const AValue: TWebDataProviderDef); begin Items[Index]:=AValue; end; function TWebDataProviderDefs.IndexOfProvider(const AProviderName: String ): Integer; begin Result:=Count-1; While (Result>=0) and (CompareText(GetD(Result).ProviderName,AProviderName)<>0) do Dec(Result); end; function TWebDataProviderDefs.AddProvider(const AProviderName: String ): TWebDataProviderDef; begin If IndexOfProvider(AProviderName)=-1 then begin Result:=Add as TWebDataProviderDef; Result.ProviderName:=AProviderName; end else Raise EFPHTTPError.CreateFmt(SErrDuplicateWebDataProvider,[AProviderName]); end; function TWebDataProviderDefs.AddProvider(const AProviderName: String; AClass: TFPCustomWebDataProviderClass): TWebDataProviderDef; begin Result:=AddProvider(AProviderName); Result.ProviderClass:=AClass; end; Var AWebDataProviderManager : TFPCustomWebDataProviderManager; Function WebDataProviderManager : TFPCustomWebDataProviderManager; begin If (AWebDataProviderManager=Nil) then begin If WebDataProviderManagerClass=Nil then WebDataProviderManagerClass:=TFPWebDataProviderManager; AWebDataProviderManager:=WebDataProviderManagerClass.Create(Nil); AWebDataProviderManager.Initialize; end; Result:=AWebDataProviderManager; end; { TFPCustomWebDataProviderManager } procedure TFPCustomWebDataProviderManager.Initialize; begin // Do nothing end; procedure TFPCustomWebDataProviderManager.Unregisterprovider( const AProviderName: String); Var I : Integer; begin I:=IndexOfProviderDef(AProviderName); If (I<>-1) then RemoveProviderDef(I) else Raise EFPHTTPError.CreateFmt(SErrUnknownWebDataProvider,[AProviderName]); end; procedure TFPCustomWebDataProviderManager.RegisterDatamodule( const AClass: TDatamoduleClass); Var DM : TDatamodule; I,J : Integer; C : TComponent; D : TWebDataProviderDef; begin FRegistering:=True; try DM:=AClass.Create(Self); try For I:=0 to DM.ComponentCount-1 do begin C:=DM.Components[i]; if C is TFPCustomWebDataProvider then begin J:=IndexOfProviderDef(C.Name); If (J<>-1) then Raise EFPHTTPError.CreateFmt(SErrDuplicateWebDataProvider,[C.Name]); D:=AddProviderDef(C.Name); {$ifdef wmdebug}SendDebug('Registering provider '+C.Name);{$endif} D.FDataModuleClass:=TDataModuleClass(DM.ClassType); end; end; finally DM.Free; end; finally FRegistering:=False; end; end; function TFPCustomWebDataProviderManager.RegisterProvider( const AProviderName: String; AClass: TFPCustomWebDataProviderClass ): TWebDataProviderDef; Var I : Integer; begin FRegistering:=True; try I:=IndexOfProviderDef(AProviderName); If (I<>-1) then Raise EFPHTTPError.CreateFmt(SErrDuplicateWebDataProvider,[AProviderName]); Result:=AddProviderDef(AProviderName); Result.ProviderClass:=AClass; finally FRegistering:=False; end; end; function TFPCustomWebDataProviderManager.FindProviderDefByName( const AProviderName: String): TWebDataProviderDef; Var I : integer; begin I:=IndexOfProviderDef(AProviderName); If (I=-1) then Result:=Nil else Result:=GetProviderDef(I); end; function TFPCustomWebDataProviderManager.GetProviderDefByName( const AProviderName: String): TWebDataProviderDef; begin Result:=FindProviderDefByName(AProviderName); If (Result=Nil) then Raise EFPHTTPError.CreateFmt(SErrUnknownWebDataProvider,[AProviderName]); end; function TFPCustomWebDataProviderManager.GetProvider( const AProviderName: String; AOwner: TComponent; Out AContainer : TComponent): TFPCustomWebDataProvider; Var D : TWebDataProviderDef; begin D:=GetProviderDefByname(AProviderName); Result:=GetProvider(D,AOwner,AContainer); end; function TFPCustomWebDataProviderManager.RegisterInputAdaptor( const AAdaptorName: String; AClass: TCustomWebdataInputAdaptorClass ): TWebInputAdaptorDef; begin If IndexOfInputAdaptorDef(AAdaptorName)<>-1 then Raise EFPHTTPError.CreateFmt(SErrDuplicateAdaptor,[AAdaptorName]); Result:=AddInputAdaptorDef(AAdaptorName,AClass); end; procedure TFPCustomWebDataProviderManager.UnRegisterInputAdaptor( const AAdaptorName: String); Var I : Integer; begin I:=IndexOfInputAdaptorDef(AAdaptorName); If (I<>-1) then RemoveInputAdaptorDef(I); end; function TFPCustomWebDataProviderManager.FindInputAdaptorDefByName( const AAdaptorName: String): TWebInputAdaptorDef; Var I: integer; begin I:=IndexOfInputAdaptorDef(AAdaptorName); If I<>-1 then Result:=GetInputAdaptorDef(I) else Result:=Nil; end; function TFPCustomWebDataProviderManager.GetInputAdaptorDefByName( const AAdaptorName: String): TWebInputAdaptorDef; begin Result:=FindInputAdaptorDefByName(AAdaptorName); If (Result=Nil) then Raise EFPHTTPError.CreateFmt(SErrUnknownInputAdaptor,[AAdaptorName]); end; function TFPCustomWebDataProviderManager.GetInputAdaptor( const ADef: TWebInputAdaptorDef; AOwner: TComponent ): TCustomWebdataInputAdaptor; Var O: TComponent; begin O:=AOwner; If (O=Nil) then O:=Self; Result:=ADef.CreateInstance(AOwner); end; function TFPCustomWebDataProviderManager.GetInputAdaptor( const AAdaptorName: String; AOwner: TComponent): TCustomWebdataInputAdaptor; begin Result:=GetInputAdaptor(GetInputAdaptorDefByName(AAdaptorName),Aowner); end; function TFPCustomWebDataProviderManager.RegisterDataProducer( const AProducerName: String; AClass: TCustomHTTPDataContentProducerClass ): THttpDataProducerDef; begin If IndexOfHttpDataProducerDef(AProducerName)<>-1 then Raise EFPHTTPError.CreateFmt(SErrDuplicateHTTPDataProducer,[AProducerName]); Result:=AddHttpDataProducerDef(AProducerName,AClass); end; procedure TFPCustomWebDataProviderManager.UnRegisterDataProducer( const AProducerName: String); Var I : Integer; begin I:=IndexOfHttpDataProducerDef(AProducerName); If (I<>-1) then RemoveHttpDataProducerDef(I); end; function TFPCustomWebDataProviderManager.FindDataProducerDefByName( const AProducerName: String): THttpDataProducerDef; Var I : Integer; begin I:=IndexOfHttpDataProducerDef(AProducerName); If (I<>-1) then Result:=GetHttpDataProducerDef(I) else Result:=Nil; end; function TFPCustomWebDataProviderManager.GetDataProducerDefByName( const AProducerName: String): THttpDataProducerDef; begin Result:=FindDataProducerDefByName(AProducerName); If (Result=Nil) then Raise EFPHTTPError.CreateFmt(SErrUnknownHTTPDataProducer,[AProducerName]); end; function TFPCustomWebDataProviderManager.GetDataProducer( ADef: THttpDataProducerDef; AOwner: TComponent ): TCustomHTTPDataContentProducer; Var O : TComponent; begin O:=AOwner; If (O=Nil) then O:=Self; Result:=ADef.CreateInstance(Aowner); end; function TFPCustomWebDataProviderManager.GetDataProducer( const AProducerName: String; AOwner : TComponent): TCustomHTTPDataContentProducer; begin Result:=GetDataProducer(GetDataProducerDefByName(AProducerName),Aowner); end; function TFPCustomWebDataProviderManager.GetProvider( const ADef: TWebDataProviderDef; AOwner: TComponent; Out AContainer : TComponent): TFPCustomWebDataProvider; Var O : TComponent; begin If AOwner<>Nil then O:=Self else O:=AOwner; Result:=ADef.CreateInstance(O,AContainer); end; { TFPWebDataProviderManager } constructor TFPWebDataProviderManager.Create(AOwner: TComponent); begin inherited Create(AOwner); FProviderDefs:=TWebDataProviderDefs.Create(TWebDataProviderDef); FAdaptorDefs:=TWebInputAdaptorDefs.Create(TWebInputAdaptorDef); FProducerDefs:=THttpDataProducerDefs.Create(THttpDataProducerDef); end; destructor TFPWebDataProviderManager.Destroy; begin FreeAndNil(FProviderDefs); FreeAndNil(FAdaptorDefs); FreeAndNil(FProducerDefs); inherited Destroy; end; procedure TFPWebDataProviderManager.RemoveProviderDef(const Index: Integer); begin FProviderDefs.Delete(Index); end; function TFPWebDataProviderManager.AddProviderDef(const AProviderName: String ): TWebDataProviderDef; begin Result:=FProviderDefs.AddProvider(AProviderName); end; function TFPWebDataProviderManager.IndexOfProviderDef(const AProviderName: String ): Integer; begin {$ifdef wmdebug}Senddebug('Entering indexofproviderdef : '+AProviderName);{$endif} {$ifdef wmdebug}Senddebug(Format('Providerdefs assigned: %d ',[Ord(Assigned(FProviderDefs))]));{$endif} Result:=FProviderDefs.IndexOfProvider(AProviderName); {$ifdef wmdebug}Senddebug('Exitining indexofproviderdef: '+IntToStr(result));{$endif} end; function TFPWebDataProviderManager.GetProviderDef(Index: Integer ): TWebDataProviderDef; begin Result:=FProviderDefs[Index]; end; function TFPWebDataProviderManager.GetProviderDefCount: Integer; begin Result:=FProviderDefs.Count; end; function TFPWebDataProviderManager.AddInputAdaptorDef( const AAdaptorName: String; AClass: TCustomWebdataInputAdaptorClass ): TWebInputAdaptorDef; begin Result:=FAdaptorDefs.AddAdaptor(AAdaptorName,AClass); end; function TFPWebDataProviderManager.IndexOfInputAdaptorDef( const AAdaptorName: String): Integer; begin Result:=FAdaptorDefs.IndexOfAdaptor(AAdaptorName); end; Procedure TFPWebDataProviderManager.RemoveInputAdaptorDef(Index : integer); begin If (Index<>-1) then FAdaptorDefs.Delete(Index); end; function TFPWebDataProviderManager.GetInputAdaptorDef(Index: Integer ): TWebInputAdaptorDef; begin Result:=FAdaptorDefs[Index]; end; function TFPWebDataProviderManager.GetInputAdaptorDefCount: Integer; begin Result:=FAdaptorDefs.Count; end; function TFPWebDataProviderManager.AddHttpDataProducerDef( const AProducerName: String; AClass: TCustomHTTPDataContentProducerClass ): THttpDataProducerDef; begin Result:=FProducerDefs.AddProducer(AProducerName,AClass); end; function TFPWebDataProviderManager.IndexOfHttpDataProducerDef( const AProducerName: String): Integer; begin Result:=FProducerDefs.IndexOfProducer(AProducerName); end; procedure TFPWebDataProviderManager.RemoveHttpDataProducerDef(Index: Integer); begin FProducerDefs.Delete(Index); end; function TFPWebDataProviderManager.GetHttpDataProducerDef(Index: Integer ): THttpDataProducerDef; begin Result:=FProducerDefs[Index]; end; function TFPWebDataProviderManager.GetHttpDataProducerDefCount: Integer; begin Result:=FProducerDefs.Count; end; { TFPCustomWebProviderDataModule } procedure TFPCustomWebProviderDataModule.ReadWebData(AProvider: TFPCustomWebDataProvider ); Var B : Boolean; begin B:=False; If Assigned(FBeforeRead) then FBeforeRead(Self,AProvider,B); if Not B then DoReadWebData(AProvider); If Assigned(FAfterRead) then FAfterRead(Self,AProvider); end; procedure TFPCustomWebProviderDataModule.InsertWebData( AProvider: TFPCustomWebDataProvider); Var B : Boolean; begin B:=False; If Assigned(FBeforeInsert) then FBeforeInsert(Self,AProvider,B); if Not B then DoInsertWebData(AProvider); If Assigned(FAfterInsert) then FAfterInsert(Self,AProvider); end; procedure TFPCustomWebProviderDataModule.SetContentProducer( const AValue: TCustomHTTPDataContentProducer); begin if FContentProducer=AValue then exit; FContentProducer:=AValue; end; procedure TFPCustomWebProviderDataModule.SetInputAdaptor( const AValue: TCustomWebdataInputAdaptor); begin if FInputAdaptor=AValue then exit; FInputAdaptor:=AValue; end; procedure TFPCustomWebProviderDataModule.UpdateWebData( AProvider: TFPCustomWebDataProvider); Var B : Boolean; begin B:=False; If Assigned(FBeforeUpdate) then FBeforeUpdate(Self,AProvider,B); if Not B then DoUpdateWebData(AProvider); If Assigned(FAfterUpdate) then FAfterUpdate(Self,AProvider); end; procedure TFPCustomWebProviderDataModule.DeleteWebData( AProvider: TFPCustomWebDataProvider); Var B : Boolean; begin B:=False; If Assigned(FBeforeDelete) then FBeforeDelete(Self,AProvider,B); if Not B then DoDeleteWebData(AProvider); If Assigned(FAfterDelete) then FAfterDelete(Self,AProvider); end; Function TFPCustomWebProviderDataModule.GetAdaptor : TCustomWebdataInputAdaptor; begin Result:=Self.InputAdaptor; If Assigned(FOnGetInputAdaptor) then FOnGetInputAdaptor(Self,Result); end; function TFPCustomWebProviderDataModule.GetContentProducer: TCustomHTTPDataContentProducer; begin Result:=FContentProducer; If Assigned(FOnGetContentProducer) then FOnGetContentProducer(Self,Result); end; procedure TFPCustomWebProviderDataModule.ProduceContent( AProvider: TFPCustomWebDataProvider); Var A : TCustomWebdataInputAdaptor; C : TCustomHTTPDataContentProducer; Handled : boolean; M : TmemoryStream; begin A:=GetAdaptor; A.Request:=Self.Request; AProvider.Adaptor:=A; C:=GetContentProducer; C.Adaptor:=A; C.Provider:=AProvider; M:=TMemoryStream.Create; try Handled:=True; C.GetContent(Request,M,Handled); If Handled then begin M.Position:=0; If Assigned(FOnContent) then FOnContent(Self,M); Response.ContentType:=C.DataContentType; Response.ContentStream:=M; Response.SendResponse; Response.ContentStream:=Nil; end else Raise EFPHTTPError.CreateFmt(SErrContentProviderRequest,[C.Name]); finally M.Free; end; end; procedure TFPCustomWebProviderDataModule.DoReadWebData( AProvider: TFPCustomWebDataProvider); begin ProduceContent(AProvider); end; procedure TFPCustomWebProviderDataModule.DoInsertWebData( AProvider: TFPCustomWebDataProvider); begin ProduceContent(AProvider); end; procedure TFPCustomWebProviderDataModule.DoUpdateWebData( AProvider: TFPCustomWebDataProvider); begin ProduceContent(AProvider); end; procedure TFPCustomWebProviderDataModule.DoDeleteWebData( AProvider: TFPCustomWebDataProvider); begin ProduceContent(AProvider); end; Constructor TFPCustomWebProviderDataModule.CreateNew(AOwner : TComponent; CreateMode : Integer); begin inherited; FUseProviderManager:=True; end; Function TFPCustomWebProviderDataModule.GetProvider(Const AProviderName : String; Out AContainer : TComponent) : TFPCustomWebDataProvider; Var C : TComponent; ADef : TWebDataProviderDef; P : TFPCustomWebDataProvider; begin Result:=Nil; AContainer:=Nil; If Assigned(FOnGetProvider) then begin FOngetProvider(Self,AProviderName,Result); If Assigned(Result) then begin AContainer:=Nil; Exit; end; end; P:=Nil; C:=FindComponent(AProviderName); {$ifdef wmdebug}SendDebug(Format('Searching provider "%s" 1 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif} If (C<>Nil) and (C is TFPCustomWebDataProvider) then P:=TFPCustomWebDataProvider(C) else if UseProviderManager then begin {$ifdef wmdebug}SendDebug(Format('Searching providerdef "%s" 1 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif} ADef:=WebDataProviderManager.FindProviderDefByName(AProviderName); If (ADef<>Nil) then begin {$ifdef wmdebug}SendDebug(Format('Found providerdef "%s" 1 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif} P:=WebDataProviderManager.GetProvider(ADef,Self,AContainer); end else P:=Nil; end; {$ifdef wmdebug}SendDebug(Format('Searching provider "%s" 2 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif} Result:=P; If (Result=Nil) then Raise EFPHTTPError.CreateFmt(SErrUnknownWebDataProvider,[AProviderName]); end; procedure TFPCustomWebProviderDataModule.HandleRequest(ARequest: TRequest; AResponse: TResponse); Var ProviderName : String; AProvider : TFPCustomWebDataProvider; A : TCustomWebdataInputAdaptor; Wa : TWebDataAction; AContainer : TComponent; begin FRequest:=ARequest; FResponse:=AResponse; try {$ifdef wmdebug}SendDebug('Checking session');{$endif} CheckSession(ARequest); {$ifdef wmdebug}SendDebug('Init session');{$endif} InitSession(AResponse); {$ifdef wmdebug}SendDebug('Getting providername');{$endif} ProviderName:=Request.GetNextPathInfo; {$ifdef wmdebug}SendDebug('Handlerequest, providername : '+Providername);{$endif} AProvider:=GetProvider(ProviderName,AContainer); try If not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then begin A:=GetAdaptor; A.Request:=ARequest; A.Reset; // Force. for wmKind=pooled, fastcgi, request can be the same. Wa:=A.GetAction; Case WA of wdaUnknown : Raise EFPHTTPError.CreateFmt(SErrUnknownProviderAction,[ProviderName]); wdaRead : ReadWebData(AProvider); wdaUpdate : UpdateWebData(AProvider); wdaInsert : InsertWebdata(AProvider); wdaDelete : DeleteWebData(AProvider); end; UpdateSession(AResponse); end; finally If (AContainer=Nil) then begin If (AProvider.Owner<>Self) then AProvider.Free; end else AContainer.Free; end; finally FRequest:=Nil; FResponse:=Nil; end; end; { TWebInputAdaptorDef } procedure TWebInputAdaptorDef.SetName(const AValue: String); begin if FName=AValue then exit; FName:=AValue; end; function TWebInputAdaptorDef.CreateInstance(AOwner: TComponent ): TCustomWebdataInputAdaptor; begin Result:=FClass.Create(AOwner); end; { TWebInputAdaptorDefs } function TWebInputAdaptorDefs.GetD(Index : Integer): TWebInputAdaptorDef; begin Result:=TWebInputAdaptorDef(Items[Index]); end; procedure TWebInputAdaptorDefs.SetD(Index : Integer; const AValue: TWebInputAdaptorDef); begin Items[Index]:=AValue; end; function TWebInputAdaptorDefs.IndexOfAdaptor(const AAdaptorName: String ): Integer; begin Result:=Count-1; While (Result>=0) and (CompareText(GetD(Result).Name,AAdaptorName)<>0) do Dec(Result); end; function TWebInputAdaptorDefs.AddAdaptor(const AAdaptorName: String; AClass: TCustomWebdataInputAdaptorClass): TWebInputAdaptorDef; Var I : Integer; begin I:=IndexOfAdaptor(AAdaptorName); If (I=-1) then begin Result:=Add as TWebInputAdaptorDef; Result.FName:=AAdaptorName; Result.FClass:=AClass; end else Raise EFPHTTPError.CreateFmt(SErrDuplicateAdaptor,[AAdaptorName]); end; { THttpDataProducerDef } procedure THttpDataProducerDef.SetName(const AValue: String); begin If AValue=FName then exit; If (AValue<>'') and Assigned(Collection) and (Collection is THttpDataProducerDefs) then if THttpDataProducerDefs(Collection).IndexOfProducer(AValue)<>-1 then Raise EFPHTTPError.CreateFmt(SErrDuplicateHTTPDataProducer,[AValue]); FName:=Avalue; end; function THttpDataProducerDef.CreateInstance(AOwner: TComponent ): TCustomHTTPDataContentProducer; begin Result:=FClass.Create(AOwner); end; { THttpDataProducerDefs } function THttpDataProducerDefs.GetD(Index: Integer): THttpDataProducerDef; begin Result:=THttpDataProducerDef(Items[Index]); end; procedure THttpDataProducerDefs.SetD(Index: Integer; const AValue: THttpDataProducerDef); begin Items[Index]:=AValue; end; function THttpDataProducerDefs.IndexOfProducer(const AProducerName: String ): Integer; begin Result:=Count-1; While (Result>=0) and (CompareText(GetD(Result).Name,AProducerName)<>0) do Dec(Result); end; function THttpDataProducerDefs.AddProducer(const AProducerName: String; AClass: TCustomHTTPDataContentProducerClass): THttpDataProducerDef; Var I : Integer; begin I:=IndexOfProducer(AProducerName); If (I=-1) then begin Result:=Add as THttpDataProducerDef; Result.FName:=AProducerName; Result.FClass:=AClass; end else Raise EFPHTTPError.CreateFmt(SErrDuplicateHTTPDataProducer,[AProducerName]); end; { TWebdataInputAdaptor } procedure TWebdataInputAdaptor.SetInputFormat(const AValue: String); begin if FInputFormat=AValue then exit; If Assigned(FProxy) then ClearProxy; FInputFormat:=AValue; end; procedure TWebdataInputAdaptor.ClearProxy; begin FreeAndNil(FProxy); end; procedure TWebdataInputAdaptor.CheckProxy; begin If (FProxy=Nil) then FProxy:=CreateProxy; end; function TWebdataInputAdaptor.CreateProxy: TCustomWebdataInputAdaptor; begin Result:=WebDataProviderManager.GetInputAdaptor(FInputFormat); end; function TWebdataInputAdaptor.GetActionFromRequest: TWebDataAction; begin CheckProxy; Result:=FProxy.GetActionFromRequest; end; destructor TWebdataInputAdaptor.Destroy; begin ClearProxy; Inherited; end; function TWebdataInputAdaptor.GetNextBatch: Boolean; begin CheckProxy; Result:=FProxy.GetNextBatch; end; function TWebdataInputAdaptor.TryParamValue(const AParamName: String; out AValue: String): Boolean; begin CheckProxy; Result:=FProxy.TryParamValue(AParamName, AValue); end; function TWebdataInputAdaptor.TryFieldValue(const AFieldName: String; out AValue: String): Boolean; begin CheckProxy; Result:=FProxy.TryFieldValue(AFieldName, AValue); end; { THTTPDataContentProducer } procedure THTTPDataContentProducer.SetOutputFormat(const AValue: String); begin if FOutputFormat=AValue then exit; If Assigned(FProxy) then ClearProxy; FOutputFormat:=AValue; end; procedure THTTPDataContentProducer.ClearProxy; begin FreeAndNil(FProxy); end; procedure THTTPDataContentProducer.CheckProxy; begin If not Assigned(FProxy) then begin FProxy:=CreateProxy; end; end; function THTTPDataContentProducer.CreateProxy: TCustomHTTPDataContentProducer; begin Result:=WebDataProviderManager.GetDataProducer(FOutputFormat,Self); ConfigureProxy(Result); end; Procedure THTTPDataContentProducer.ConfigureProxy(AProxy : TCustomHTTPDataContentProducer); begin AProxy.PageSize:=Self.PageSize; AProxy.PageStart:=Self.PageStart; AProxy.MetaData:=Self.MetaData; AProxy.SortField:=Self.SortField; AProxy.SortDescending:=Self.SortDescending; AProxy.AllowPageSize:=Self.AllowPageSize; If Assigned(FOnConfigure) then FOnConfigure(AProxy); end; destructor THTTPDataContentProducer.destroy; begin ClearProxy; inherited destroy; end; initialization finalization FreeAndNil(AWebDataProviderManager); end.