fphtml.pp 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473
  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;
  16. type
  17. { THTMLContentProducer }
  18. THTMLContentProducer = Class(THTTPContentProducer)
  19. private
  20. FDocument: THTMLDocument;
  21. FElement: THTMLCustomElement;
  22. FWriter: THTMLWriter;
  23. procedure SetDocument(const AValue: THTMLDocument);
  24. procedure SetWriter(const AValue: THTMLWriter);
  25. Protected
  26. function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
  27. public
  28. function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; virtual; abstract;
  29. Function ProduceContent : String; override; // Here to test the output. Replace to protected after tests
  30. property ParentElement : THTMLCustomElement read FElement write FElement;
  31. property Writer : THTMLWriter read FWriter write SetWriter;
  32. published
  33. Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
  34. end;
  35. TWriterElementEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter; var anElement : THTMLCustomElement) of object;
  36. TAfterElementEvent = procedure (Sender:THTMLContentProducer; anElement : THTMLCustomElement) of object;
  37. TWriterEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter) of object;
  38. TBooleanEvent = procedure (Sender:THTMLContentProducer; var flag : boolean) of object;
  39. { THTMLCustomDatasetContentProducer }
  40. THTMLCustomDatasetContentProducer = class (THTMLContentProducer)
  41. private
  42. FDatasource: TDatasource;
  43. FOnWriteFooter: TWriterEvent;
  44. FOnWriteHeader: TWriterElementEvent;
  45. FOnWriteRecord: TWriterEvent;
  46. function WriteHeader (aWriter : THTMLWriter) : THTMLCustomElement;
  47. procedure WriteFooter (aWriter : THTMLWriter);
  48. procedure WriteRecord (aWriter : THTMLWriter);
  49. protected
  50. function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
  51. procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); virtual;
  52. procedure DoWriteFooter (aWriter : THTMLWriter); virtual;
  53. procedure DoWriteRecord (aWriter : THTMLWriter); virtual;
  54. public
  55. Property OnWriteHeader : TWriterElementEvent read FOnWriteHeader write FOnWriteHeader;
  56. Property OnWriteFooter : TWriterEvent read FOnWriteFooter write FOnWriteFooter;
  57. Property OnWriteRecord : TWriterEvent read FOnWriteRecord write FOnWriteRecord;
  58. published
  59. Property DataSource : TDataSource read FDataSource write FDataSource;
  60. end;
  61. { THTMLDatasetContentProducer }
  62. THTMLDatasetContentProducer = class (THTMLCustomDatasetContentProducer)
  63. published
  64. Property OnWriteHeader;
  65. Property OnWriteFooter;
  66. Property OnWriteRecord;
  67. end;
  68. { THTMLSelectProducer }
  69. THTMLSelectProducer = class (THTMLContentProducer)
  70. private
  71. FControlName: string;
  72. FItems: TStrings;
  73. FPreSelected: string;
  74. FSize: integer;
  75. FUseValues: boolean;
  76. procedure SetItems(const AValue: TStrings);
  77. protected
  78. function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
  79. public
  80. constructor create (aOwner : TComponent); override;
  81. destructor destroy; override;
  82. published
  83. property Items : TStrings read FItems write SetItems;
  84. property UseValues : boolean read FUseValues write FUseValues default false;
  85. property PreSelected : string read FPreSelected write FPreSelected;
  86. property Size : integer read FSize write FSize default 1;
  87. property ControlName : string read FControlName write FControlName;
  88. end;
  89. { THTMLDatasetSelectProducer }
  90. THTMLDatasetSelectProducer = class (THTMLCustomDatasetContentProducer)
  91. private
  92. FControlName: string;
  93. FIsPreSelected: TBooleanEvent;
  94. FItemField: string;
  95. FSize: string;
  96. FValueField: string;
  97. FValue, FItem : TField;
  98. protected
  99. procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); override;
  100. procedure DoWriteFooter (aWriter : THTMLWriter); override;
  101. procedure DoWriteRecord (aWriter : THTMLWriter); override;
  102. public
  103. constructor create (aOwner : TComponent); override;
  104. published
  105. property ItemField : string read FItemField write FItemField;
  106. property ValueField : string read FValueField write FValueField;
  107. property OnIsPreSelected : TBooleanEvent read FIsPreSelected write FIsPreSelected;
  108. property Size : string read FSize write FSize;
  109. property ControlName : string read FControlName write FControlName;
  110. property OnWriteHeader;
  111. end;
  112. { THTMLDataModule }
  113. THTMLGetContentEvent = Procedure (Sender : TObject; ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean) of object;
  114. TCreateDocumentEvent = Procedure(Sender : TObject; var ADocument : THTMLDocument) of object;
  115. TCreateWriterEvent = Procedure(Sender : TObject; ADocument : THTMLDocument; Var AWriter : THTMLWriter) of object;
  116. { THTMLContentAction }
  117. THTMLContentAction = Class(TCustomWebAction)
  118. private
  119. FOnGetContent: THTMLGetContentEvent;
  120. Public
  121. Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
  122. Published
  123. Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
  124. end;
  125. { THTMLContentActions }
  126. THTMLContentActions = Class(TCustomWebActions)
  127. Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
  128. end;
  129. { TCustomHTMLDataModule }
  130. { TCustomHTMLModule }
  131. TCustomHTMLModule = Class(TCustomHTTPModule)
  132. private
  133. FDocument : THTMLDocument;
  134. FActions: THTMLContentActions;
  135. FOnCreateDocument: TCreateDocumentEvent;
  136. FOnCreateWriter: TCreateWriterEvent;
  137. FOnGetContent: THTMLGetContentEvent;
  138. procedure SetActions(const AValue: THTMLContentActions);
  139. Protected
  140. Function CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
  141. Function CreateDocument : THTMLDocument;
  142. Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
  143. Property Actions : THTMLContentActions Read FActions Write SetActions;
  144. Property OnCreateDocument : TCreateDocumentEvent Read FOnCreateDocument Write FOnCreateDocument;
  145. Property OnCreateWriter : TCreateWriterEvent Read FOnCreateWriter Write FOnCreateWriter;
  146. Public
  147. Constructor Create(AOwner : TComponent);override;
  148. Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
  149. end;
  150. TFPHTMLModule=Class(TCustomHTMLModule)
  151. Published
  152. Property OnGetContent;
  153. Property Actions;
  154. Property OnCreateDocument;
  155. Property OnCreateWriter;
  156. end;
  157. EHTMLError = Class(Exception);
  158. implementation
  159. {$ifdef cgidebug}
  160. Uses dbugintf;
  161. {$endif cgidebug}
  162. resourcestring
  163. SErrRequestNotHandled = 'Web request was not handled by actions.';
  164. { THTMLContentProducer }
  165. procedure THTMLContentProducer.SetWriter(const AValue: THTMLWriter);
  166. begin
  167. FWriter := AValue;
  168. if not assigned (FDocument) then
  169. FDocument := AValue.Document
  170. else if FDocument <> AValue.Document then
  171. AValue.document := FDocument;
  172. end;
  173. procedure THTMLContentProducer.SetDocument(const AValue: THTMLDocument);
  174. begin
  175. FDocument := AValue;
  176. if assigned (FWriter) and (AValue <> FWriter.Document) then
  177. FWriter.Document := AValue;
  178. end;
  179. function THTMLContentProducer.ProduceContent: String;
  180. var WCreated, created : boolean;
  181. el : THtmlCustomElement;
  182. begin
  183. created := not assigned (FDocument);
  184. if created then
  185. FDocument := THTMLDocument.Create;
  186. try
  187. WCreated := not assigned(FWriter);
  188. if WCreated then
  189. FWriter := CreateWriter (FDocument);
  190. try
  191. FWriter.CurrentElement := ParentElement;
  192. el := WriteContent (FWriter);
  193. result := el.asstring;
  194. finally
  195. if WCreated then
  196. FWriter.Free;
  197. end;
  198. finally
  199. if created then
  200. FDocument.Free;
  201. end;
  202. end;
  203. function THTMLContentProducer.CreateWriter (Doc : THTMLDocument): THTMLWriter;
  204. begin
  205. FDocument := Doc;
  206. result := THTMLWriter.Create (Doc);
  207. end;
  208. { THTMLCustomDatasetContentProducer }
  209. function THTMLCustomDatasetContentProducer.WriteHeader(aWriter: THTMLWriter): THTMLCustomElement;
  210. var el : THTmlCustomElement;
  211. begin
  212. el := nil;
  213. DoWriteHeader (aWriter, el);
  214. result := el;
  215. end;
  216. procedure THTMLCustomDatasetContentProducer.WriteFooter(aWriter: THTMLWriter);
  217. begin
  218. DoWriteFooter (aWriter);
  219. end;
  220. procedure THTMLCustomDatasetContentProducer.WriteRecord(aWriter: THTMLWriter);
  221. begin
  222. DoWriteRecord (aWriter);
  223. end;
  224. function THTMLCustomDatasetContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
  225. var opened : boolean;
  226. begin
  227. if assigned (FDataSource) and assigned(datasource.dataset) then
  228. begin
  229. result := WriteHeader (aWriter);
  230. try
  231. with FDataSource.dataset do
  232. try
  233. opened := Active;
  234. if not opened then
  235. Open;
  236. first;
  237. while not eof do
  238. begin
  239. WriteRecord(aWriter);
  240. next;
  241. end;
  242. finally
  243. if opened then
  244. close;
  245. end;
  246. finally
  247. WriteFooter (aWriter);
  248. end;
  249. end;
  250. end;
  251. procedure THTMLCustomDatasetContentProducer.DoWriteHeader(aWriter: THTMLWriter; var el : THTMLCustomElement);
  252. begin
  253. if assigned (FOnWriteHeader) then
  254. FOnWriteHeader (self, aWriter, el);
  255. end;
  256. procedure THTMLCustomDatasetContentProducer.DoWriteFooter(aWriter: THTMLWriter);
  257. begin
  258. if assigned (FOnWriteFooter) then
  259. FOnWriteFooter (self, aWriter);
  260. end;
  261. procedure THTMLCustomDatasetContentProducer.DoWriteRecord(aWriter: THTMLWriter);
  262. begin
  263. if assigned (FOnWriteRecord) then
  264. FOnWriteRecord (self, aWriter);
  265. end;
  266. { THTMLSelectProducer }
  267. procedure THTMLSelectProducer.SetItems(const AValue: TStrings);
  268. begin
  269. if FItems<>AValue then
  270. FItems.assign(AValue);
  271. end;
  272. function THTMLSelectProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
  273. begin
  274. result := aWriter.FormSelect(FControlName, FPreselected, FSize, FItems, FUseValues);
  275. end;
  276. constructor THTMLSelectProducer.create(aOwner: TComponent);
  277. begin
  278. inherited create (aOwner);
  279. FItems := TStringlist.Create;
  280. size := 1;
  281. end;
  282. destructor THTMLSelectProducer.destroy;
  283. begin
  284. FItems.Free;
  285. inherited;
  286. end;
  287. { THTMLDatasetSelectProducer }
  288. procedure THTMLDatasetSelectProducer.DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement);
  289. var s : THTML_Select;
  290. begin
  291. s := aWriter.StartSelect;
  292. s.size := FSize;
  293. s.name := FControlName;
  294. el := s;
  295. if FValueField <> '' then
  296. FValue := datasource.dataset.findfield (FValueField);
  297. if FItemField <> '' then
  298. FItem := DataSource.dataset.findfield (FItemField);
  299. inherited DoWriteHeader(aWriter, el);
  300. end;
  301. procedure THTMLDatasetSelectProducer.DoWriteFooter(aWriter: THTMLWriter);
  302. begin
  303. inherited DoWriteFooter(aWriter);
  304. aWriter.EndSelect;
  305. end;
  306. procedure THTMLDatasetSelectProducer.DoWriteRecord(aWriter: THTMLWriter);
  307. var sel : boolean;
  308. begin
  309. if assigned (FItem) then
  310. with aWriter.Option(FItem.asstring) do
  311. begin
  312. if assigned (FIsPreSelected) then
  313. begin
  314. sel := false;
  315. FIsPreSelected (self, sel);
  316. selected := sel;
  317. end;
  318. if assigned (FValue) then
  319. Value := FValue.Asstring;
  320. end;
  321. end;
  322. constructor THTMLDatasetSelectProducer.create(aOwner: TComponent);
  323. begin
  324. inherited create(aOwner);
  325. Size := '1';
  326. end;
  327. { TCustomHTMLDataModule }
  328. Function TCustomHTMLModule.CreateDocument : THTMLDocument;
  329. begin
  330. If Assigned(FOnCreateDocument) then
  331. FOnCreateDocument(Self,Result);
  332. If (Result=Nil) then
  333. Result:=THTMLDocument.Create;
  334. end;
  335. constructor TCustomHTMLModule.Create(AOwner: TComponent);
  336. begin
  337. FActions:=THTMLContentActions.Create(THTMLContentAction);
  338. inherited Create(AOwner);
  339. end;
  340. procedure TCustomHTMLModule.SetActions(const AValue: THTMLContentActions);
  341. begin
  342. end;
  343. Function TCustomHTMLModule.CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
  344. begin
  345. If Assigned(FOnCreateWriter) then
  346. FOnCreateWriter(Self,ADocument,Result);
  347. if (Result=Nil) then
  348. Result:=THTMLWriter.Create(ADocument);
  349. end;
  350. procedure TCustomHTMLModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
  351. Var
  352. FWriter : THTMLWriter;
  353. B : Boolean;
  354. M : TMemoryStream;
  355. begin
  356. CreateDocument;
  357. Try
  358. FWriter:=CreateWriter(FDocument);
  359. Try
  360. B:=False;
  361. If Assigned(OnGetContent) then
  362. OnGetContent(Self,ARequest,FWriter,B);
  363. If Not B then
  364. Raise EHTMLError.Create(SErrRequestNotHandled);
  365. If (AResponse.ContentStream=Nil) then
  366. begin
  367. M:=TMemoryStream.Create;
  368. AResponse.ContentStream:=M;
  369. end;
  370. FDocument.SaveToStream(AResponse.ContentStream);
  371. Finally
  372. FWriter.Free;
  373. end;
  374. Finally
  375. FDocument.Free;
  376. end;
  377. end;
  378. { THTMLContentActions }
  379. procedure THTMLContentActions.HandleRequest(ARequest: TRequest;
  380. HTMLPage: THTMLWriter; var Handled: Boolean);
  381. Var
  382. A : TCustomWebAction;
  383. begin
  384. {$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
  385. A:=GetRequestAction(ARequest);
  386. if Assigned(A) then
  387. (A as THTMLContentAction).HandleRequest(ARequest,HTMLPage,Handled);
  388. {$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
  389. end;
  390. { THTMLContentAction }
  391. procedure THTMLContentAction.HandleRequest(ARequest: TRequest;
  392. HTMLPage: THTMLWriter; var Handled: Boolean);
  393. begin
  394. If Assigned(FOngetContent) then
  395. FOnGetContent(Self,ARequest,HTMLPage,Handled);
  396. end;
  397. end.