Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 22 - Project BrokApache

Project Structure

BrokApache.dpr
library BrokApache;

uses
  WebBroker,
  ApacheApp,
  BrokWm in 'BrokWm.pas' {WebModule1: TWebModule};

{$R *.res}

exports
  apache_module name 'brokdemo_module';

begin
  ContentType:= 'brokdemo-handler';

  Application.Initialize;
  Application.CreateForm(TWebModule1, WebModule1);
  Application.Run;
end.
BrokWm.pas
unit BrokWm;

interface

uses
  Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, DSProd,
  DBWeb, HTTPProd;

type
  TWebModule1 = class(TWebModule)
    Table1: TTable;
    Table1EmpNo: TIntegerField;
    Table1LastName: TStringField;
    Table1FirstName: TStringField;
    Table1PhoneExt: TStringField;
    Table1HireDate: TDateTimeField;
    Table1Salary: TFloatField;
    PageHead: TPageProducer;
    DataSetPage: TDataSetPageProducer;
    PageTail: TPageProducer;
    DataSetTableProducer1: TDataSetTableProducer;
    procedure TimeAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure DateAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure MenuAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure StatusAction(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    procedure RecordAction(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    procedure PageTailHTMLTag(Sender: TObject; Tag: TTag;
      const TagString: String; TagParams: TStrings;
      var ReplaceText: String);
    procedure DataSetTableProducer1FormatCell(Sender: TObject; CellRow,
      CellColumn: Integer; var BgColor: THTMLBgColor;
      var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
      CellData: String);
    procedure WebModule1AfterDispatch(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1WaTableAction(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  public
    { Public declarations }
  end;

var
  WebModule1: TWebModule1;

implementation

{$R *.DFM}

procedure TWebModule1.TimeAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := 'Time at this site: ' +
    FormatDateTime('hh:mm:ss AM/PM', Now) + '<p>';
end;

procedure TWebModule1.DateAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := 'Today is ' +
    FormatDateTime('dddd, mmmm d, yyyy', Now) + '<p>';
end;

procedure TWebModule1.MenuAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  I: Integer;
begin
  Response.Content := '<H3>Menu</H3><ul>'#13;
  for I := 0 to Actions.Count - 1 do
    Response.Content := Response.Content +
      '<li> <a href="' + Request.ScriptName +
      Action[I].PathInfo + '"> ' + Copy (Action[I].Name, 3, 1000) + '</a>'#13;
  Response.Content := Response.Content + '</ul>';
end;

procedure TWebModule1.StatusAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  I: Integer;
begin
  Response.Content := '<H3>Status</H3>'#13 +
    'Method: ' + Request.Method + '<br>'#13 +
    'ProtocolVersion: ' + Request.ProtocolVersion + '<br>'#13 +
    'URL: ' + Request.URL + '<br>'#13 +
    'Query: ' + Request.Query + '<br>'#13 +
    'PathInfo: ' + Request.PathInfo + '<br>'#13 +
    'PathTranslated: ' + Request.PathTranslated + '<br>'#13 +
    'Authorization: ' + Request.Authorization + '<br>'#13 +
    'CacheControl: ' + Request.CacheControl + '<br>'#13 +
    'Cookie: ' + Request.Cookie + '<br>'#13 +
    'Date: ' + DateTimeToStr (Request.Date) + '<br>'#13 +
    'Accept: ' + Request.Accept + '<br>'#13 +
    'From: ' + Request.From + '<br>'#13 +
    'Host: ' + Request.Host + '<br>'#13 +
    'IfModifiedSince: ' + DateTimeToStr (Request.IfModifiedSince) + '<br>'#13 +
    'Referer: ' + Request.Referer + '<br>'#13 +
    'UserAgent: ' + Request.UserAgent + '<br>'#13 +
    'ContentEncoding: ' + Request.ContentEncoding + '<br>'#13 +
    'ContentType: ' + Request.ContentType + '<br>'#13 +
    'ContentLength: ' + IntToStr (Request.ContentLength) + '<br>'#13 +
    'ContentVersion: ' + Request.ContentVersion + '<br>'#13 +
    'Content: ' + Request.Content + '<br>'#13 +
    'Connection: ' + Request.Connection + '<br>'#13 +
    'DerivedFrom: ' + Request.DerivedFrom + '<br>'#13 +
    'Expires: ' + DateTimeToStr (Request.Expires) + '<br>'#13 +
    'Title: ' + Request.Title + '<br>'#13 +
    'RemoteAddr: ' + Request.RemoteAddr + '<br>'#13 +
    'RemoteHost: ' + Request.RemoteHost + '<br>'#13 +
    'ScriptName: ' + Request.ScriptName + '<br>'#13 +
    'ServerPort: ' + IntToStr (Request.ServerPort) + '<br>'#13;
  // list of strings
  Response.Content := Response.Content +
    'ContentFields:<ul>'#13;
  for I := 0 to Request.ContentFields.Count - 1 do
    Response.Content := Response.Content +
      '<li>' + Request.ContentFields [I]+ #13;
  Response.Content := Response.Content +
    '</ul>CookieFields:<ul>'#13;
  for I := 0 to Request.CookieFields.Count - 1 do
    Response.Content := Response.Content +
      '<li>' + Request.CookieFields [I] + #13;
  Response.Content := Response.Content +
    '</ul>QueryFields:<ul>'#13;
  for I := 0 to Request.QueryFields.Count - 1 do
    Response.Content := Response.Content +
      '<li>' + Request.QueryFields [I] + #13;
end;

procedure TWebModule1.RecordAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Table1.Open;
  // go to the requested record
  Table1.FindNearest ([Request.QueryFields.Values['LastName'],
    Request.QueryFields.Values['FirstName']]);
  // get the output
  Response.Content := DataSetPage.Content;
end;

procedure TWebModule1.PageTailHTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
begin
  if TagString = 'script' then
    ReplaceText := Request.ScriptName;
end;

procedure TWebModule1.DataSetTableProducer1FormatCell(Sender: TObject;
  CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  CellData: String);
begin
  if (CellColumn = 0) and (CellRow <> 0) then
    CellData := '<a href="' + Request.ScriptName + '/record?LastName=' +
      Table1['LastName'] + '&FirstName=' + Table1 ['FirstName'] + '"> '
      + CellData + ' </a>';
end;

procedure TWebModule1.WebModule1AfterDispatch(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := PageHead.Content +
    Response.Content + PageTail.Content;
end;

procedure TWebModule1.WebModule1WaTableAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Table1.Open;
  Table1.First;
end;

end.
BrokWm.dfm
object WebModule1: TWebModule1
  OldCreateOrder = True
  Actions = <
    item
      Name = 'WaTime'
      PathInfo = '/time'
      OnAction = TimeAction
    end
    item
      Name = 'WaDate'
      PathInfo = '/date'
      OnAction = DateAction
    end
    item
      Default = True
      Name = 'WaMenu'
      PathInfo = '/menu'
      OnAction = MenuAction
    end
    item
      Name = 'WaStatus'
      PathInfo = '/status'
      OnAction = StatusAction
    end
    item
      Name = 'WaTable'
      PathInfo = '/table'
      Producer = DataSetTableProducer1
      OnAction = WebModule1WaTableAction
    end
    item
      Name = 'WaRecord'
      PathInfo = '/record'
      Producer = DataSetPage
      OnAction = RecordAction
    end>
  AfterDispatch = WebModule1AfterDispatch
  Left = 278
  Top = 272
  Height = 392
  Width = 726
  object Table1: TTable
    DatabaseName = 'DBDEMOS'
    IndexName = 'ByName'
    TableName = 'EMPLOYEE.DB'
    Left = 48
    Top = 24
    object Table1EmpNo: TIntegerField
      FieldName = 'EmpNo'
    end
    object Table1LastName: TStringField
      FieldName = 'LastName'
    end
    object Table1FirstName: TStringField
      FieldName = 'FirstName'
      Size = 15
    end
    object Table1PhoneExt: TStringField
      FieldName = 'PhoneExt'
      Size = 4
    end
    object Table1HireDate: TDateTimeField
      FieldName = 'HireDate'
    end
    object Table1Salary: TFloatField
      FieldName = 'Salary'
    end
  end
  object PageHead: TPageProducer
    HTMLDoc.Strings = (
      '<HTML><HEAD>'
      '<TITLE>WebBroker Demo</TITLE>'
      '</HEAD>'
      '<BODY>'
      '<H1>Web Broker Demo</H1>')
    Left = 110
    Top = 25
  end
  object DataSetPage: TDataSetPageProducer
    HTMLDoc.Strings = (
      '<H3>Employee: <#LastName></H3>'
      '<ul>'
      '<li> Employee ID: <#EmpNo>'
      '<li> Name: <#FirstName> <#LastName>'
      '<li> Phone: <#PhoneExt>'
      '<li> Hired On: <#HireDate>'
      '<li> Salary: <#Salary>'
      '</ul>')
    DataSet = Table1
    OnHTMLTag = PageTailHTMLTag
    Left = 168
    Top = 80
  end
  object PageTail: TPageProducer
    HTMLDoc.Strings = (
      '<hr><I>Page generated by <#script></I>'
      '</BODY>'
      '</HTML>')
    OnHTMLTag = PageTailHTMLTag
    Left = 168
    Top = 27
  end
  object DataSetTableProducer1: TDataSetTableProducer
    Columns = <
      item
        FieldName = 'EmpNo'
      end
      item
        FieldName = 'LastName'
      end
      item
        FieldName = 'FirstName'
      end
      item
        FieldName = 'PhoneExt'
      end
      item
        FieldName = 'HireDate'
      end
      item
        FieldName = 'Salary'
      end>
    MaxRows = -1
    DataSet = Table1
    TableAttributes.Border = 1
    TableAttributes.CellSpacing = 0
    TableAttributes.CellPadding = 4
    OnFormatCell = DataSetTableProducer1FormatCell
    Left = 104
    Top = 80
  end
end