fphtml.pp 46 KB

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