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