123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473 |
- {
- $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
- This file is part of the Free Component Library (FCL)
- Copyright (c) 1999-2000 by the Free Pascal development team
- 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.
- **********************************************************************}
- unit fphtml;
- {$mode objfpc}{$H+}
- interface
- uses
- Classes, SysUtils, htmlelements, htmlwriter, httpdefs, fphttp, db;
- type
- { THTMLContentProducer }
- THTMLContentProducer = Class(THTTPContentProducer)
- private
- FDocument: THTMLDocument;
- FElement: THTMLCustomElement;
- FWriter: THTMLWriter;
- procedure SetDocument(const AValue: THTMLDocument);
- procedure SetWriter(const AValue: THTMLWriter);
- Protected
- function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
- public
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; virtual; abstract;
- Function ProduceContent : String; override; // Here to test the output. Replace to protected after tests
- property ParentElement : THTMLCustomElement read FElement write FElement;
- property Writer : THTMLWriter read FWriter write SetWriter;
- published
- Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
- end;
- TWriterElementEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter; var anElement : THTMLCustomElement) of object;
- TAfterElementEvent = procedure (Sender:THTMLContentProducer; anElement : THTMLCustomElement) of object;
- TWriterEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter) of object;
- TBooleanEvent = procedure (Sender:THTMLContentProducer; var flag : boolean) of object;
- { THTMLCustomDatasetContentProducer }
- THTMLCustomDatasetContentProducer = class (THTMLContentProducer)
- private
- FDatasource: TDatasource;
- FOnWriteFooter: TWriterEvent;
- FOnWriteHeader: TWriterElementEvent;
- FOnWriteRecord: TWriterEvent;
- function WriteHeader (aWriter : THTMLWriter) : THTMLCustomElement;
- procedure WriteFooter (aWriter : THTMLWriter);
- procedure WriteRecord (aWriter : THTMLWriter);
- protected
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
- procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); virtual;
- procedure DoWriteFooter (aWriter : THTMLWriter); virtual;
- procedure DoWriteRecord (aWriter : THTMLWriter); virtual;
- public
- Property OnWriteHeader : TWriterElementEvent read FOnWriteHeader write FOnWriteHeader;
- Property OnWriteFooter : TWriterEvent read FOnWriteFooter write FOnWriteFooter;
- Property OnWriteRecord : TWriterEvent read FOnWriteRecord write FOnWriteRecord;
- published
- Property DataSource : TDataSource read FDataSource write FDataSource;
- end;
- { THTMLDatasetContentProducer }
- THTMLDatasetContentProducer = class (THTMLCustomDatasetContentProducer)
- published
- Property OnWriteHeader;
- Property OnWriteFooter;
- Property OnWriteRecord;
- end;
-
- { THTMLSelectProducer }
- THTMLSelectProducer = class (THTMLContentProducer)
- private
- FControlName: string;
- FItems: TStrings;
- FPreSelected: string;
- FSize: integer;
- FUseValues: boolean;
- procedure SetItems(const AValue: TStrings);
- protected
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
- public
- constructor create (aOwner : TComponent); override;
- destructor destroy; override;
- published
- property Items : TStrings read FItems write SetItems;
- property UseValues : boolean read FUseValues write FUseValues default false;
- property PreSelected : string read FPreSelected write FPreSelected;
- property Size : integer read FSize write FSize default 1;
- property ControlName : string read FControlName write FControlName;
- end;
- { THTMLDatasetSelectProducer }
- THTMLDatasetSelectProducer = class (THTMLCustomDatasetContentProducer)
- private
- FControlName: string;
- FIsPreSelected: TBooleanEvent;
- FItemField: string;
- FSize: string;
- FValueField: string;
- FValue, FItem : TField;
- protected
- procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); override;
- procedure DoWriteFooter (aWriter : THTMLWriter); override;
- procedure DoWriteRecord (aWriter : THTMLWriter); override;
- public
- constructor create (aOwner : TComponent); override;
- published
- property ItemField : string read FItemField write FItemField;
- property ValueField : string read FValueField write FValueField;
- property OnIsPreSelected : TBooleanEvent read FIsPreSelected write FIsPreSelected;
- property Size : string read FSize write FSize;
- property ControlName : string read FControlName write FControlName;
- property OnWriteHeader;
- end;
-
- { THTMLDataModule }
- THTMLGetContentEvent = Procedure (Sender : TObject; ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean) of object;
- TCreateDocumentEvent = Procedure(Sender : TObject; var ADocument : THTMLDocument) of object;
- TCreateWriterEvent = Procedure(Sender : TObject; ADocument : THTMLDocument; Var AWriter : THTMLWriter) of object;
- { THTMLContentAction }
- THTMLContentAction = Class(TCustomWebAction)
- private
- FOnGetContent: THTMLGetContentEvent;
- Public
- Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
- Published
- Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
- end;
-
- { THTMLContentActions }
- THTMLContentActions = Class(TCustomWebActions)
- Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
- end;
- { TCustomHTMLDataModule }
- { TCustomHTMLModule }
- TCustomHTMLModule = Class(TCustomHTTPModule)
- private
- FDocument : THTMLDocument;
- FActions: THTMLContentActions;
- FOnCreateDocument: TCreateDocumentEvent;
- FOnCreateWriter: TCreateWriterEvent;
- FOnGetContent: THTMLGetContentEvent;
- procedure SetActions(const AValue: THTMLContentActions);
- Protected
- Function CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
- Function CreateDocument : THTMLDocument;
- Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
- Property Actions : THTMLContentActions Read FActions Write SetActions;
- Property OnCreateDocument : TCreateDocumentEvent Read FOnCreateDocument Write FOnCreateDocument;
- Property OnCreateWriter : TCreateWriterEvent Read FOnCreateWriter Write FOnCreateWriter;
- Public
- Constructor Create(AOwner : TComponent);override;
- Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
- end;
-
- TFPHTMLModule=Class(TCustomHTMLModule)
- Published
- Property OnGetContent;
- Property Actions;
- Property OnCreateDocument;
- Property OnCreateWriter;
- end;
-
- EHTMLError = Class(Exception);
-
- implementation
- {$ifdef cgidebug}
- Uses dbugintf;
- {$endif cgidebug}
- resourcestring
- SErrRequestNotHandled = 'Web request was not handled by actions.';
- { THTMLContentProducer }
- procedure THTMLContentProducer.SetWriter(const AValue: THTMLWriter);
- begin
- FWriter := AValue;
- if not assigned (FDocument) then
- FDocument := AValue.Document
- else if FDocument <> AValue.Document then
- AValue.document := FDocument;
- end;
- procedure THTMLContentProducer.SetDocument(const AValue: THTMLDocument);
- begin
- FDocument := AValue;
- if assigned (FWriter) and (AValue <> FWriter.Document) then
- FWriter.Document := AValue;
- end;
- function THTMLContentProducer.ProduceContent: String;
- var WCreated, created : boolean;
- el : THtmlCustomElement;
- begin
- created := not assigned (FDocument);
- if created then
- FDocument := THTMLDocument.Create;
- try
- WCreated := not assigned(FWriter);
- if WCreated then
- FWriter := CreateWriter (FDocument);
- try
- FWriter.CurrentElement := ParentElement;
- el := WriteContent (FWriter);
- result := el.asstring;
- finally
- if WCreated then
- FWriter.Free;
- end;
- finally
- if created then
- FDocument.Free;
- end;
- end;
- function THTMLContentProducer.CreateWriter (Doc : THTMLDocument): THTMLWriter;
- begin
- FDocument := Doc;
- result := THTMLWriter.Create (Doc);
- end;
- { THTMLCustomDatasetContentProducer }
- function THTMLCustomDatasetContentProducer.WriteHeader(aWriter: THTMLWriter): THTMLCustomElement;
- var el : THTmlCustomElement;
- begin
- el := nil;
- DoWriteHeader (aWriter, el);
- result := el;
- end;
- procedure THTMLCustomDatasetContentProducer.WriteFooter(aWriter: THTMLWriter);
- begin
- DoWriteFooter (aWriter);
- end;
- procedure THTMLCustomDatasetContentProducer.WriteRecord(aWriter: THTMLWriter);
- begin
- DoWriteRecord (aWriter);
- end;
- function THTMLCustomDatasetContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
- var opened : boolean;
- begin
- if assigned (FDataSource) and assigned(datasource.dataset) then
- begin
- result := WriteHeader (aWriter);
- try
- with FDataSource.dataset do
- try
- opened := Active;
- if not opened then
- Open;
- first;
- while not eof do
- begin
- WriteRecord(aWriter);
- next;
- end;
- finally
- if opened then
- close;
- end;
- finally
- WriteFooter (aWriter);
- end;
- end;
- end;
- procedure THTMLCustomDatasetContentProducer.DoWriteHeader(aWriter: THTMLWriter; var el : THTMLCustomElement);
- begin
- if assigned (FOnWriteHeader) then
- FOnWriteHeader (self, aWriter, el);
- end;
- procedure THTMLCustomDatasetContentProducer.DoWriteFooter(aWriter: THTMLWriter);
- begin
- if assigned (FOnWriteFooter) then
- FOnWriteFooter (self, aWriter);
- end;
- procedure THTMLCustomDatasetContentProducer.DoWriteRecord(aWriter: THTMLWriter);
- begin
- if assigned (FOnWriteRecord) then
- FOnWriteRecord (self, aWriter);
- end;
- { THTMLSelectProducer }
- procedure THTMLSelectProducer.SetItems(const AValue: TStrings);
- begin
- if FItems<>AValue then
- FItems.assign(AValue);
- end;
- function THTMLSelectProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
- begin
- result := aWriter.FormSelect(FControlName, FPreselected, FSize, FItems, FUseValues);
- end;
- constructor THTMLSelectProducer.create(aOwner: TComponent);
- begin
- inherited create (aOwner);
- FItems := TStringlist.Create;
- size := 1;
- end;
- destructor THTMLSelectProducer.destroy;
- begin
- FItems.Free;
- inherited;
- end;
- { THTMLDatasetSelectProducer }
- procedure THTMLDatasetSelectProducer.DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement);
- var s : THTML_Select;
- begin
- s := aWriter.StartSelect;
- s.size := FSize;
- s.name := FControlName;
- el := s;
- if FValueField <> '' then
- FValue := datasource.dataset.findfield (FValueField);
- if FItemField <> '' then
- FItem := DataSource.dataset.findfield (FItemField);
- inherited DoWriteHeader(aWriter, el);
- end;
- procedure THTMLDatasetSelectProducer.DoWriteFooter(aWriter: THTMLWriter);
- begin
- inherited DoWriteFooter(aWriter);
- aWriter.EndSelect;
- end;
- procedure THTMLDatasetSelectProducer.DoWriteRecord(aWriter: THTMLWriter);
- var sel : boolean;
- begin
- if assigned (FItem) then
- with aWriter.Option(FItem.asstring) do
- begin
- if assigned (FIsPreSelected) then
- begin
- sel := false;
- FIsPreSelected (self, sel);
- selected := sel;
- end;
- if assigned (FValue) then
- Value := FValue.Asstring;
- end;
- end;
- constructor THTMLDatasetSelectProducer.create(aOwner: TComponent);
- begin
- inherited create(aOwner);
- Size := '1';
- end;
- { TCustomHTMLDataModule }
- Function TCustomHTMLModule.CreateDocument : THTMLDocument;
- begin
- If Assigned(FOnCreateDocument) then
- FOnCreateDocument(Self,Result);
- If (Result=Nil) then
- Result:=THTMLDocument.Create;
- end;
- constructor TCustomHTMLModule.Create(AOwner: TComponent);
- begin
- FActions:=THTMLContentActions.Create(THTMLContentAction);
- inherited Create(AOwner);
- end;
- procedure TCustomHTMLModule.SetActions(const AValue: THTMLContentActions);
- begin
- end;
- Function TCustomHTMLModule.CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
- begin
- If Assigned(FOnCreateWriter) then
- FOnCreateWriter(Self,ADocument,Result);
- if (Result=Nil) then
- Result:=THTMLWriter.Create(ADocument);
- end;
- procedure TCustomHTMLModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
- Var
- FWriter : THTMLWriter;
- B : Boolean;
- M : TMemoryStream;
-
- begin
- CreateDocument;
- Try
- FWriter:=CreateWriter(FDocument);
- Try
- B:=False;
- If Assigned(OnGetContent) then
- OnGetContent(Self,ARequest,FWriter,B);
- If Not B then
- Raise EHTMLError.Create(SErrRequestNotHandled);
- If (AResponse.ContentStream=Nil) then
- begin
- M:=TMemoryStream.Create;
- AResponse.ContentStream:=M;
- end;
- FDocument.SaveToStream(AResponse.ContentStream);
- Finally
- FWriter.Free;
- end;
- Finally
- FDocument.Free;
- end;
- end;
- { THTMLContentActions }
- procedure THTMLContentActions.HandleRequest(ARequest: TRequest;
- HTMLPage: THTMLWriter; var Handled: Boolean);
-
- Var
- A : TCustomWebAction;
- begin
- {$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
- A:=GetRequestAction(ARequest);
- if Assigned(A) then
- (A as THTMLContentAction).HandleRequest(ARequest,HTMLPage,Handled);
- {$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
- end;
- { THTMLContentAction }
- procedure THTMLContentAction.HandleRequest(ARequest: TRequest;
- HTMLPage: THTMLWriter; var Handled: Boolean);
- begin
- If Assigned(FOngetContent) then
- FOnGetContent(Self,ARequest,HTMLPage,Handled);
- end;
- end.
|