1{
2    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
3    This file is part of the Free Component Library (FCL)
4    Copyright (c) 1999-2000 by the Free Pascal development team
5
6    See the file COPYING.FPC, included in this distribution,
7    for details about the copyright.
8
9    This program is distributed in the hope that it will be useful,
10    but WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 **********************************************************************}
14unit fphtml;
15
16{$mode objfpc}{$H+}
17
18interface
19
20uses
21  Classes, SysUtils, htmlelements, htmlwriter, httpdefs, fphttp, DB, DOM, contnrs;
22
23type
24  THtmlEntities = (heHtml,heBody,heHead,heDiv,heParagraph);
25
26const
27  THtmlEntitiesClasses : array[THtmlEntities] of THTMLElementClass =
28    (THTML_html, THTML_body, THTML_head, THTML_div, THTML_p);
29
30type
31
32  { TJavaScriptStack }
33  TWebButtonType = (btOk, btCancel, btCustom);
34  TWebButton = record
35    ButtonType: TWebButtonType;
36    Caption: String;
37    OnClick: String;
38  end;
39  TWebButtons = array of TWebButton;
40
41  TMessageBoxHandler = function(Sender: TObject; AText: String; Buttons: TWebButtons; Loaded: string = ''): string of object;
42  TOnGetUrlProc = procedure(ParamNames, ParamValues, KeepParams: array of string; Action: string; var URL: string) of object;
43  TWebController = class;
44  THTMLContentProducer = class;
45
46  TJavaType = (jtOther, jtClientSideEvent);
47
48  TJavaScriptStack = class(TObject)
49  private
50    FJavaType: TJavaType;
51    FMessageBoxHandler: TMessageBoxHandler;
52    FScript: TStrings;
53    FWebController: TWebController;
54  protected
55    function GetWebController: TWebController;
56  public
57    constructor Create(const AWebController: TWebController; const AJavaType: TJavaType); virtual;
58    destructor Destroy; override;
59    procedure AddScriptLine(ALine: String); virtual;
60    procedure MessageBox(AText: String; Buttons: TWebButtons; Loaded: string = ''); virtual;
61    procedure RedrawContentProducer(AContentProducer: THTMLContentProducer); virtual;
62    procedure CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = ''); virtual;
63    procedure Clear; virtual;
64    procedure Redirect(AUrl: string); virtual;
65    function ScriptIsEmpty: Boolean; virtual;
66    function GetScript: String; virtual;
67    property WebController: TWebController read GetWebController;
68    property JavaType: TJavaType read FJavaType;
69  end;
70
71  { TContainerStylesheet }
72
73  TContainerStylesheet = class(TCollectionItem)
74  private
75    Fhref: string;
76    Fmedia: string;
77  published
78    property href: string read Fhref write Fhref;
79    property media: string read Fmedia write Fmedia;
80  end;
81
82  { TContainerStylesheets }
83
84  TContainerStylesheets = class(TCollection)
85  private
86    function GetItem(Index: integer): TContainerStylesheet;
87    procedure SetItem(Index: integer; const AValue: TContainerStylesheet);
88  public
89    function Add: TContainerStylesheet;
90    property Items[Index: integer]: TContainerStylesheet read GetItem write SetItem;
91  end;
92
93  { TJavaVariable }
94
95  TJavaVariable = class(TCollectionItem)
96  private
97    FBelongsTo: string;
98    FGetValueFunc: string;
99    FID: string;
100    FIDSuffix: string;
101    FName: string;
102  public
103    property BelongsTo: string read FBelongsTo write FBelongsTo;
104    property GetValueFunc: string read FGetValueFunc write FGetValueFunc;
105    property Name: string read FName write FName;
106    property ID: string read FID write FID;
107    property IDSuffix: string read FIDSuffix write FIDSuffix;
108  end;
109
110  { TJavaVariables }
111
112  TJavaVariables = class(TCollection)
113  private
114    function GetItem(Index: integer): TJavaVariable;
115    procedure SetItem(Index: integer; const AValue: TJavaVariable);
116  public
117    function Add: TJavaVariable;
118    property Items[Index: integer]: TJavaVariable read GetItem write SetItem;
119  end;
120
121
122  { TWebController }
123
124  TWebController = class(TComponent)
125  private
126    FAddRelURLPrefix: boolean;
127    FBaseURL: string;
128    FMessageBoxHandler: TMessageBoxHandler;
129    FOnGetURL: TOnGetUrlProc;
130    FScriptName: string;
131    FScriptStack: TFPObjectList;
132    FIterationIDs: array of string;
133    FJavaVariables: TJavaVariables;
134    procedure SetBaseURL(const AValue: string);
135    procedure SetScriptName(const AValue: string);
136  protected
137    function GetJavaVariables: TJavaVariables;
138    function GetJavaVariablesCount: integer;
139    function GetScriptFileReferences: TStringList; virtual; abstract;
140    function GetCurrentJavaScriptStack: TJavaScriptStack; virtual;
141    function GetStyleSheetReferences: TContainerStylesheets; virtual; abstract;
142    function GetScripts: TFPObjectList; virtual; abstract;
143    function GetRequest: TRequest;
144    property OnGetURL: TOnGetUrlProc read FOnGetURL write FOnGetURL;
145  public
146    constructor Create(AOwner: TComponent); override;
147    destructor Destroy; override;
148    procedure AddScriptFileReference(AScriptFile: String); virtual; abstract;
149    procedure AddStylesheetReference(Ahref, Amedia: String); virtual; abstract;
150    function CreateNewJavascriptStack(AJavaType: TJavaType): TJavaScriptStack; virtual; abstract;
151    function InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
152    procedure FreeJavascriptStack; virtual;
153    function HasJavascriptStack: boolean; virtual; abstract;
154    function GetUrl(ParamNames, ParamValues, KeepParams: array of string; Action: string = ''): string; virtual; abstract;
155    procedure InitializeAjaxRequest; virtual;
156    procedure InitializeShowRequest; virtual;
157    procedure CleanupShowRequest; virtual;
158    procedure CleanupAfterRequest; virtual;
159    procedure BeforeGenerateHead; virtual;
160    function AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
161    procedure BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string); virtual; abstract;
162    function MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual;
163    function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons;  ALoaded: string = ''): string; virtual; abstract;
164    function CreateNewScript: TStringList; virtual; abstract;
165    function AddrelativeLinkPrefix(AnURL: string): string;
166    procedure FreeScript(var AScript: TStringList); virtual; abstract;
167    procedure ShowRegisteredScript(ScriptID: integer); virtual; abstract;
168
169    function IncrementIterationLevel: integer; virtual;
170    function ResetIterationLevel: integer; virtual;
171    procedure SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string); virtual;
172    function GetIterationIDSuffix: string; virtual;
173    procedure DecrementIterationLevel; virtual;
174
175    property ScriptFileReferences: TStringList read GetScriptFileReferences;
176    property StyleSheetReferences: TContainerStylesheets read GetStyleSheetReferences;
177    property Scripts: TFPObjectList read GetScripts;
178    property CurrentJavaScriptStack: TJavaScriptStack read GetCurrentJavaScriptStack;
179    property MessageBoxHandler: TMessageBoxHandler read FMessageBoxHandler write FMessageBoxHandler;
180  published
181    property BaseURL: string read FBaseURL write SetBaseURL;
182    property ScriptName: string read FScriptName write SetScriptName;
183    property AddRelURLPrefix: boolean read FAddRelURLPrefix write FAddRelURLPrefix;
184  end;
185
186  { TAjaxResponse }
187
188  TAjaxResponse= class(TObject)
189  private
190    FJavascriptCallStack: TJavaScriptStack;
191    FResponse: TResponse;
192    FSendXMLAnswer: boolean;
193    FXMLAnswer: TXMLDocument;
194    FRootNode: TDOMNode;
195    FWebController: TWebController;
196    function GetXMLAnswer: TXMLDocument;
197  public
198    constructor Create(AWebController: TWebController; AResponse: TResponse); virtual;
199    destructor Destroy; override;
200    procedure BindToResponse; virtual;
201    procedure SetError(HelpContext: longint; ErrorMessage: string);
202    procedure CancelXMLAnswer;
203    property Response: TResponse read FResponse;
204    property XMLAnswer: TXMLDocument read GetXMLAnswer;
205    property SendXMLAnswer: boolean read FSendXMLAnswer;
206    property JavascriptCallStack: TJavaScriptStack read FJavascriptCallStack;
207  end;
208
209  TCSAjaxEvent=procedure(Sender: TComponent; AJavascriptClass: TJavaScriptStack; var Handled: boolean) of object;
210  THandleAjaxEvent = procedure(Sender: TObject; ARequest: TRequest; AnAjaxResponse: TAjaxResponse) of object;
211
212  TEventRecord = record
213    csCallback: TCSAjaxEvent;
214    ServerEvent: THandleAjaxEvent;
215    ServerEventID: integer;
216    JavaEventName: string;
217  end;
218  TEventRecords = array of TEventRecord;
219
220  TForeachContentProducerProc = procedure(const AContentProducer: THTMLContentProducer) of object;
221
222  { IHTMLContentProducerContainer }
223
224  IHTMLContentProducerContainer = interface
225   ['{8B4D8AE0-4873-49BF-B677-D03C8A02CDA5}']
226    procedure AddContentProducer(AContentProducer: THTMLContentProducer);
227    procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
228    function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
229    function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
230    procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
231
232    function ProduceContent : string;
233  end;
234
235  { THTMLContentProducer }
236
237  THTMLContentProducer = Class(THTTPContentProducer, IHTMLContentProducerContainer)
238  private
239    FDocument: THTMLDocument;
240    FElement: THTMLCustomElement;
241    FWriter: THTMLWriter;
242    FIDSuffix: string;
243    procedure SetDocument(const AValue: THTMLDocument);
244    procedure SetWriter(const AValue: THTMLWriter);
245  private
246    // for streaming
247    FChilds: TFPList; // list of THTMLContentProducer
248    FParent: TComponent;
249    function GetContentProducerList: TFPList;
250    function GetContentProducers(Index: integer): THTMLContentProducer;
251    procedure SetParent(const AValue: TComponent);
252  Protected
253    function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
254    function GetIdentification: string; virtual;
255    function GetIDSuffix: string; virtual;
256    procedure SetIDSuffix(const AValue: string); virtual;
257  protected
258    // Methods for streaming
259    FAcceptChildsAtDesignTime: boolean;
260    procedure SetParentComponent(Value: TComponent); override;
261    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
262    procedure DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
263    function GetEvents: TEventRecords; virtual;
264    procedure AddEvent(var Events: TEventRecords; AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string; AcsCallBack: TCSAjaxEvent); virtual;
265    procedure DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean); virtual;
266    procedure SetupEvents(AHtmlElement: THtmlCustomElement); virtual;
267    function GetWebPage: TDataModule;
268    function GetWebController(const ExceptIfNotAvailable: boolean = true): TWebController;
269    property ContentProducerList: TFPList read GetContentProducerList;
270  public
271    procedure BeforeGenerateContent; virtual;
272    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; virtual;
273    Function ProduceContent : String; override; // Here to test the output. Replace to protected after tests
274    function GetParentComponent: TComponent; override;
275    property ParentElement : THTMLCustomElement read FElement write FElement;
276    property Writer : THTMLWriter read FWriter write SetWriter;
277    Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
278    Property IDSuffix : string read GetIDSuffix write SetIDSuffix;
279  public
280    // for streaming
281    constructor Create(AOwner: TComponent); override;
282    destructor destroy; override;
283    function HasParent: Boolean; override;
284    function ChildCount: integer;
285    procedure CleanupAfterRequest; virtual;
286    procedure AddContentProducer(AContentProducer: THTMLContentProducer);
287    procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
288    function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
289    function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
290    procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); virtual;
291    procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
292    property Identification: string read GetIdentification;
293    property Childs[Index: integer]: THTMLContentProducer read GetContentProducers;
294    property AcceptChildsAtDesignTime: boolean read FAcceptChildsAtDesignTime;
295    property parent: TComponent read FParent write SetParent;
296  end;
297  THTMLContentProducerClass = class of THTMLContentProducer;
298
299
300  TWriterElementEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter; var anElement : THTMLCustomElement) of object;
301  TAfterElementEvent = procedure (Sender:THTMLContentProducer; anElement : THTMLCustomElement) of object;
302  TWriterEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter) of object;
303  TBooleanEvent = procedure (Sender:THTMLContentProducer; var flag : boolean) of object;
304
305  { THTMLCustomEntityProducer }
306
307  THTMLCustomEntityProducer = class (THTMLContentProducer)
308  private
309    FOnWriteEntity: TWriterEvent;
310    FEntity: THtmlEntities;
311  protected
312    procedure DoWriteEntity (aWriter : THTMLWriter); virtual;
313    Property OnWriteEntity : TWriterEvent read FOnWriteEntity write FOnWriteEntity;
314    Property Entity : THtmlEntities read FEntity write FEntity default heHtml;
315  public
316    constructor Create(AOwner: TComponent); override;
317    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
318  end;
319
320  { THTMLEntityContentProducer }
321
322  THTMLEntityProducer = class (THTMLCustomEntityProducer)
323  published
324    Property OnWriteEntity;
325    Property Entity;
326  end;
327
328  { THTMLCustomPageProducer }
329
330  THTMLCustomPageProducer = class (THTMLCustomEntityProducer)
331  private
332    FHeaderProducer : THTMLContentProducer;
333    FOnWriteHeader: TWriterEvent;
334    FOnWriteVisualBody: TWriterEvent;
335    FOnWriteVisualFooter: TWriterEvent;
336    FOnWriteVisualHeader: TWriterEvent;
337    FVisualHeaderProducer : THTMLContentProducer;
338    FVisualBodyProducer : THTMLContentProducer;
339    FVisualFooterProducer : THTMLContentProducer;
340  protected
341    procedure DoWriteEntity (aWriter : THTMLWriter); override;
342    procedure DoWriteHeader (aWriter : THTMLWriter); virtual;
343    procedure DoWriteVisualHeader (aWriter : THTMLWriter); virtual;
344    procedure DoWriteVisualBody (aWriter : THTMLWriter); virtual;
345    procedure DoWriteVisualFooter (aWriter : THTMLWriter); virtual;
346    procedure BeforeGenerateContent; override;
347    Property HeaderProducer : THTMLContentProducer read FHeaderProducer write FHeaderProducer;
348    Property VisualHeaderProducer : THTMLContentProducer read FVisualHeaderProducer write FVisualHeaderProducer;
349    Property VisualBodyProducer : THTMLContentProducer read FVisualBodyProducer write FVisualBodyProducer;
350    Property VisualFooterProducer : THTMLContentProducer read FVisualFooterProducer write FVisualFooterProducer;
351    Property OnWriteHeader : TWriterEvent read FOnWriteHeader write FOnWriteHeader;
352    Property OnWriteVisualHeader : TWriterEvent read FOnWriteVisualHeader write FOnWriteVisualHeader;
353    Property OnWriteVisualBody : TWriterEvent read FOnWriteVisualBody write FOnWriteVisualBody;
354    Property OnWriteVisualFooter : TWriterEvent read FOnWriteVisualFooter write FOnWriteVisualFooter;
355  public
356    constructor Create(AOwner: TComponent); override;
357  end;
358
359  { THTMLPageProducer }
360
361  THTMLPageProducer = class (THTMLCustomPageProducer)
362  published
363    property OnWriteHeader;
364    property OnWriteVisualHeader;
365    property OnWriteVisualBody;
366    property OnWriteVisualFooter;
367    Property HeaderProducer;
368    Property VisualHeaderProducer;
369    Property VisualBodyProducer;
370    Property VisualFooterProducer;
371  end;
372
373  { THTMLCustomDatasetContentProducer }
374
375  THTMLCustomDatasetContentProducer = class (THTMLContentProducer)
376  private
377    FDatasource: TDatasource;
378    FOnChange: THandleAjaxEvent;
379    FOnChangeCS: TCSAjaxEvent;
380    FOnWriteFooter: TWriterEvent;
381    FOnWriteHeader: TWriterElementEvent;
382    FOnWriteRecord: TWriterEvent;
383    function WriteHeader (aWriter : THTMLWriter) : THTMLCustomElement;
384    procedure WriteFooter (aWriter : THTMLWriter);
385    procedure WriteRecord (aWriter : THTMLWriter);
386  protected
387    procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); virtual;
388    procedure DoWriteFooter (aWriter : THTMLWriter); virtual;
389    procedure DoWriteRecord (aWriter : THTMLWriter); virtual;
390    function GetEvents: TEventRecords; override;
391    procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); override;
392  public
393    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
394    Property OnWriteHeader : TWriterElementEvent read FOnWriteHeader write FOnWriteHeader;
395    Property OnWriteFooter : TWriterEvent read FOnWriteFooter write FOnWriteFooter;
396    Property OnWriteRecord : TWriterEvent read FOnWriteRecord write FOnWriteRecord;
397  published
398    Property DataSource : TDataSource read FDataSource write FDataSource;
399    property OnChangeCS: TCSAjaxEvent read FOnChangeCS write FOnChangeCS;
400    property OnChange: THandleAjaxEvent read FOnChange write FOnChange;
401  end;
402
403  { THTMLDatasetContentProducer }
404
405  THTMLDatasetContentProducer = class (THTMLCustomDatasetContentProducer)
406  published
407    Property OnWriteHeader;
408    Property OnWriteFooter;
409    Property OnWriteRecord;
410  end;
411
412  { THTMLSelectProducer }
413
414  THTMLSelectProducer = class (THTMLContentProducer)
415  private
416    FControlName: string;
417    FItems: TStrings;
418    FjsOnChange: string;
419    FPreSelected: string;
420    FSize: integer;
421    FUseValues: boolean;
422    procedure SetItems(const AValue: TStrings);
423  public
424    constructor create (aOwner : TComponent); override;
425    destructor destroy; override;
426    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
427  published
428    property Items : TStrings read FItems write SetItems;
429    property UseValues : boolean read FUseValues write FUseValues default false;
430    property PreSelected : string read FPreSelected write FPreSelected;
431    property Size : integer read FSize write FSize default 1;
432    property ControlName : string read FControlName write FControlName;
433    property jsOnChange: string read FjsOnChange write FjsOnChange;
434  end;
435
436  { THTMLDatasetSelectProducer }
437
438  THTMLDatasetSelectProducer = class (THTMLCustomDatasetContentProducer)
439  private
440    FControlName: string;
441    FIsPreSelected: TBooleanEvent;
442    FItemField: string;
443    FSize: integer;
444    FValueField: string;
445    FValue, FItem : TField;
446    FPreSelected: string;
447    FUseValues: boolean;
448  protected
449    procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); override;
450    procedure DoWriteFooter (aWriter : THTMLWriter); override;
451    procedure DoWriteRecord (aWriter : THTMLWriter); override;
452  public
453    constructor create (aOwner : TComponent); override;
454  published
455    property UseValues : boolean read FUseValues write FUseValues default false;
456    property PreSelected : string read FPreSelected write FPreSelected;
457    property ItemField : string read FItemField write FItemField;
458    property ValueField : string read FValueField write FValueField;
459    property OnIsPreSelected : TBooleanEvent read FIsPreSelected write FIsPreSelected;
460    property Size : integer read FSize write FSize;
461    property ControlName : string read FControlName write FControlName;
462    property OnWriteHeader;
463  end;
464
465  { THTMLDataModule }
466  THTMLGetContentEvent = Procedure (Sender : TObject; ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean) of object;
467  TCreateDocumentEvent = Procedure(Sender : TObject; var ADocument : THTMLDocument) of object;
468  TCreateWriterEvent = Procedure(Sender : TObject; ADocument : THTMLDocument; Var AWriter : THTMLWriter) of object;
469
470  { THTMLContentAction }
471
472  THTMLContentAction = Class(TCustomWebAction)
473  private
474    FOnGetContent: THTMLGetContentEvent;
475  Public
476    Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
477  Published
478    Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
479  end;
480
481  { THTMLContentActions }
482
483  THTMLContentActions = Class(TCustomWebActions)
484    Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
485  end;
486
487  { TCustomHTMLDataModule }
488
489  { TCustomHTMLModule }
490
491  TCustomHTMLModule = Class(TSessionHTTPModule)
492  private
493    FDocument : THTMLDocument;
494    FActions: THTMLContentActions;
495    FOnCreateDocument: TCreateDocumentEvent;
496    FOnCreateWriter: TCreateWriterEvent;
497    FOnGetContent: THTMLGetContentEvent;
498    procedure SetActions(const AValue: THTMLContentActions);
499  Protected
500    Function CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
501    Function CreateDocument : THTMLDocument;
502    Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
503    Property Actions : THTMLContentActions Read FActions Write SetActions;
504    Property OnCreateDocument : TCreateDocumentEvent Read FOnCreateDocument Write FOnCreateDocument;
505    Property OnCreateWriter : TCreateWriterEvent Read FOnCreateWriter Write FOnCreateWriter;
506  Public
507    Constructor Create(AOwner : TComponent);override;
508    Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
509    Property Document : THTMLDocument Read FDocument;
510  end;
511
512  TFPHTMLModule=Class(TCustomHTMLModule)
513  Published
514    Property Actions;
515    Property CreateSession;
516    Property Session;
517    Property OnCreateDocument;
518    Property OnCreateWriter;
519    Property OnGetContent;
520    Property OnNewSession;
521    Property OnSessionExpired;
522    Property CORS;
523  end;
524
525  EHTMLError = Class(EHTTP);
526
527const SimpleOkButton: array[0..0] of TWebButton = ((buttontype: btok;caption: 'Ok';onclick: ''));
528
529const jseButtonClick = 1000;
530      jseInputChange = 1001;
531      jseFormReset   = 1002;
532      jseFormSubmit  = 1003;
533
534implementation
535Uses
536{$ifdef cgidebug}
537  dbugintf
538{$endif cgidebug}
539  webpage, XMLWrite;
540
541resourcestring
542  SErrRequestNotHandled = 'Web request was not handled by actions.';
543  SErrNoContentProduced = 'The content producer "%s" didn''t produce any content.';
544
545{ TJavaVariables }
546
547function TJavaVariables.GetItem(Index: integer): TJavaVariable;
548begin
549  result := TJavaVariable(Inherited GetItem(Index));
550end;
551
552procedure TJavaVariables.SetItem(Index: integer; const AValue: TJavaVariable);
553begin
554  inherited SetItem(Index, AValue);
555end;
556
557function TJavaVariables.Add: TJavaVariable;
558begin
559  result := inherited Add as TJavaVariable;
560end;
561
562{ TcontainerStylesheets }
563
564function TcontainerStylesheets.GetItem(Index: integer): TContainerStylesheet;
565begin
566  result := TContainerStylesheet(Inherited GetItem(Index));
567end;
568
569procedure TcontainerStylesheets.SetItem(Index: integer; const AValue: TContainerStylesheet);
570begin
571  inherited SetItem(Index, AValue);
572end;
573
574function TcontainerStylesheets.Add: TContainerStylesheet;
575begin
576  result := inherited Add as TContainerStylesheet;
577end;
578
579
580{ TJavaScriptStack }
581
582function TJavaScriptStack.GetWebController: TWebController;
583begin
584  result := FWebController;
585end;
586
587constructor TJavaScriptStack.Create(const AWebController: TWebController; const AJavaType: TJavaType);
588begin
589  FWebController := AWebController;
590  FScript := TStringList.Create;
591  FJavaType := AJavaType;
592end;
593
594destructor TJavaScriptStack.Destroy;
595begin
596  FScript.Free;
597  inherited Destroy;
598end;
599
600procedure TJavaScriptStack.AddScriptLine(ALine: String);
601begin
602  FScript.Add(ALine);
603end;
604
605procedure TJavaScriptStack.MessageBox(AText: String; Buttons: TWebButtons; Loaded: string = '');
606begin
607  AddScriptLine(WebController.MessageBox(AText,Buttons,Loaded));
608end;
609
610procedure TJavaScriptStack.RedrawContentProducer(AContentProducer: THTMLContentProducer);
611begin
612  raise EHTMLError.Create('RedrawContentProducer not supported by current WebController');
613end;
614
615procedure TJavaScriptStack.CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = '');
616begin
617  raise EHTMLError.Create('SendServerEvent not supported by current WebController');
618end;
619
620procedure TJavaScriptStack.Clear;
621begin
622  FScript.Clear;
623end;
624
625procedure TJavaScriptStack.Redirect(AUrl: string);
626begin
627  AddScriptLine('window.location = "'+AUrl+'";');
628end;
629
630function TJavaScriptStack.ScriptIsEmpty: Boolean;
631begin
632  result := FScript.Count=0;
633end;
634
635function TJavaScriptStack.GetScript: String;
636begin
637  result := FScript.Text;
638end;
639
640
641{ THTMLContentProducer }
642
643procedure THTMLContentProducer.SetWriter(const AValue: THTMLWriter);
644begin
645  FWriter := AValue;
646  if not assigned (FDocument) then
647    FDocument := AValue.Document
648  else if FDocument <> AValue.Document then
649    AValue.document := FDocument;
650end;
651
652procedure THTMLContentProducer.SetDocument(const AValue: THTMLDocument);
653begin
654  FDocument := AValue;
655  if assigned (FWriter) and (AValue <> FWriter.Document) then
656    FWriter.Document := AValue;
657end;
658
659procedure THTMLContentProducer.SetParent(const AValue: TComponent);
660begin
661  if FParent=AValue then exit;
662  if FParent<>nil then
663    (FParent as IHTMLContentProducerContainer).RemoveContentProducer(Self);
664  FParent:=AValue;
665  if FParent<>nil then
666    (FParent as IHTMLContentProducerContainer).AddContentProducer(Self);
667end;
668
669function THTMLContentProducer.GetContentProducers(Index: integer): THTMLContentProducer;
670begin
671  Result:=THTMLContentProducer(ContentProducerList[Index]);
672end;
673
674function THTMLContentProducer.GetIDSuffix: string;
675begin
676  result := FIDSuffix;
677end;
678
679procedure THTMLContentProducer.SetIDSuffix(const AValue: string);
680begin
681  FIDSuffix := AValue;
682end;
683
684function THTMLContentProducer.GetContentProducerList: TFPList;
685begin
686  if not assigned(FChilds) then
687    fchilds := tfplist.Create;
688  Result := FChilds;
689end;
690
691function THTMLContentProducer.GetIdentification: string;
692begin
693  result := '';
694end;
695
696function THTMLContentProducer.ProduceContent: String;
697var WCreated, created : boolean;
698    el : THtmlCustomElement;
699begin
700  created := not assigned (FDocument);
701  if created then
702    FDocument := THTMLDocument.Create;
703  try
704    WCreated := not assigned(FWriter);
705    if WCreated then
706      FWriter := CreateWriter (FDocument);
707    try
708      FWriter.CurrentElement := ParentElement;
709      el := WriteContent (FWriter);
710      if not assigned(el) then
711        Raise EHTMLError.CreateFmt(SErrNoContentProduced,[Self.Name]);
712      BeforeGenerateContent;
713      ForeachContentProducer(@DoBeforeGenerateContent,True);
714      result := el.asstring;
715    finally
716      if WCreated then
717        FreeAndNil(FWriter);
718    end;
719  finally
720    if created then
721      FreeAndNil(FDocument);
722  end;
723end;
724
725constructor THTMLContentProducer.Create(AOwner: TComponent);
726begin
727  inherited Create(AOwner);
728  FAcceptChildsAtDesignTime:=True;
729end;
730
731destructor THTMLContentProducer.destroy;
732begin
733  Parent:=nil;
734  while ChildCount>0 do Childs[ChildCount-1].Free;
735  FreeAndNil(FChilds);
736  inherited destroy;
737end;
738
739function THTMLContentProducer.GetEvents: TEventRecords;
740begin
741  result := nil;
742end;
743
744procedure THTMLContentProducer.AddEvent(var Events: TEventRecords;
745  AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string;
746  AcsCallBack: TCSAjaxEvent);
747begin
748  SetLength(Events,length(Events)+1);
749  with Events[high(Events)] do
750    begin
751    ServerEvent:=AServerEvent;
752    ServerEventID:=AServerEventID;
753    JavaEventName:=AJavaEventName;
754    csCallback:=AcsCallBack;
755    end;
756end;
757
758procedure THTMLContentProducer.DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean);
759begin
760  if assigned(AnEvent.csCallback) then
761    AnEvent.csCallback(self, AJavascriptStack, Handled);
762end;
763
764procedure THTMLContentProducer.SetupEvents(AHtmlElement: THtmlCustomElement);
765var AJSClass: TJavaScriptStack;
766    wc: TWebController;
767    Handled: boolean;
768    Events: TEventRecords;
769    i: integer;
770begin
771  Events := GetEvents;
772  if length(Events)>0 then
773    begin
774    wc := GetWebController(false);
775    if assigned(wc) then
776      begin
777      AJSClass := wc.InitializeJavaScriptStack(jtClientSideEvent);
778      try
779        for i := 0 to high(Events) do
780          begin
781          Handled:=false;
782          DoOnEventCS(events[i],AJSClass, Handled);
783          if not handled and assigned(events[i].ServerEvent) then
784            AJSClass.CallServerEvent(self,events[i].ServerEventID);
785          wc.BindJavascriptCallstackToElement(Self, AHtmlElement,events[i].JavaEventName);
786          AJSClass.clear;
787          end;
788      finally
789        wc.FreeJavascriptStack;
790      end;
791      end
792    else
793      begin
794      for i := 0 to high(Events) do if assigned(events[i].csCallback) or assigned(events[i].ServerEvent) then
795        raise EHTMLError.Create('There is no webcontroller available, which is necessary to use events.');
796      end;
797    end;
798end;
799
800function THTMLContentProducer.GetWebPage: TDataModule;
801var
802  aowner: TComponent;
803begin
804  result := nil;
805  aowner := Owner;
806  while assigned(aowner) do
807    begin
808    if aowner.InheritsFrom(TWebPage) then
809      begin
810      result := TWebPage(aowner);
811      break;
812      end;
813    aowner:=aowner.Owner;
814    end;
815end;
816
817function THTMLContentProducer.GetWebController(const ExceptIfNotAvailable: boolean): TWebController;
818var
819  i : integer;
820  wp: TWebPage;
821begin
822  result := nil;
823  wp := TWebPage(GetWebPage);
824  if assigned(wp) then
825    begin
826    if wp.HasWebController then
827      begin
828      result := wp.WebController;
829      exit;
830      end;
831    end
832  else if assigned(Owner) then //if (owner is TDataModule) then
833    begin
834    for i := 0 to owner.ComponentCount-1 do if owner.Components[i] is TWebController then
835      begin
836      result := TWebController(Owner.Components[i]);
837      Exit;
838      end;
839    end;
840  if ExceptIfNotAvailable then
841    raise EHTMLError.Create('No webcontroller available');
842end;
843
844procedure THTMLContentProducer.BeforeGenerateContent;
845begin
846  // do nothing
847end;
848
849function THTMLContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
850var i: integer;
851begin
852  for i := 0 to ChildCount-1 do
853    if Childs[i] is THTMLContentProducer then
854      result := THTMLContentProducer(Childs[i]).WriteContent(aWriter);
855end;
856
857function THTMLContentProducer.ChildCount: integer;
858begin
859  if assigned(FChilds) then
860    result := FChilds.Count
861  else
862    result := 0;
863end;
864
865procedure THTMLContentProducer.CleanupAfterRequest;
866begin
867  // Do Nothing
868end;
869
870procedure THTMLContentProducer.AddContentProducer(AContentProducer: THTMLContentProducer);
871begin
872  ContentProducerList.Add(AContentProducer);
873end;
874
875procedure THTMLContentProducer.RemoveContentProducer(AContentProducer: THTMLContentProducer);
876begin
877  ContentProducerList.Remove(AContentProducer);
878end;
879
880function THTMLContentProducer.ExchangeContentProducers(Child1, Child2: THTMLContentProducer): boolean;
881var ChildIndex1, ChildIndex2: integer;
882begin
883  result := false;
884  ChildIndex1:=GetContentProducerList.IndexOf(Child1);
885  if (ChildIndex1=-1) then
886    Exit;
887  ChildIndex2:=GetContentProducerList.IndexOf(Child2);
888  if (ChildIndex2=-1) then
889    Exit;
890  GetContentProducerList.Exchange(ChildIndex1,ChildIndex2);
891  result := true;
892end;
893
894function THTMLContentProducer.MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer): boolean;
895var ChildIndex1, ChildIndex2: integer;
896begin
897  result := false;
898  ChildIndex1:=GetContentProducerList.IndexOf(MoveElement);
899  if (ChildIndex1=-1) then
900    Exit;
901  ChildIndex2:=GetContentProducerList.IndexOf(MoveBeforeElement);
902  if (ChildIndex2=-1) then
903    Exit;
904  if ChildIndex2>ChildIndex1 then dec(ChildIndex2);
905  GetContentProducerList.Move(ChildIndex1,ChildIndex2);
906  result := true;
907end;
908
909procedure THTMLContentProducer.HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse);
910begin
911  // Do nothing
912end;
913
914procedure THTMLContentProducer.ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
915var i : integer;
916    tmpChild: THTMLContentProducer;
917begin
918  for i := 0 to ChildCount -1 do
919    begin
920    tmpChild := Childs[i];
921    AForeachChildsProc(tmpChild);
922    if recursive then
923      tmpChild.ForeachContentProducer(AForeachChildsProc,Recursive);
924    end;
925end;
926
927function THTMLContentProducer.CreateWriter (Doc : THTMLDocument): THTMLWriter;
928begin
929  FDocument := Doc;
930  result := THTMLWriter.Create (Doc);
931end;
932
933procedure THTMLContentProducer.SetParentComponent(Value: TComponent);
934begin
935  if Supports(Value,IHTMLContentProducerContainer) then
936    Parent:=Value;
937end;
938
939function THTMLContentProducer.HasParent: Boolean;
940begin
941  Result:=FParent<>nil;
942end;
943
944function THTMLContentProducer.GetParentComponent: TComponent;
945begin
946  Result:=TComponent(Parent);
947end;
948
949procedure THTMLContentProducer.GetChildren(Proc: TGetChildProc; Root: TComponent);
950var
951  i: Integer;
952begin
953  for i:=0 to ChildCount-1 do
954    if Childs[i].Owner=Root then
955      Proc(Childs[i]);
956end;
957
958procedure THTMLContentProducer.DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
959begin
960  AContentProducer.BeforeGenerateContent;
961end;
962
963{ THTMLCustomDatasetContentProducer }
964
965function THTMLCustomDatasetContentProducer.WriteHeader(aWriter: THTMLWriter): THTMLCustomElement;
966var el : THTmlCustomElement;
967begin
968  el := nil;
969  DoWriteHeader (aWriter, el);
970  result := el;
971end;
972
973procedure THTMLCustomDatasetContentProducer.WriteFooter(aWriter: THTMLWriter);
974begin
975  DoWriteFooter (aWriter);
976end;
977
978procedure THTMLCustomDatasetContentProducer.WriteRecord(aWriter: THTMLWriter);
979begin
980  DoWriteRecord (aWriter);
981end;
982
983function THTMLCustomDatasetContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
984var opened : boolean;
985begin
986  if assigned (FDataSource) and assigned(datasource.dataset) then
987    begin
988    result := WriteHeader (aWriter);
989    try
990        with FDataSource.dataset do
991          try
992            opened := Active;
993            if not opened then
994              Open;
995            first;
996            while not eof do
997              begin
998              WriteRecord(aWriter);
999              next;
1000              end;
1001          finally
1002            if not opened then
1003              close;
1004          end;
1005      SetupEvents(Result);
1006    finally
1007      WriteFooter (aWriter);
1008    end;
1009    end;
1010end;
1011
1012procedure THTMLCustomDatasetContentProducer.DoWriteHeader(aWriter: THTMLWriter; var el : THTMLCustomElement);
1013begin
1014  if assigned (FOnWriteHeader) then
1015    FOnWriteHeader (self, aWriter, el);
1016end;
1017
1018procedure THTMLCustomDatasetContentProducer.DoWriteFooter(aWriter: THTMLWriter);
1019begin
1020  if assigned (FOnWriteFooter) then
1021    FOnWriteFooter (self, aWriter);
1022end;
1023
1024procedure THTMLCustomDatasetContentProducer.DoWriteRecord(aWriter: THTMLWriter);
1025begin
1026  if assigned (FOnWriteRecord) then
1027    FOnWriteRecord (self, aWriter);
1028end;
1029
1030function THTMLCustomDatasetContentProducer.GetEvents: TEventRecords;
1031begin
1032  AddEvent(result,jseInputChange,OnChange,'onchange',OnChangeCS);
1033end;
1034
1035procedure THTMLCustomDatasetContentProducer.HandleAjaxRequest(ARequest: TRequest;
1036  AnAjaxResponse: TAjaxResponse);
1037begin
1038  inherited HandleAjaxRequest(ARequest, AnAjaxResponse);
1039  case StrToIntDef(ARequest.QueryFields.Values['event'],-1) of
1040    jseInputChange : if assigned(OnChange) then OnChange(Self, ARequest, AnAjaxResponse);
1041  end;
1042end;
1043
1044{ THTMLSelectProducer }
1045
1046procedure THTMLSelectProducer.SetItems(const AValue: TStrings);
1047begin
1048  if FItems<>AValue then
1049    FItems.assign(AValue);
1050end;
1051
1052function THTMLSelectProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
1053begin
1054  result := aWriter.FormSelect(FControlName, FPreselected, FSize, FItems, FUseValues);
1055  THTML_select(result).onchange:=FjsOnChange;
1056end;
1057
1058constructor THTMLSelectProducer.create(aOwner: TComponent);
1059begin
1060  inherited create (aOwner);
1061  FUseValues := False;
1062  FItems := TStringlist.Create;
1063  size := 1;
1064end;
1065
1066destructor THTMLSelectProducer.destroy;
1067begin
1068  FItems.Free;
1069  inherited;
1070end;
1071
1072{ THTMLDatasetSelectProducer }
1073
1074procedure THTMLDatasetSelectProducer.DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement);
1075var s : THTML_Select;
1076begin
1077  s := aWriter.StartSelect;
1078  s.size := IntToStr(FSize);
1079  s.name := FControlName;
1080  el := s;
1081  if FValueField <> '' then
1082    FValue := datasource.dataset.findfield (FValueField);
1083  if FItemField <> '' then
1084    FItem := DataSource.dataset.findfield (FItemField);
1085  inherited DoWriteHeader(aWriter, el);
1086end;
1087
1088procedure THTMLDatasetSelectProducer.DoWriteFooter(aWriter: THTMLWriter);
1089begin
1090  inherited DoWriteFooter(aWriter);
1091  aWriter.EndSelect;
1092end;
1093
1094procedure THTMLDatasetSelectProducer.DoWriteRecord(aWriter: THTMLWriter);
1095var sel : boolean;
1096begin
1097  if assigned (FItem) then
1098    with aWriter.Option(FItem.asstring) do
1099      begin
1100      if FUseValues then
1101        begin
1102        if assigned(FValue) then
1103          sel := (FValue.AsString = FPreSelected)
1104        end
1105      else if assigned(FItem) then
1106        sel := (FItem.AsString = FPreSelected);
1107      if assigned (FIsPreSelected) then
1108        FIsPreSelected (self, sel);
1109      selected := sel;
1110      if assigned (FValue) then
1111        Value := FValue.Asstring;
1112      end;
1113end;
1114
1115constructor THTMLDatasetSelectProducer.create(aOwner: TComponent);
1116begin
1117  inherited create(aOwner);
1118  Size := 1;
1119  FUseValues := False;
1120end;
1121
1122{ TCustomHTMLDataModule }
1123
1124Function TCustomHTMLModule.CreateDocument : THTMLDocument;
1125
1126begin
1127  Result:=Nil;
1128  If Assigned(FOnCreateDocument) then
1129    FOnCreateDocument(Self,Result);
1130  If (Result=Nil) then
1131    Result:=THTMLDocument.Create;
1132end;
1133
1134constructor TCustomHTMLModule.Create(AOwner: TComponent);
1135begin
1136  FActions:=THTMLContentActions.Create(THTMLContentAction);
1137  inherited Create(AOwner);
1138end;
1139
1140procedure TCustomHTMLModule.SetActions(const AValue: THTMLContentActions);
1141begin
1142  FActions.Assign(AValue);
1143end;
1144
1145Function TCustomHTMLModule.CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
1146
1147begin
1148  Result:=Nil;
1149  If Assigned(FOnCreateWriter) then
1150    FOnCreateWriter(Self,ADocument,Result);
1151  if (Result=Nil) then
1152    Result:=THTMLWriter.Create(ADocument);
1153end;
1154
1155
1156procedure TCustomHTMLModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
1157
1158Var
1159  FWriter : THTMLWriter;
1160  B : Boolean;
1161  M : TMemoryStream;
1162
1163
1164begin
1165  FDocument := CreateDocument;
1166  Try
1167    FWriter:=CreateWriter(FDocument);
1168    Try
1169      B:=False;
1170      if Not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then
1171        If Assigned(OnGetContent) then
1172          OnGetContent(Self,ARequest,FWriter,B);
1173        If Not B then
1174          Actions.HandleRequest(ARequest,FWriter,B);
1175        If Not B then
1176          Raise EHTMLError.Create(SErrRequestNotHandled);
1177        If (AResponse.ContentStream=Nil) then
1178          begin
1179          M:=TMemoryStream.Create;
1180          AResponse.ContentStream:=M;
1181          AResponse.FreeContentStream:=True;
1182          end;
1183        if not AResponse.ContentSent then
1184          begin
1185          FDocument.SaveToStream(AResponse.ContentStream);
1186          AResponse.ContentStream.Position:=0;
1187          if (AResponse.ContentType='') then
1188             AResponse.ContentType:='text/html';
1189          AResponse.ContentLength:=AResponse.ContentStream.Size;
1190          AResponse.SendContent;
1191          end;
1192    Finally
1193      FreeAndNil(FWriter);
1194    end;
1195  Finally
1196    FreeAndNil(FDocument);
1197  end;
1198end;
1199
1200{ THTMLContentActions }
1201
1202procedure THTMLContentActions.HandleRequest(ARequest: TRequest;
1203  HTMLPage: THTMLWriter; var Handled: Boolean);
1204
1205Var
1206  A : TCustomWebAction;
1207
1208begin
1209{$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
1210  A:=GetRequestAction(ARequest);
1211  if Assigned(A) then
1212    (A as THTMLContentAction).HandleRequest(ARequest,HTMLPage,Handled);
1213{$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
1214end;
1215
1216
1217{ THTMLContentAction }
1218
1219procedure THTMLContentAction.HandleRequest(ARequest: TRequest;
1220  HTMLPage: THTMLWriter; var Handled: Boolean);
1221begin
1222  If Assigned(FOngetContent) then
1223    FOnGetContent(Self,ARequest,HTMLPage,Handled);
1224end;
1225
1226{ THTMLCustomEntityProducer }
1227
1228function THTMLCustomEntityProducer.WriteContent(aWriter: THTMLWriter
1229  ): THTMLCustomElement;
1230begin
1231  result := aWriter.StartElement(THtmlEntitiesClasses[FEntity]);
1232  DoWriteEntity(aWriter);
1233  inherited WriteContent(aWriter);
1234  aWriter.EndElement(THtmlEntitiesClasses[FEntity]);
1235end;
1236
1237procedure THTMLCustomEntityProducer.DoWriteEntity(aWriter: THTMLWriter);
1238begin
1239  if assigned (FOnWriteEntity) then
1240    FOnWriteEntity (self, aWriter);
1241end;
1242
1243constructor THTMLCustomEntityProducer.Create(AOwner: TComponent);
1244begin
1245  inherited Create(AOwner);
1246  FEntity := heHtml;
1247end;
1248
1249{ THTMLCustomPageProducer }
1250
1251procedure THTMLCustomPageProducer.DoWriteEntity(aWriter: THTMLWriter);
1252begin
1253  inherited DoWriteEntity(aWriter);
1254  DoWriteHeader(aWriter);
1255  aWriter.Startbody;
1256  DoWriteVisualHeader(aWriter);
1257  DoWriteVisualBody(aWriter);
1258  DoWriteVisualFooter(aWriter);
1259  awriter.Endbody;
1260end;
1261
1262procedure THTMLCustomPageProducer.DoWriteHeader(aWriter: THTMLWriter);
1263begin
1264  if assigned(FOnWriteHeader) then
1265    FOnWriteHeader(self,aWriter);
1266  if assigned(FHeaderProducer) then
1267    aWriter.AddElement(FHeaderProducer.WriteContent(aWriter));
1268end;
1269
1270procedure THTMLCustomPageProducer.DoWriteVisualHeader(aWriter: THTMLWriter);
1271begin
1272  if assigned(FOnWriteVisualHeader) then
1273    FOnWriteVisualHeader(self,aWriter);
1274  if assigned(FVisualHeaderProducer) then
1275    aWriter.AddElement(FVisualHeaderProducer.WriteContent(aWriter));
1276end;
1277
1278procedure THTMLCustomPageProducer.DoWriteVisualBody(aWriter: THTMLWriter);
1279begin
1280  if assigned(FOnWriteVisualBody) then
1281    FOnWriteVisualBody(self,aWriter);
1282  if assigned(FVisualBodyProducer) then
1283    aWriter.AddElement(FVisualBodyProducer.WriteContent(aWriter));
1284end;
1285
1286procedure THTMLCustomPageProducer.DoWriteVisualFooter(aWriter: THTMLWriter);
1287begin
1288  if assigned(FOnWriteVisualFooter) then
1289    FOnWriteVisualFooter(self,aWriter);
1290  if assigned(FVisualFooterProducer) then
1291    aWriter.AddElement(FVisualFooterProducer.WriteContent(aWriter));
1292end;
1293
1294procedure THTMLCustomPageProducer.BeforeGenerateContent;
1295begin
1296  inherited BeforeGenerateContent;
1297  if assigned(FHeaderProducer) then
1298    FHeaderProducer.BeforeGenerateContent;
1299  if assigned(FVisualHeaderProducer) then
1300    FVisualHeaderProducer.BeforeGenerateContent;
1301  if assigned(FVisualBodyProducer) then
1302    FVisualBodyProducer.BeforeGenerateContent;
1303  if assigned(FVisualFooterProducer) then
1304    FVisualFooterProducer.BeforeGenerateContent;
1305end;
1306
1307constructor THTMLCustomPageProducer.Create(AOwner: TComponent);
1308begin
1309  inherited Create(AOwner);
1310  Entity := heHtml;
1311end;
1312
1313{ TAjaxResponse }
1314
1315function TAjaxResponse.GetXMLAnswer: TXMLDocument;
1316begin
1317  if not assigned(FXMLAnswer) then
1318    begin
1319    FXMLAnswer := TXMLDocument.create;
1320    FRootNode := FXMLAnswer.CreateElement('CallResponse');
1321    FXMLAnswer.Appendchild(FRootNode);
1322    end;
1323  result := FXMLAnswer;
1324end;
1325
1326constructor TAjaxResponse.Create(AWebController: TWebController;
1327  AResponse: TResponse);
1328begin
1329  FSendXMLAnswer:=true;
1330  FResponse:=AResponse;
1331  FWebController := AWebController;
1332  FJavascriptCallStack:=FWebController.InitializeJavaScriptStack(jtOther);
1333end;
1334
1335destructor TAjaxResponse.Destroy;
1336begin
1337  FXMLAnswer.Free;
1338  assert(FWebController.CurrentJavaScriptStack=FJavascriptCallStack);
1339  FWebController.FreeJavascriptStack;
1340  FJavascriptCallStack:=nil;
1341  inherited Destroy;
1342end;
1343
1344procedure TAjaxResponse.BindToResponse;
1345var SubNode: TDOMNode;
1346begin
1347  if SendXMLAnswer then
1348    begin
1349    SubNode := XMLAnswer.CreateElement('ExecScript');
1350    FRootNode.Appendchild(SubNode);
1351    SubNode.Appendchild(XMLAnswer.CreateTextNode(FJavascriptCallStack.GetScript));
1352
1353    Response.ContentStream := TMemoryStream.Create;
1354    Response.ContentType:='text/xml';
1355    writeXMLFile(XMLAnswer,Response.ContentStream);
1356    Response.ContentLength := Response.ContentStream.Size;
1357    end
1358end;
1359
1360procedure TAjaxResponse.SetError(HelpContext: longint; ErrorMessage: string);
1361var SubNode: TDOMNode;
1362    ErrNode: TDOMNode;
1363begin
1364  ErrNode := XMLAnswer.CreateElement('Error');
1365  FRootNode.AppendChild(ErrNode);
1366  SubNode := XMLAnswer.CreateElement('HelpContext');
1367  SubNode.AppendChild(XMLAnswer.CreateTextNode(IntToStr(HelpContext)));
1368  ErrNode.AppendChild(SubNode);
1369  SubNode := XMLAnswer.CreateElement('Message');
1370  SubNode.AppendChild(XMLAnswer.CreateTextNode(ErrorMessage));
1371  ErrNode.AppendChild(SubNode);
1372end;
1373
1374procedure TAjaxResponse.CancelXMLAnswer;
1375begin
1376  FSendXMLAnswer:=false;
1377end;
1378
1379{ TWebController }
1380
1381function TWebController.GetJavaVariables: TJavaVariables;
1382begin
1383  if not assigned(FJavaVariables) then
1384    FJavaVariables := TJavaVariables.Create(TJavaVariable);
1385  Result := FJavaVariables;
1386end;
1387
1388function TWebController.GetJavaVariablesCount: integer;
1389begin
1390  if assigned(FJavaVariables) then
1391    result := FJavaVariables.Count
1392  else
1393    result := 0;
1394end;
1395
1396procedure TWebController.SetBaseURL(const AValue: string);
1397begin
1398  if FBaseURL=AValue then exit;
1399  FBaseURL:=AValue;
1400end;
1401
1402procedure TWebController.SetScriptName(const AValue: string);
1403begin
1404  if FScriptName=AValue then exit;
1405  FScriptName:=AValue;
1406end;
1407
1408function TWebController.GetCurrentJavaScriptStack: TJavaScriptStack;
1409begin
1410  if FScriptStack.Count>0 then
1411    result := TJavaScriptStack(FScriptStack.Items[FScriptStack.Count-1])
1412  else
1413    result := nil;
1414end;
1415
1416procedure TWebController.InitializeAjaxRequest;
1417begin
1418  // do nothing
1419end;
1420
1421procedure TWebController.InitializeShowRequest;
1422begin
1423  // do nothing
1424end;
1425
1426procedure TWebController.CleanupShowRequest;
1427begin
1428  // Do Nothing
1429end;
1430
1431procedure TWebController.CleanupAfterRequest;
1432begin
1433  // Do Nothing
1434end;
1435
1436procedure TWebController.BeforeGenerateHead;
1437begin
1438  // do nothing
1439end;
1440
1441function TWebController.AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
1442begin
1443  result := GetJavaVariables.Add;
1444  result.BelongsTo := ABelongsTo;
1445  result.GetValueFunc := AGetValueFunc;
1446  result.Name := AName;
1447  result.IDSuffix := AIDSuffix;
1448  result.ID := AID;
1449end;
1450
1451function TWebController.MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string;
1452begin
1453  if assigned(MessageBoxHandler) then
1454    result := MessageBoxHandler(self,AText,Buttons,ALoaded)
1455  else
1456    result := DefaultMessageBoxHandler(self,AText,Buttons,ALoaded);
1457end;
1458
1459function TWebController.AddrelativeLinkPrefix(AnURL: string): string;
1460var
1461  i: Integer;
1462begin
1463  if FAddRelURLPrefix and (AnURL<>'') and (copy(AnURL,1,1)<>'/') and assigned(Owner) and (owner is TWebPage) and assigned(TWebPage(Owner).Request) then
1464    result := TWebPage(Owner).Request.LocalPathPrefix + AnURL
1465  else
1466    result := AnURL;
1467end;
1468
1469function TWebController.IncrementIterationLevel: integer;
1470begin
1471  result := Length(FIterationIDs)+1;
1472  SetLength(FIterationIDs,Result);
1473end;
1474
1475function TWebController.ResetIterationLevel: integer;
1476begin
1477  SetLength(FIterationIDs,0);
1478end;
1479
1480procedure TWebController.SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string);
1481begin
1482  FIterationIDs[AIterationLevel-1]:=IDSuffix;
1483end;
1484
1485function TWebController.GetIterationIDSuffix: string;
1486var
1487  i: integer;
1488begin
1489  result := '';
1490  for i := 0 to length(FIterationIDs)-1 do
1491    result := result + '_' + FIterationIDs[i];
1492end;
1493
1494procedure TWebController.DecrementIterationLevel;
1495var
1496  i: integer;
1497begin
1498  i := length(FIterationIDs);
1499  if i=0 then
1500    raise EHTMLError.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
1501  SetLength(FIterationIDs,i-1);
1502end;
1503
1504function TWebController.GetRequest: TRequest;
1505begin
1506  if assigned(Owner) and (owner is TWebPage) then
1507    result := TWebPage(Owner).Request
1508  else
1509    result := nil;
1510end;
1511
1512constructor TWebController.Create(AOwner: TComponent);
1513begin
1514  inherited Create(AOwner);
1515  { TODO : Do this prperly using a notification. And make the WebController property readonly }
1516  if owner is TWebPage then TWebPage(Owner).WebController := self;
1517  FScriptStack := TFPObjectList.Create(true);
1518end;
1519
1520destructor TWebController.Destroy;
1521begin
1522  if (Owner is TWebPage) and (TWebPage(Owner).WebController=self) then
1523    TWebPage(Owner).WebController := nil;
1524  FScriptStack.Free;
1525  if assigned(FJavaVariables) then FJavaVariables.Free;
1526  inherited Destroy;
1527end;
1528
1529function TWebController.InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
1530begin
1531  result := CreateNewJavascriptStack(AJavaType);
1532  FScriptStack.Add(result);
1533end;
1534
1535procedure TWebController.FreeJavascriptStack;
1536begin
1537  FScriptStack.Delete(FScriptStack.Count-1);
1538end;
1539
1540
1541end.
1542
1543