12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505 |
- {
- $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, DOM, contnrs;
- type
- THtmlEntities = (heHtml,heBody,heHead,heDiv,heParagraph);
- const
- THtmlEntitiesClasses : array[THtmlEntities] of THTMLElementClass =
- (THTML_html, THTML_body, THTML_head, THTML_div, THTML_p);
- type
- { TJavaScriptStack }
- TWebButtonType = (btOk, btCancel, btCustom);
- TWebButton = record
- ButtonType: TWebButtonType;
- Caption: String;
- OnClick: String;
- end;
- TWebButtons = array of TWebButton;
- TMessageBoxHandler = function(Sender: TObject; AText: String; Buttons: TWebButtons; Loaded: string = ''): string of object;
- TWebController = class;
- THTMLContentProducer = class;
- TJavaType = (jtOther, jtClientSideEvent);
- TJavaScriptStack = class(TObject)
- private
- FJavaType: TJavaType;
- FMessageBoxHandler: TMessageBoxHandler;
- FScript: TStrings;
- FWebController: TWebController;
- protected
- function GetWebController: TWebController;
- public
- constructor Create(const AWebController: TWebController; const AJavaType: TJavaType); virtual;
- destructor Destroy; override;
- procedure AddScriptLine(ALine: String); virtual;
- procedure MessageBox(AText: String; Buttons: TWebButtons; Loaded: string = ''); virtual;
- procedure RedrawContentProducer(AContentProducer: THTMLContentProducer); virtual;
- procedure CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = ''); virtual;
- procedure Clear; virtual;
- procedure Redirect(AUrl: string); virtual;
- function ScriptIsEmpty: Boolean; virtual;
- function GetScript: String; virtual;
- property WebController: TWebController read GetWebController;
- property JavaType: TJavaType read FJavaType;
- end;
- { TContainerStylesheet }
- TContainerStylesheet = class(TCollectionItem)
- private
- Fhref: string;
- Fmedia: string;
- published
- property href: string read Fhref write Fhref;
- property media: string read Fmedia write Fmedia;
- end;
- { TContainerStylesheets }
- TContainerStylesheets = class(TCollection)
- private
- function GetItem(Index: integer): TContainerStylesheet;
- procedure SetItem(Index: integer; const AValue: TContainerStylesheet);
- public
- function Add: TContainerStylesheet;
- property Items[Index: integer]: TContainerStylesheet read GetItem write SetItem;
- end;
- { TJavaVariable }
- TJavaVariable = class(TCollectionItem)
- private
- FBelongsTo: string;
- FGetValueFunc: string;
- FID: string;
- FIDSuffix: string;
- FName: string;
- public
- property BelongsTo: string read FBelongsTo write FBelongsTo;
- property GetValueFunc: string read FGetValueFunc write FGetValueFunc;
- property Name: string read FName write FName;
- property ID: string read FID write FID;
- property IDSuffix: string read FIDSuffix write FIDSuffix;
- end;
- { TJavaVariables }
- TJavaVariables = class(TCollection)
- private
- function GetItem(Index: integer): TJavaVariable;
- procedure SetItem(Index: integer; const AValue: TJavaVariable);
- public
- function Add: TJavaVariable;
- property Items[Index: integer]: TJavaVariable read GetItem write SetItem;
- end;
- { TWebController }
- TWebController = class(TComponent)
- private
- FAddRelURLPrefix: boolean;
- FBaseURL: string;
- FMessageBoxHandler: TMessageBoxHandler;
- FScriptName: string;
- FScriptStack: TFPObjectList;
- FIterationIDs: array of string;
- FJavaVariables: TJavaVariables;
- procedure SetBaseURL(const AValue: string);
- procedure SetScriptName(const AValue: string);
- protected
- function GetJavaVariables: TJavaVariables;
- function GetJavaVariablesCount: integer;
- function GetScriptFileReferences: TStringList; virtual; abstract;
- function GetCurrentJavaScriptStack: TJavaScriptStack; virtual;
- function GetStyleSheetReferences: TContainerStylesheets; virtual; abstract;
- function GetScripts: TFPObjectList; virtual; abstract;
- function GetRequest: TRequest;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure AddScriptFileReference(AScriptFile: String); virtual; abstract;
- procedure AddStylesheetReference(Ahref, Amedia: String); virtual; abstract;
- function CreateNewJavascriptStack(AJavaType: TJavaType): TJavaScriptStack; virtual; abstract;
- function InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
- procedure FreeJavascriptStack; virtual;
- function HasJavascriptStack: boolean; virtual; abstract;
- function GetUrl(ParamNames, ParamValues, KeepParams: array of string; Action: string = ''): string; virtual; abstract;
- procedure InitializeAjaxRequest; virtual;
- procedure InitializeShowRequest; virtual;
- procedure CleanupShowRequest; virtual;
- procedure CleanupAfterRequest; virtual;
- procedure BeforeGenerateHead; virtual;
- function AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
- procedure BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string); virtual; abstract;
- function MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual;
- function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual; abstract;
- function CreateNewScript: TStringList; virtual; abstract;
- function AddrelativeLinkPrefix(AnURL: string): string;
- procedure FreeScript(var AScript: TStringList); virtual; abstract;
- procedure ShowRegisteredScript(ScriptID: integer); virtual; abstract;
- function IncrementIterationLevel: integer; virtual;
- procedure SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string); virtual;
- function GetIterationIDSuffix: string; virtual;
- procedure DecrementIterationLevel; virtual;
- property ScriptFileReferences: TStringList read GetScriptFileReferences;
- property StyleSheetReferences: TContainerStylesheets read GetStyleSheetReferences;
- property Scripts: TFPObjectList read GetScripts;
- property CurrentJavaScriptStack: TJavaScriptStack read GetCurrentJavaScriptStack;
- property MessageBoxHandler: TMessageBoxHandler read FMessageBoxHandler write FMessageBoxHandler;
- published
- property BaseURL: string read FBaseURL write SetBaseURL;
- property ScriptName: string read FScriptName write SetScriptName;
- property AddRelURLPrefix: boolean read FAddRelURLPrefix write FAddRelURLPrefix;
- end;
- { TAjaxResponse }
- TAjaxResponse= class(TObject)
- private
- FJavascriptCallStack: TJavaScriptStack;
- FResponse: TResponse;
- FSendXMLAnswer: boolean;
- FXMLAnswer: TXMLDocument;
- FRootNode: TDOMNode;
- FWebController: TWebController;
- function GetXMLAnswer: TXMLDocument;
- public
- constructor Create(AWebController: TWebController; AResponse: TResponse); virtual;
- destructor Destroy; override;
- procedure BindToResponse; virtual;
- procedure SetError(HelpContext: longint; ErrorMessage: string);
- procedure CancelXMLAnswer;
- property Response: TResponse read FResponse;
- property XMLAnswer: TXMLDocument read GetXMLAnswer;
- property SendXMLAnswer: boolean read FSendXMLAnswer;
- property JavascriptCallStack: TJavaScriptStack read FJavascriptCallStack;
- end;
- TCSAjaxEvent=procedure(Sender: TComponent; AJavascriptClass: TJavaScriptStack; var Handled: boolean) of object;
- THandleAjaxEvent = procedure(Sender: TObject; ARequest: TRequest; AnAjaxResponse: TAjaxResponse) of object;
- TEventRecord = record
- csCallback: TCSAjaxEvent;
- ServerEvent: THandleAjaxEvent;
- ServerEventID: integer;
- JavaEventName: string;
- end;
- TEventRecords = array of TEventRecord;
- TForeachContentProducerProc = procedure(const AContentProducer: THTMLContentProducer) of object;
- { IHTMLContentProducerContainer }
- IHTMLContentProducerContainer = interface
- ['{8B4D8AE0-4873-49BF-B677-D03C8A02CDA5}']
- procedure AddContentProducer(AContentProducer: THTMLContentProducer);
- procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
- function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
- function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
- procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
- function ProduceContent : string;
- end;
- { THTMLContentProducer }
- THTMLContentProducer = Class(THTTPContentProducer, IHTMLContentProducerContainer)
- private
- FDocument: THTMLDocument;
- FElement: THTMLCustomElement;
- FWriter: THTMLWriter;
- FIDSuffix: string;
- procedure SetDocument(const AValue: THTMLDocument);
- procedure SetWriter(const AValue: THTMLWriter);
- private
- // for streaming
- FChilds: TFPList; // list of THTMLContentProducer
- FParent: TComponent;
- function GetContentProducerList: TFPList;
- function GetContentProducers(Index: integer): THTMLContentProducer;
- procedure SetParent(const AValue: TComponent);
- Protected
- function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
- function GetIDSuffix: string; virtual;
- procedure SetIDSuffix(const AValue: string); virtual;
- protected
- // Methods for streaming
- FAcceptChildsAtDesignTime: boolean;
- procedure SetParentComponent(Value: TComponent); override;
- procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
- procedure DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
- function GetEvents: TEventRecords; virtual;
- procedure AddEvent(var Events: TEventRecords; AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string; AcsCallBack: TCSAjaxEvent); virtual;
- procedure DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean); virtual;
- procedure SetupEvents(AHtmlElement: THtmlCustomElement); virtual;
- function GetWebPage: TDataModule;
- function GetWebController(const ExceptIfNotAvailable: boolean = true): TWebController;
- property ContentProducerList: TFPList read GetContentProducerList;
- public
- procedure BeforeGenerateContent; virtual;
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; virtual;
- Function ProduceContent : String; override; // Here to test the output. Replace to protected after tests
- function GetParentComponent: TComponent; override;
- property ParentElement : THTMLCustomElement read FElement write FElement;
- property Writer : THTMLWriter read FWriter write SetWriter;
- Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
- Property IDSuffix : string read GetIDSuffix write SetIDSuffix;
- public
- // for streaming
- constructor Create(AOwner: TComponent); override;
- destructor destroy; override;
- function HasParent: Boolean; override;
- function ChildCount: integer;
- procedure CleanupAfterRequest; virtual;
- procedure AddContentProducer(AContentProducer: THTMLContentProducer);
- procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
- function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
- function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
- procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); virtual;
- procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
- property Childs[Index: integer]: THTMLContentProducer read GetContentProducers;
- property AcceptChildsAtDesignTime: boolean read FAcceptChildsAtDesignTime;
- property parent: TComponent read FParent write SetParent;
- end;
- THTMLContentProducerClass = class of THTMLContentProducer;
- 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;
- { THTMLCustomEntityProducer }
- THTMLCustomEntityProducer = class (THTMLContentProducer)
- private
- FOnWriteEntity: TWriterEvent;
- FEntity: THtmlEntities;
- protected
- procedure DoWriteEntity (aWriter : THTMLWriter); virtual;
- Property OnWriteEntity : TWriterEvent read FOnWriteEntity write FOnWriteEntity;
- Property Entity : THtmlEntities read FEntity write FEntity default heHtml;
- public
- constructor Create(AOwner: TComponent); override;
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
- end;
- { THTMLEntityContentProducer }
- THTMLEntityProducer = class (THTMLCustomEntityProducer)
- published
- Property OnWriteEntity;
- Property Entity;
- end;
- { THTMLCustomPageProducer }
- THTMLCustomPageProducer = class (THTMLCustomEntityProducer)
- private
- FHeaderProducer : THTMLContentProducer;
- FOnWriteHeader: TWriterEvent;
- FOnWriteVisualBody: TWriterEvent;
- FOnWriteVisualFooter: TWriterEvent;
- FOnWriteVisualHeader: TWriterEvent;
- FVisualHeaderProducer : THTMLContentProducer;
- FVisualBodyProducer : THTMLContentProducer;
- FVisualFooterProducer : THTMLContentProducer;
- protected
- procedure DoWriteEntity (aWriter : THTMLWriter); override;
- procedure DoWriteHeader (aWriter : THTMLWriter); virtual;
- procedure DoWriteVisualHeader (aWriter : THTMLWriter); virtual;
- procedure DoWriteVisualBody (aWriter : THTMLWriter); virtual;
- procedure DoWriteVisualFooter (aWriter : THTMLWriter); virtual;
- procedure BeforeGenerateContent; override;
- Property HeaderProducer : THTMLContentProducer read FHeaderProducer write FHeaderProducer;
- Property VisualHeaderProducer : THTMLContentProducer read FVisualHeaderProducer write FVisualHeaderProducer;
- Property VisualBodyProducer : THTMLContentProducer read FVisualBodyProducer write FVisualBodyProducer;
- Property VisualFooterProducer : THTMLContentProducer read FVisualFooterProducer write FVisualFooterProducer;
- Property OnWriteHeader : TWriterEvent read FOnWriteHeader write FOnWriteHeader;
- Property OnWriteVisualHeader : TWriterEvent read FOnWriteVisualHeader write FOnWriteVisualHeader;
- Property OnWriteVisualBody : TWriterEvent read FOnWriteVisualBody write FOnWriteVisualBody;
- Property OnWriteVisualFooter : TWriterEvent read FOnWriteVisualFooter write FOnWriteVisualFooter;
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { THTMLPageProducer }
- THTMLPageProducer = class (THTMLCustomPageProducer)
- published
- property OnWriteHeader;
- property OnWriteVisualHeader;
- property OnWriteVisualBody;
- property OnWriteVisualFooter;
- Property HeaderProducer;
- Property VisualHeaderProducer;
- Property VisualBodyProducer;
- Property VisualFooterProducer;
- end;
- { THTMLCustomDatasetContentProducer }
- THTMLCustomDatasetContentProducer = class (THTMLContentProducer)
- private
- FDatasource: TDatasource;
- FOnChange: THandleAjaxEvent;
- FOnChangeCS: TCSAjaxEvent;
- FOnWriteFooter: TWriterEvent;
- FOnWriteHeader: TWriterElementEvent;
- FOnWriteRecord: TWriterEvent;
- function WriteHeader (aWriter : THTMLWriter) : THTMLCustomElement;
- procedure WriteFooter (aWriter : THTMLWriter);
- procedure WriteRecord (aWriter : THTMLWriter);
- protected
- procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); virtual;
- procedure DoWriteFooter (aWriter : THTMLWriter); virtual;
- procedure DoWriteRecord (aWriter : THTMLWriter); virtual;
- function GetEvents: TEventRecords; override;
- procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); override;
- public
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
- 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;
- property OnChangeCS: TCSAjaxEvent read FOnChangeCS write FOnChangeCS;
- property OnChange: THandleAjaxEvent read FOnChange write FOnChange;
- end;
- { THTMLDatasetContentProducer }
- THTMLDatasetContentProducer = class (THTMLCustomDatasetContentProducer)
- published
- Property OnWriteHeader;
- Property OnWriteFooter;
- Property OnWriteRecord;
- end;
-
- { THTMLSelectProducer }
- THTMLSelectProducer = class (THTMLContentProducer)
- private
- FControlName: string;
- FItems: TStrings;
- FjsOnChange: string;
- FPreSelected: string;
- FSize: integer;
- FUseValues: boolean;
- procedure SetItems(const AValue: TStrings);
- public
- constructor create (aOwner : TComponent); override;
- destructor destroy; override;
- function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; 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;
- property jsOnChange: string read FjsOnChange write FjsOnChange;
- end;
- { THTMLDatasetSelectProducer }
- THTMLDatasetSelectProducer = class (THTMLCustomDatasetContentProducer)
- private
- FControlName: string;
- FIsPreSelected: TBooleanEvent;
- FItemField: string;
- FSize: integer;
- FValueField: string;
- FValue, FItem : TField;
- FPreSelected: string;
- FUseValues: boolean;
- 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 UseValues : boolean read FUseValues write FUseValues default false;
- property PreSelected : string read FPreSelected write FPreSelected;
- property ItemField : string read FItemField write FItemField;
- property ValueField : string read FValueField write FValueField;
- property OnIsPreSelected : TBooleanEvent read FIsPreSelected write FIsPreSelected;
- property Size : integer 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);
- const SimpleOkButton: array[0..0] of TWebButton = ((buttontype: btok;caption: 'Ok';onclick: ''));
- const jseButtonClick = 1000;
- jseInputChange = 1001;
- jseFormReset = 1002;
- jseFormSubmit = 1003;
- implementation
- Uses
- {$ifdef cgidebug}
- dbugintf
- {$endif cgidebug}
- webpage, XMLWrite;
- resourcestring
- SErrRequestNotHandled = 'Web request was not handled by actions.';
- SErrNoContentProduced = 'The content producer "%s" didn''t produce any content.';
- { TJavaVariables }
- function TJavaVariables.GetItem(Index: integer): TJavaVariable;
- begin
- result := TJavaVariable(Inherited GetItem(Index));
- end;
- procedure TJavaVariables.SetItem(Index: integer; const AValue: TJavaVariable);
- begin
- inherited SetItem(Index, AValue);
- end;
- function TJavaVariables.Add: TJavaVariable;
- begin
- result := inherited Add as TJavaVariable;
- end;
- { TcontainerStylesheets }
- function TcontainerStylesheets.GetItem(Index: integer): TContainerStylesheet;
- begin
- result := TContainerStylesheet(Inherited GetItem(Index));
- end;
- procedure TcontainerStylesheets.SetItem(Index: integer; const AValue: TContainerStylesheet);
- begin
- inherited SetItem(Index, AValue);
- end;
- function TcontainerStylesheets.Add: TContainerStylesheet;
- begin
- result := inherited Add as TContainerStylesheet;
- end;
- { TJavaScriptStack }
- function TJavaScriptStack.GetWebController: TWebController;
- begin
- result := FWebController;
- end;
- constructor TJavaScriptStack.Create(const AWebController: TWebController; const AJavaType: TJavaType);
- begin
- FWebController := AWebController;
- FScript := TStringList.Create;
- FJavaType := AJavaType;
- end;
- destructor TJavaScriptStack.Destroy;
- begin
- FScript.Free;
- inherited Destroy;
- end;
- procedure TJavaScriptStack.AddScriptLine(ALine: String);
- begin
- FScript.Add(ALine);
- end;
- procedure TJavaScriptStack.MessageBox(AText: String; Buttons: TWebButtons; Loaded: string = '');
- begin
- AddScriptLine(WebController.MessageBox(AText,Buttons,Loaded));
- end;
- procedure TJavaScriptStack.RedrawContentProducer(AContentProducer: THTMLContentProducer);
- begin
- raise exception.Create('RedrawContentProducer not supported by current WebController');
- end;
- procedure TJavaScriptStack.CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = '');
- begin
- raise exception.Create('SendServerEvent not supported by current WebController');
- end;
- procedure TJavaScriptStack.Clear;
- begin
- FScript.Clear;
- end;
- procedure TJavaScriptStack.Redirect(AUrl: string);
- begin
- AddScriptLine('window.location = "'+AUrl+'";');
- end;
- function TJavaScriptStack.ScriptIsEmpty: Boolean;
- begin
- result := FScript.Count=0;
- end;
- function TJavaScriptStack.GetScript: String;
- begin
- result := FScript.Text;
- end;
- { 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;
- procedure THTMLContentProducer.SetParent(const AValue: TComponent);
- begin
- if FParent=AValue then exit;
- if FParent<>nil then
- (FParent as IHTMLContentProducerContainer).RemoveContentProducer(Self);
- FParent:=AValue;
- if FParent<>nil then
- (FParent as IHTMLContentProducerContainer).AddContentProducer(Self);
- end;
- function THTMLContentProducer.GetContentProducers(Index: integer): THTMLContentProducer;
- begin
- Result:=THTMLContentProducer(ContentProducerList[Index]);
- end;
- function THTMLContentProducer.GetIDSuffix: string;
- begin
- result := FIDSuffix;
- end;
- procedure THTMLContentProducer.SetIDSuffix(const AValue: string);
- begin
- FIDSuffix := AValue;
- end;
- function THTMLContentProducer.GetContentProducerList: TFPList;
- begin
- if not assigned(FChilds) then
- fchilds := tfplist.Create;
- Result := FChilds;
- 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);
- if not assigned(el) then
- Raise EHTMLError.CreateFmt(SErrNoContentProduced,[Self.Name]);
- BeforeGenerateContent;
- ForeachContentProducer(@DoBeforeGenerateContent,True);
- result := el.asstring;
- finally
- if WCreated then
- FreeAndNil(FWriter);
- end;
- finally
- if created then
- FreeAndNil(FDocument);
- end;
- end;
- constructor THTMLContentProducer.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FAcceptChildsAtDesignTime:=True;
- end;
- destructor THTMLContentProducer.destroy;
- begin
- Parent:=nil;
- while ChildCount>0 do Childs[ChildCount-1].Free;
- FreeAndNil(FChilds);
- inherited destroy;
- end;
- function THTMLContentProducer.GetEvents: TEventRecords;
- begin
- result := nil;
- end;
- procedure THTMLContentProducer.AddEvent(var Events: TEventRecords;
- AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string;
- AcsCallBack: TCSAjaxEvent);
- begin
- SetLength(Events,length(Events)+1);
- with Events[high(Events)] do
- begin
- ServerEvent:=AServerEvent;
- ServerEventID:=AServerEventID;
- JavaEventName:=AJavaEventName;
- csCallback:=AcsCallBack;
- end;
- end;
- procedure THTMLContentProducer.DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean);
- begin
- if assigned(AnEvent.csCallback) then
- AnEvent.csCallback(self, AJavascriptStack, Handled);
- end;
- procedure THTMLContentProducer.SetupEvents(AHtmlElement: THtmlCustomElement);
- var AJSClass: TJavaScriptStack;
- wc: TWebController;
- Handled: boolean;
- Events: TEventRecords;
- i: integer;
- begin
- Events := GetEvents;
- if length(Events)>0 then
- begin
- wc := GetWebController(false);
- if assigned(wc) then
- begin
- AJSClass := wc.InitializeJavaScriptStack(jtClientSideEvent);
- try
- for i := 0 to high(Events) do
- begin
- Handled:=false;
- DoOnEventCS(events[i],AJSClass, Handled);
- if not handled and assigned(events[i].ServerEvent) then
- AJSClass.CallServerEvent(self,events[i].ServerEventID);
- wc.BindJavascriptCallstackToElement(Self, AHtmlElement,events[i].JavaEventName);
- AJSClass.clear;
- end;
- finally
- wc.FreeJavascriptStack;
- end;
- end
- else
- begin
- for i := 0 to high(Events) do if assigned(events[i].csCallback) or assigned(events[i].ServerEvent) then
- raise exception.Create('There is no webcontroller available, which is necessary to use events.');
- end;
- end;
- end;
- function THTMLContentProducer.GetWebPage: TDataModule;
- var
- aowner: TComponent;
- begin
- result := nil;
- aowner := Owner;
- while assigned(aowner) do
- begin
- if aowner.InheritsFrom(TWebPage) then
- begin
- result := TWebPage(aowner);
- break;
- end;
- aowner:=aowner.Owner;
- end;
- end;
- function THTMLContentProducer.GetWebController(const ExceptIfNotAvailable: boolean): TWebController;
- var
- i : integer;
- wp: TWebPage;
- begin
- result := nil;
- wp := TWebPage(GetWebPage);
- if assigned(wp) then
- begin
- if wp.HasWebController then
- begin
- result := wp.WebController;
- exit;
- end;
- end
- else if assigned(Owner) then //if (owner is TDataModule) then
- begin
- for i := 0 to owner.ComponentCount-1 do if owner.Components[i] is TWebController then
- begin
- result := TWebController(Owner.Components[i]);
- Exit;
- end;
- end;
- if ExceptIfNotAvailable then
- raise Exception.Create('No webcontroller available');
- end;
- procedure THTMLContentProducer.BeforeGenerateContent;
- begin
- // do nothing
- end;
- function THTMLContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
- var i: integer;
- begin
- for i := 0 to ChildCount-1 do
- if Childs[i] is THTMLContentProducer then
- result := THTMLContentProducer(Childs[i]).WriteContent(aWriter);
- end;
- function THTMLContentProducer.ChildCount: integer;
- begin
- if assigned(FChilds) then
- result := FChilds.Count
- else
- result := 0;
- end;
- procedure THTMLContentProducer.CleanupAfterRequest;
- begin
- // Do Nothing
- end;
- procedure THTMLContentProducer.AddContentProducer(AContentProducer: THTMLContentProducer);
- begin
- ContentProducerList.Add(AContentProducer);
- end;
- procedure THTMLContentProducer.RemoveContentProducer(AContentProducer: THTMLContentProducer);
- begin
- ContentProducerList.Remove(AContentProducer);
- end;
- function THTMLContentProducer.ExchangeContentProducers(Child1, Child2: THTMLContentProducer): boolean;
- var ChildIndex1, ChildIndex2: integer;
- begin
- result := false;
- ChildIndex1:=GetContentProducerList.IndexOf(Child1);
- if (ChildIndex1=-1) then
- Exit;
- ChildIndex2:=GetContentProducerList.IndexOf(Child2);
- if (ChildIndex2=-1) then
- Exit;
- GetContentProducerList.Exchange(ChildIndex1,ChildIndex2);
- result := true;
- end;
- function THTMLContentProducer.MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer): boolean;
- var ChildIndex1, ChildIndex2: integer;
- begin
- result := false;
- ChildIndex1:=GetContentProducerList.IndexOf(MoveElement);
- if (ChildIndex1=-1) then
- Exit;
- ChildIndex2:=GetContentProducerList.IndexOf(MoveBeforeElement);
- if (ChildIndex2=-1) then
- Exit;
- if ChildIndex2>ChildIndex1 then dec(ChildIndex2);
- GetContentProducerList.Move(ChildIndex1,ChildIndex2);
- result := true;
- end;
- procedure THTMLContentProducer.HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse);
- begin
- // Do nothing
- end;
- procedure THTMLContentProducer.ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
- var i : integer;
- tmpChild: THTMLContentProducer;
- begin
- for i := 0 to ChildCount -1 do
- begin
- tmpChild := Childs[i];
- AForeachChildsProc(tmpChild);
- if recursive then
- tmpChild.ForeachContentProducer(AForeachChildsProc,Recursive);
- end;
- end;
- function THTMLContentProducer.CreateWriter (Doc : THTMLDocument): THTMLWriter;
- begin
- FDocument := Doc;
- result := THTMLWriter.Create (Doc);
- end;
- procedure THTMLContentProducer.SetParentComponent(Value: TComponent);
- begin
- if Supports(Value,IHTMLContentProducerContainer) then
- Parent:=Value;
- end;
- function THTMLContentProducer.HasParent: Boolean;
- begin
- Result:=FParent<>nil;
- end;
- function THTMLContentProducer.GetParentComponent: TComponent;
- begin
- Result:=TComponent(Parent);
- end;
- procedure THTMLContentProducer.GetChildren(Proc: TGetChildProc; Root: TComponent);
- var
- i: Integer;
- begin
- for i:=0 to ChildCount-1 do
- if Childs[i].Owner=Root then
- Proc(Childs[i]);
- end;
- procedure THTMLContentProducer.DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
- begin
- AContentProducer.BeforeGenerateContent;
- 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 not opened then
- close;
- end;
- SetupEvents(Result);
- 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;
- function THTMLCustomDatasetContentProducer.GetEvents: TEventRecords;
- begin
- AddEvent(result,jseInputChange,OnChange,'onchange',OnChangeCS);
- end;
- procedure THTMLCustomDatasetContentProducer.HandleAjaxRequest(ARequest: TRequest;
- AnAjaxResponse: TAjaxResponse);
- begin
- inherited HandleAjaxRequest(ARequest, AnAjaxResponse);
- case StrToIntDef(ARequest.QueryFields.Values['event'],-1) of
- jseInputChange : if assigned(OnChange) then OnChange(Self, ARequest, AnAjaxResponse);
- end;
- 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);
- THTML_select(result).onchange:=FjsOnChange;
- end;
- constructor THTMLSelectProducer.create(aOwner: TComponent);
- begin
- inherited create (aOwner);
- FUseValues := False;
- 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 := IntToStr(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 FUseValues then
- begin
- if assigned(FValue) then
- sel := (FValue.AsString = FPreSelected)
- end
- else if assigned(FItem) then
- sel := (FItem.AsString = FPreSelected);
- if assigned (FIsPreSelected) then
- FIsPreSelected (self, sel);
- selected := sel;
- if assigned (FValue) then
- Value := FValue.Asstring;
- end;
- end;
- constructor THTMLDatasetSelectProducer.create(aOwner: TComponent);
- begin
- inherited create(aOwner);
- Size := 1;
- FUseValues := False;
- 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
- FDocument := 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
- FreeAndNil(FWriter);
- end;
- Finally
- FreeAndNil(FDocument);
- 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;
- { THTMLCustomEntityProducer }
- function THTMLCustomEntityProducer.WriteContent(aWriter: THTMLWriter
- ): THTMLCustomElement;
- begin
- result := aWriter.StartElement(THtmlEntitiesClasses[FEntity]);
- DoWriteEntity(aWriter);
- inherited WriteContent(aWriter);
- aWriter.EndElement(THtmlEntitiesClasses[FEntity]);
- end;
- procedure THTMLCustomEntityProducer.DoWriteEntity(aWriter: THTMLWriter);
- begin
- if assigned (FOnWriteEntity) then
- FOnWriteEntity (self, aWriter);
- end;
- constructor THTMLCustomEntityProducer.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FEntity := heHtml;
- end;
- { THTMLCustomPageProducer }
- procedure THTMLCustomPageProducer.DoWriteEntity(aWriter: THTMLWriter);
- begin
- inherited DoWriteEntity(aWriter);
- DoWriteHeader(aWriter);
- aWriter.Startbody;
- DoWriteVisualHeader(aWriter);
- DoWriteVisualBody(aWriter);
- DoWriteVisualFooter(aWriter);
- awriter.Endbody;
- end;
- procedure THTMLCustomPageProducer.DoWriteHeader(aWriter: THTMLWriter);
- begin
- if assigned(FOnWriteHeader) then
- FOnWriteHeader(self,aWriter);
- if assigned(FHeaderProducer) then
- aWriter.AddElement(FHeaderProducer.WriteContent(aWriter));
- end;
- procedure THTMLCustomPageProducer.DoWriteVisualHeader(aWriter: THTMLWriter);
- begin
- if assigned(FOnWriteVisualHeader) then
- FOnWriteVisualHeader(self,aWriter);
- if assigned(FVisualHeaderProducer) then
- aWriter.AddElement(FVisualHeaderProducer.WriteContent(aWriter));
- end;
- procedure THTMLCustomPageProducer.DoWriteVisualBody(aWriter: THTMLWriter);
- begin
- if assigned(FOnWriteVisualBody) then
- FOnWriteVisualBody(self,aWriter);
- if assigned(FVisualBodyProducer) then
- aWriter.AddElement(FVisualBodyProducer.WriteContent(aWriter));
- end;
- procedure THTMLCustomPageProducer.DoWriteVisualFooter(aWriter: THTMLWriter);
- begin
- if assigned(FOnWriteVisualFooter) then
- FOnWriteVisualFooter(self,aWriter);
- if assigned(FVisualFooterProducer) then
- aWriter.AddElement(FVisualFooterProducer.WriteContent(aWriter));
- end;
- procedure THTMLCustomPageProducer.BeforeGenerateContent;
- begin
- inherited BeforeGenerateContent;
- if assigned(FHeaderProducer) then
- FHeaderProducer.BeforeGenerateContent;
- if assigned(FVisualHeaderProducer) then
- FVisualHeaderProducer.BeforeGenerateContent;
- if assigned(FVisualBodyProducer) then
- FVisualBodyProducer.BeforeGenerateContent;
- if assigned(FVisualFooterProducer) then
- FVisualFooterProducer.BeforeGenerateContent;
- end;
- constructor THTMLCustomPageProducer.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- Entity := heHtml;
- end;
- { TAjaxResponse }
- function TAjaxResponse.GetXMLAnswer: TXMLDocument;
- begin
- if not assigned(FXMLAnswer) then
- begin
- FXMLAnswer := TXMLDocument.create;
- FRootNode := FXMLAnswer.CreateElement('CallResponse');
- FXMLAnswer.Appendchild(FRootNode);
- end;
- result := FXMLAnswer;
- end;
- constructor TAjaxResponse.Create(AWebController: TWebController;
- AResponse: TResponse);
- begin
- FSendXMLAnswer:=true;
- FResponse:=AResponse;
- FWebController := AWebController;
- FJavascriptCallStack:=FWebController.InitializeJavaScriptStack(jtOther);
- end;
- destructor TAjaxResponse.Destroy;
- begin
- FXMLAnswer.Free;
- assert(FWebController.CurrentJavaScriptStack=FJavascriptCallStack);
- FWebController.FreeJavascriptStack;
- FJavascriptCallStack:=nil;
- inherited Destroy;
- end;
- procedure TAjaxResponse.BindToResponse;
- var SubNode: TDOMNode;
- begin
- if SendXMLAnswer then
- begin
- SubNode := XMLAnswer.CreateElement('ExecScript');
- FRootNode.Appendchild(SubNode);
- SubNode.Appendchild(XMLAnswer.CreateTextNode(FJavascriptCallStack.GetScript));
- Response.ContentStream := TMemoryStream.Create;
- Response.ContentType:='text/xml';
- writeXMLFile(XMLAnswer,Response.ContentStream);
- Response.ContentLength := Response.ContentStream.Size;
- end
- end;
- procedure TAjaxResponse.SetError(HelpContext: longint; ErrorMessage: string);
- var SubNode: TDOMNode;
- ErrNode: TDOMNode;
- begin
- ErrNode := XMLAnswer.CreateElement('Error');
- FRootNode.AppendChild(ErrNode);
- SubNode := XMLAnswer.CreateElement('HelpContext');
- SubNode.AppendChild(XMLAnswer.CreateTextNode(IntToStr(HelpContext)));
- ErrNode.AppendChild(SubNode);
- SubNode := XMLAnswer.CreateElement('Message');
- SubNode.AppendChild(XMLAnswer.CreateTextNode(ErrorMessage));
- ErrNode.AppendChild(SubNode);
- end;
- procedure TAjaxResponse.CancelXMLAnswer;
- begin
- FSendXMLAnswer:=false;
- end;
- { TWebController }
- function TWebController.GetJavaVariables: TJavaVariables;
- begin
- if not assigned(FJavaVariables) then
- FJavaVariables := TJavaVariables.Create(TJavaVariable);
- Result := FJavaVariables;
- end;
- function TWebController.GetJavaVariablesCount: integer;
- begin
- if assigned(FJavaVariables) then
- result := FJavaVariables.Count
- else
- result := 0;
- end;
- procedure TWebController.SetBaseURL(const AValue: string);
- begin
- if FBaseURL=AValue then exit;
- FBaseURL:=AValue;
- end;
- procedure TWebController.SetScriptName(const AValue: string);
- begin
- if FScriptName=AValue then exit;
- FScriptName:=AValue;
- end;
- function TWebController.GetCurrentJavaScriptStack: TJavaScriptStack;
- begin
- if FScriptStack.Count>0 then
- result := TJavaScriptStack(FScriptStack.Items[FScriptStack.Count-1])
- else
- result := nil;
- end;
- procedure TWebController.InitializeAjaxRequest;
- begin
- // do nothing
- end;
- procedure TWebController.InitializeShowRequest;
- begin
- // do nothing
- end;
- procedure TWebController.CleanupShowRequest;
- begin
- // Do Nothing
- end;
- procedure TWebController.CleanupAfterRequest;
- begin
- // Do Nothing
- end;
- procedure TWebController.BeforeGenerateHead;
- begin
- // do nothing
- end;
- function TWebController.AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
- begin
- result := GetJavaVariables.Add;
- result.BelongsTo := ABelongsTo;
- result.GetValueFunc := AGetValueFunc;
- result.Name := AName;
- result.IDSuffix := AIDSuffix;
- result.ID := AID;
- end;
- function TWebController.MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string;
- begin
- if assigned(MessageBoxHandler) then
- result := MessageBoxHandler(self,AText,Buttons,ALoaded)
- else
- result := DefaultMessageBoxHandler(self,AText,Buttons,ALoaded);
- end;
- function TWebController.AddrelativeLinkPrefix(AnURL: string): string;
- var
- i: Integer;
- begin
- if FAddRelURLPrefix and (AnURL<>'') and (copy(AnURL,1,1)<>'/') and assigned(Owner) and (owner is TWebPage) and assigned(TWebPage(Owner).Request) then
- result := TWebPage(Owner).Request.LocalPathPrefix + AnURL
- else
- result := AnURL;
- end;
- function TWebController.IncrementIterationLevel: integer;
- begin
- result := Length(FIterationIDs)+1;
- SetLength(FIterationIDs,Result);
- end;
- procedure TWebController.SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string);
- begin
- FIterationIDs[AIterationLevel-1]:=IDSuffix;
- end;
- function TWebController.GetIterationIDSuffix: string;
- var
- i: integer;
- begin
- result := '';
- for i := 0 to length(FIterationIDs)-1 do
- result := result + '_' + FIterationIDs[i];
- end;
- procedure TWebController.DecrementIterationLevel;
- var
- i: integer;
- begin
- i := length(FIterationIDs);
- if i=0 then
- raise Exception.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
- SetLength(FIterationIDs,i-1);
- end;
- function TWebController.GetRequest: TRequest;
- begin
- if assigned(Owner) and (owner is TWebPage) then
- result := TWebPage(Owner).Request
- else
- result := nil;
- end;
- constructor TWebController.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- { TODO : Do this prperly using a notification. And make the WebController property readonly }
- if owner is TWebPage then TWebPage(Owner).WebController := self;
- FScriptStack := TFPObjectList.Create(true);
- end;
- destructor TWebController.Destroy;
- begin
- if (Owner is TWebPage) and (TWebPage(Owner).WebController=self) then
- TWebPage(Owner).WebController := nil;
- FScriptStack.Free;
- if assigned(FJavaVariables) then FJavaVariables.Free;
- inherited Destroy;
- end;
- function TWebController.InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
- begin
- result := CreateNewJavascriptStack(AJavaType);
- FScriptStack.Add(result);
- end;
- procedure TWebController.FreeJavascriptStack;
- begin
- FScriptStack.Delete(FScriptStack.Count-1);
- end;
- end.
|