mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2026-02-04 03:54:51 +01:00
474 lines
14 KiB
ObjectPascal
474 lines
14 KiB
ObjectPascal
{
|
|
$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.
|
|
|