home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Demos / Webserv / main.pas < prev   
Pascal/Delphi Source File  |  1999-08-11  |  6KB  |  186 lines
  1. unit main;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   HTTPApp, DBWeb, DBTables, Db, DSProd;
  8.  
  9. type
  10.   TCustomerInfoModule = class(TWebModule)
  11.     Query1: TQuery;
  12.     CustomerOrders: TQueryTableProducer;
  13.     CustomerList: TPageProducer;
  14.     Customer: TTable;
  15.     CustomerCustNo: TFloatField;
  16.     CustomerCompany: TStringField;
  17.     CustSource: TDataSource;
  18.     BioLife: TTable;
  19.     BioLifeProducer: TDataSetPageProducer;
  20.     BioLifeSpeciesNo: TFloatField;
  21.     BioLifeCategory: TStringField;
  22.     BioLifeCommon_Name: TStringField;
  23.     BioLifeSpeciesName: TStringField;
  24.     BioLifeLengthcm: TFloatField;
  25.     BioLifeLength_In: TFloatField;
  26.     BioLifeNotes: TMemoField;
  27.     BioLifeGraphic: TGraphicField;
  28.     Root: TPageProducer;
  29.     procedure CustomerListHTMLTag(Sender: TObject; Tag: TTag;
  30.       const TagString: String; TagParams: TStrings;
  31.       var ReplaceText: String);
  32.     procedure DataModule1Create(Sender: TObject);
  33.     procedure WebModule1CustomerListAction(Sender: TObject;
  34.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  35.     procedure WebModule1QueryActionAction(Sender: TObject;
  36.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  37.     procedure CustomerInfoModuleRedirectAction(Sender: TObject;
  38.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  39.     procedure BioLifeGraphicGetText(Sender: TField; var Text: String;
  40.       DisplayText: Boolean);
  41.     procedure CustomerInfoModuleGetImageAction(Sender: TObject;
  42.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  43.     procedure CustomerInfoModuleBioLifeAction(Sender: TObject;
  44.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  45.     procedure BioLifeNotesGetText(Sender: TField; var Text: String;
  46.       DisplayText: Boolean);
  47.     procedure CustomerInfoModulerootAction(Sender: TObject;
  48.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  49.     procedure RootHTMLTag(Sender: TObject; Tag: TTag;
  50.       const TagString: String; TagParams: TStrings;
  51.       var ReplaceText: String);
  52.   private
  53.     ScriptName: String;
  54.   public
  55.     { Public declarations }
  56.   end;
  57.  
  58. var
  59.   CustomerInfoModule: TCustomerInfoModule;
  60.  
  61. implementation
  62.  
  63. uses JPeg;
  64.  
  65. {$R *.DFM}
  66.  
  67. procedure TCustomerInfoModule.CustomerListHTMLTag(Sender: TObject; Tag: TTag;
  68.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  69. var
  70.   Customers: String;
  71. begin
  72.   if CompareText(TagString, 'CUSTLIST') = 0 then
  73.   begin
  74.     Customers := '';
  75.     Customer.First;
  76.     while not Customer.Eof do
  77.     begin
  78.       Customers := Customers + Format('<A HREF="/scripts/%s/runquery?CustNo=%d">%s</A><BR>',
  79.         [ScriptName, CustomerCustNo.AsInteger, CustomerCompany.AsString]);
  80.       Customer.Next;
  81.     end;
  82.   end;
  83.   ReplaceText := Customers;
  84. end;
  85.  
  86. procedure TCustomerInfoModule.DataModule1Create(Sender: TObject);
  87. var
  88.   FN: array[0..MAX_PATH- 1] of char;
  89. begin
  90.   Customer.Open;
  91.   BioLife.Open;
  92.   SetString(ScriptName, FN, GetModuleFileName(hInstance, FN, SizeOf(FN)));
  93.   ScriptName := ExtractFileName(ScriptName);
  94. end;
  95.  
  96. procedure TCustomerInfoModule.WebModule1CustomerListAction(Sender: TObject;
  97.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  98. begin
  99.   Response.Content := CustomerList.Content;
  100. end;
  101.  
  102. procedure TCustomerInfoModule.WebModule1QueryActionAction(Sender: TObject;
  103.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  104. begin
  105.   if Customer.Locate('CustNo', Request.QueryFields.Values['CustNo'], []) then
  106.   begin
  107.     CustomerOrders.Header.Clear;
  108.     CustomerOrders.Header.Add('The following table was produced using a TDatasetTableProducer.<P>');    
  109.     CustomerOrders.Header.Add('Orders for: ' + CustomerCompany.AsString);
  110.     Response.Content := CustomerOrders.Content;
  111.   end
  112.   else
  113.     Response.Content := Format('<html><body><b>Customer: %s not found</b></body></html>',
  114.       [Request.QueryFields.Values['CustNo']]);
  115. end;
  116.  
  117. procedure TCustomerInfoModule.CustomerInfoModuleRedirectAction(
  118.   Sender: TObject; Request: TWebRequest; Response: TWebResponse;
  119.   var Handled: Boolean);
  120. begin
  121.   Response.SendRedirect('http://www.borland.com');
  122. end;
  123.  
  124. procedure TCustomerInfoModule.BioLifeGraphicGetText(Sender: TField;
  125.   var Text: String; DisplayText: Boolean);
  126. begin
  127.   Text := Format('<IMG SRC="/scripts/%s/getimage" alt="[%s]" border="0">',
  128.     [ScriptName, BiolifeCommon_Name.Text]);
  129. end;
  130.  
  131. procedure TCustomerInfoModule.CustomerInfoModuleGetImageAction(
  132.   Sender: TObject; Request: TWebRequest; Response: TWebResponse;
  133.   var Handled: Boolean);
  134. var
  135.   Jpg: TJpegImage;
  136.   S: TMemoryStream;
  137.   B: TBitmap;
  138. begin
  139.   Jpg := TJpegImage.Create;
  140.   try
  141.     B := TBitmap.Create;
  142.     try
  143.       B.Assign(BioLifeGraphic);
  144.       Jpg.Assign(B);
  145.     finally
  146.       B.Free;
  147.     end;
  148.     S := TMemoryStream.Create;
  149.     Jpg.SaveToStream(S);
  150.     S.Position := 0;
  151.     Response.ContentType := 'image/jpeg';
  152.     Response.ContentStream := S; // do not free the stream because the response
  153.                                  // object will handle that task.
  154.   finally
  155.     Jpg.Free;
  156.   end;
  157. end;
  158.  
  159. procedure TCustomerInfoModule.CustomerInfoModuleBioLifeAction(
  160.   Sender: TObject; Request: TWebRequest; Response: TWebResponse;
  161.   var Handled: Boolean);
  162. begin
  163.   Response.Content := BioLifeProducer.Content;
  164. end;
  165.  
  166. procedure TCustomerInfoModule.BioLifeNotesGetText(Sender: TField;
  167.   var Text: String; DisplayText: Boolean);
  168. begin
  169.   Text := Sender.AsString;
  170. end;
  171.  
  172. procedure TCustomerInfoModule.CustomerInfoModulerootAction(Sender: TObject;
  173.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  174. begin
  175.   Response.Content := Root.Content;
  176. end;
  177.  
  178. procedure TCustomerInfoModule.RootHTMLTag(Sender: TObject; Tag: TTag;
  179.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  180. begin
  181.   if TagString = 'MODULENAME' then
  182.     ReplaceText := ScriptName;
  183. end;
  184.  
  185. end.
  186.