
{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       Web server application components               }
{                                                       }
{       Copyright (c) 1997,98 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit HTTPApp;

interface

uses SyncObjs, SysUtils, Classes, Forms, Masks;

const
  sDateFormat = '"%s", dd "%s" yyyy hh:mm:ss';

  MAX_STRINGS = 12;
  MAX_INTEGERS = 1;
  MAX_DATETIMES = 3;

type
  TMethodType = (mtAny, mtGet, mtPut, mtPost, mtHead);

{ Forward declaration }

  TWebResponse = class;

{ TWebRequest }

  TWebRequest = class(TObject)
  private
    FMethodType: TMethodType;
    FContentFields,
    FCookieFields,
    FQueryFields: TStrings;
    function GetContentFields: TStrings;
    function GetCookieFields: TStrings;
    function GetQueryFields: TStrings;
  protected
    function GetStringVariable(Index: Integer): string; virtual; abstract;
    function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
    function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  public
    constructor Create;
    destructor Destroy; override;
    // Read count bytes from client
    function ReadClient(var Buffer; Count: Integer): Integer; virtual; abstract;
    // Read count characters as a string from client
    function ReadString(Count: Integer): string; virtual; abstract;
    // Translate a relative URI to a local absolute path
    function TranslateURI(const URI: string): string; virtual; abstract;
    // Write count bytes back to client
    function WriteClient(var Buffer; Count: Integer): Integer; virtual; abstract;
    // Write string contents back to client
    function WriteString(const AString: string): Boolean; virtual; abstract;
    // Utility to extract fields from a given string buffer
    procedure ExtractFields(Separators, WhiteSpace: TSysCharSet;
      Content: PChar; Strings: TStrings);
    // Fills the given string list with the content fields as the result
    // of a POST method
    procedure ExtractContentFields(Strings: TStrings);
    // Fills the given string list with values from the cookie header field
    procedure ExtractCookieFields(Strings: TStrings);
    // Fills the given TStrings with the values from the Query data
    // (ie: data following the "?" in the URL)
    procedure ExtractQueryFields(Strings: TStrings);
    // Read an arbitrary HTTP/Server Field not lists here
    function GetFieldByName(const Name: string): string; virtual; abstract;
    // The request method as an enumeration
    property MethodType: TMethodType read FMethodType;
    // Field lists
    property ContentFields: TStrings read GetContentFields;
    property CookieFields: TStrings read GetCookieFields;
    property QueryFields: TStrings read GetQueryFields;
    // HTTP header Fields
    property Method: string index 0 read GetStringVariable;
    property ProtocolVersion: string index 1 read GetStringVariable;
    property URL: string index 2 read GetStringVariable;
    property Query: string index 3 read GetStringVariable;
    property PathInfo: string index 4 read GetStringVariable;
    property PathTranslated: string index 5 read GetStringVariable;
    property Authorization: string index 28 read GetStringVariable;
    property CacheControl: string index 6 read GetStringVariable;
    property Cookie: string index 27 read GetStringVariable;
    property Date: TDateTime index 7 read GetDateVariable;
    property Accept: string index 8 read GetStringVariable;
    property From: string index 9 read GetStringVariable;
    property Host: string index 10 read GetStringVariable;
    property IfModifiedSince: TDateTime index 11 read GetDateVariable;
    property Referer: string index 12 read GetStringVariable;
    property UserAgent: string index 13 read GetStringVariable;
    property ContentEncoding: string index 14 read GetStringVariable;
    property ContentType: string index 15 read GetStringVariable;
    property ContentLength: Integer index 16 read GetIntegerVariable;
    property ContentVersion: string index 17 read GetStringVariable;
    property Content: string index 25 read GetStringVariable;
    property Connection: string index 26 read GetStringVariable;
    property DerivedFrom: string index 18 read GetStringVariable;
    property Expires: TDateTime index 19 read GetDateVariable;
    property Title: string index 20 read GetStringVariable;
    property RemoteAddr: string index 21 read GetStringVariable;
    property RemoteHost: string index 22 read GetStringVariable;
    property ScriptName: string index 23 read GetStringVariable;
    property ServerPort: Integer index 24 read GetIntegerVariable;
  end;

{ TCookie }

  TCookie = class(TCollectionItem)
  private
    FName: string;
    FValue: string;
    FPath: string;
    FDomain: string;
    FExpires: TDateTime;
    FSecure: Boolean;
  protected
    function GetHeaderValue: string;
  public
    constructor Create(Collection: TCollection); override;
    procedure AssignTo(Dest: TPersistent); override;
    property Name: string read FName write FName;
    property Value: string read FValue write FValue;
    property Domain: string read FDomain write FDomain;
    property Path: string read FPath write FPath;
    property Expires: TDateTime read FExpires write FExpires;
    property Secure: Boolean read FSecure write FSecure;
    property HeaderValue: string read GetHeaderValue;
  end;

{ TCookieCollection }

  TCookieCollection = class(TCollection)
  private
    FWebResponse: TWebResponse;
  protected
    function GetCookie(Index: Integer): TCookie;
    procedure SetCookie(Index: Integer; Cookie: TCookie);
  public
    constructor Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
    function  Add: TCookie;
    property WebResponse: TWebResponse read FWebResponse;
    property Items[Index: Integer]: TCookie read GetCookie write SetCookie; default;
  end;

{ TWebResponse }

  TWebResponse = class(TObject)
  private
    FContentStream: TStream;
    FCustomHeaders: TStrings;
    FCookies: TCookieCollection;
    procedure SetCustomHeaders(Value: TStrings);
  protected
    FHTTPRequest: TWebRequest;
    procedure AddCustomHeaders(var Headers: string);
    function GetStringVariable(Index: Integer): string; virtual; abstract;
    procedure SetStringVariable(Index: Integer; const Value: string); virtual; abstract;
    function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
    procedure SetDateVariable(Index: Integer; const Value: TDateTime); virtual; abstract;
    function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
    procedure SetIntegerVariable(Index: Integer; Value: Integer); virtual; abstract;
    function GetContent: string; virtual; abstract;
    procedure SetContent(const Value: string); virtual; abstract;
    procedure SetContentStream(Value: TStream); virtual;
    function GetStatusCode: Integer; virtual; abstract;
    procedure SetStatusCode(Value: Integer); virtual; abstract;
    function GetLogMessage: string; virtual; abstract;
    procedure SetLogMessage(const Value: string); virtual; abstract;
  public
    constructor Create(HTTPRequest: TWebRequest);
    destructor Destroy; override;
    function GetCustomHeader(const Name: string): String;
    procedure SendResponse; virtual; abstract;
    procedure SendRedirect(const URI: string); virtual; abstract;
    procedure SendStream(AStream: TStream); virtual; abstract;
    function Sent: Boolean; virtual;
    procedure SetCookieField(Values: TStrings; const ADomain, APath: string;
      AExpires: TDateTime; ASecure: Boolean);
    procedure SetCustomHeader(const Name, Value: string);
    property Cookies: TCookieCollection read FCookies;
    property HTTPRequest: TWebRequest read FHTTPRequest;
    property Version: string index 0 read GetStringVariable write SetStringVariable;
    property ReasonString: string index 1 read GetStringVariable write SetStringVariable;
    property Server: string index 2 read GetStringVariable write SetStringVariable;
    property WWWAuthenticate: string index 3 read GetStringVariable write SetStringVariable;
    property Realm: string index 4 read GetStringVariable write SetStringVariable;
    property Allow: string index 5 read GetStringVariable write SetStringVariable;
    property Location: string index 6 read GetStringVariable write SetStringVariable;
    property ContentEncoding: string index 7 read GetStringVariable write SetStringVariable;
    property ContentType: string index 8 read GetStringVariable write SetStringVariable;
    property ContentVersion: string index 9 read GetStringVariable write SetStringVariable;
    property DerivedFrom: string index 10 read GetStringVariable write SetStringVariable;
    property Title: string index 11 read GetStringVariable write SetStringVariable;

    property StatusCode: Integer read GetStatusCode write SetStatusCode;
    property ContentLength: Integer index 0 read GetIntegerVariable write SetIntegerVariable;

    property Date: TDateTime index 0 read GetDateVariable write SetDateVariable;
    property Expires: TDateTime index 1 read GetDateVariable write SetDateVariable;
    property LastModified: TDateTime index 2 read GetDateVariable write SetDateVariable;

    property Content: string read GetContent write SetContent;
    property ContentStream: TStream read FContentStream write SetContentStream;

    property LogMessage: string read GetLogMessage write SetLogMessage;

    property CustomHeaders: TStrings read FCustomHeaders write SetCustomHeaders;
  end;

{ TWebDispatcherEditor }

  TCustomWebDispatcher = class;
  TCustomContentProducer = class;

{ THTMLTagAttributes }

  THTMLAlign = (haDefault, haLeft, haRight, haCenter);
  THTMLVAlign = (haVDefault, haTop, haMiddle, haBottom, haBaseline);
  THTMLBgColor = type string;

  THTMLTagAttributes = class(TPersistent)
  private
    FProducer: TCustomContentProducer;
    FCustom: string;
    FOnChange: TNotifyEvent;
    procedure SetCustom(const Value: string);
  protected
    procedure Changed;
  public
    constructor Create(Producer: TCustomContentProducer);
    procedure RestoreDefaults; virtual;
    property Producer: TCustomContentProducer read FProducer;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property Custom: string read FCustom write SetCustom;
  end;

  THTMLTableAttributes = class(THTMLTagAttributes)
  private
    FAlign: THTMLAlign;
    FBorder: Integer;
    FBgColor: THTMLBgColor;
    FCellSpacing: Integer;
    FCellPadding: Integer;
    FWidth: Integer;
    procedure SetAlign(Value: THTMLAlign);
    procedure SetBorder(Value: Integer);
    procedure SetBGColor(Value: THTMLBgColor);
    procedure SetCellSpacing(Value: Integer);
    procedure SetCellPadding(Value: Integer);
    procedure SetWidth(Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Producer: TCustomContentProducer);
    procedure RestoreDefaults; override;
  published
    property Align: THTMLAlign read FAlign write SetAlign default haDefault;
    property BgColor: THTMLBgColor read FBgColor write SetBgColor;
    property Border: Integer read FBorder write SetBorder default -1;
    property CellSpacing: Integer read FCellSpacing write SetCellSpacing default -1;
    property CellPadding: Integer read FCellPadding write SetCellPAdding default -1;
    property Width: Integer read FWidth write SetWidth default 100;
  end;

  THTMLTableElementAttributes = class(THTMLTagAttributes)
  private
    FAlign: THTMLAlign;
    FBgColor: THTMLBgColor;
    FVAlign: THTMLVAlign;
    procedure SetAlign(Value: THTMLAlign);
    procedure SetBGColor(Value: THTMLBgColor);
    procedure SetVAlign(Value: THTMLVAlign);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public  
    procedure RestoreDefaults; override;
  published
    property Align: THTMLAlign read FAlign write SetAlign default haDefault;
    property BgColor: THTMLBgColor read FBgColor write SetBgColor;
    property VAlign: THTMLVAlign read FVAlign write SetVAlign default haVDefault;
  end;

  THTMLTableHeaderAttributes = class(THTMLTableElementAttributes)
  private
    FCaption: string;
    procedure SetCaption(Value: string);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    procedure RestoreDefaults; override;
  published
    property Caption: string read FCaption write SetCaption;
  end;

  THTMLTableRowAttributes = class(THTMLTableElementAttributes);
  THTMLTableCellAttributes = class(THTMLTableElementAttributes);

{ TCustomContentProducer }

  TCustomContentProducer = class(TComponent)
  private
    FDispatcher: TCustomWebDispatcher;
    procedure SetDispatcher(Value: TCustomWebDispatcher);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    function Content: string; virtual;
    function ContentFromStream(Stream: TStream): string; virtual;
    function ContentFromString(const S: string): string; virtual;
  published
    property Dispatcher: TCustomWebDispatcher read FDispatcher
      write SetDispatcher stored False;
  end;

{ TCustomHTTPPageProducer }

  TCustomPageProducer = class(TCustomContentProducer)
  private
    FHTMLFile: TFileName;
    FHTMLDoc: TStrings;
    procedure SetHTMLFile(const Value: TFileName);
    procedure SetHTMLDoc(Value: TStrings);
  protected
    function HandleTag(const TagString: string; TagParams: TStrings): string; virtual;
    property HTMLDoc: TStrings read FHTMLDoc write SetHTMLDoc;
    property HTMLFile: TFileName read FHTMLFile write SetHTMLFile;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Content: string; override;
    function ContentFromStream(Stream: TStream): string; override;
    function ContentFromString(const S: string): string; override;
  end;

{ TPageProducer }

  TTag = (tgCustom, tgLink, tgImage, tgTable, tgImageMap, tgObject, tgEmbed);

  THTMLTagEvent = procedure (Sender: TObject; Tag: TTag; const TagString: string;
    TagParams: TStrings; var ReplaceText: string) of object;

  TPageProducer = class(TCustomPageProducer)
  private
    FOnHTMLTag: THTMLTagEvent;
  protected
    function HandleTag(const TagString: string; TagParams: TStrings): string; override;
    procedure DoTagEvent(Tag: TTag; const TagString: string; TagParams: TStrings;
      var ReplaceText: string); dynamic;
  published
    property HTMLDoc;
    property HTMLFile;
    property OnHTMLTag: THTMLTagEvent read FOnHTMLTag write FOnHTMLTag;
  end;

{ TWebActionItem }

  THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest;
    Response: TWebResponse; var Handled: Boolean) of object;

  TWebActionItem = class(TCollectionItem)
  private
    FOnAction: THTTPMethodEvent;
    FPathInfo: string;
    FMethodType: TMethodType;
    FDefault: Boolean;
    FEnabled: Boolean;
    FMask: TMask;
    FName: string;
    function DispatchAction(Request: TWebRequest; Response: TWebResponse;
      DoDefault: Boolean): Boolean;
    function GetDisplayName: string; override;
    procedure SetDefault(Value: Boolean);
    procedure SetEnabled(Value: Boolean);
    procedure SetMethodType(Value: TMethodType);
    procedure SetDisplayName(const Value: string); override;
    procedure SetOnAction(Value: THTTPMethodEvent);
    procedure SetPathInfo(const Value: string);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure AssignTo(Dest: TPersistent); override;
  published
    property Default: Boolean read FDefault write SetDefault default False;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property MethodType: TMethodType read FMethodType write SetMethodType default mtAny;
    property Name: string read GetDisplayName write SetDisplayName;
    property PathInfo: string read FPathInfo write SetPathInfo;
    property OnAction: THTTPMethodEvent read FOnAction write SetOnAction;
  end;

{ TWebActionItems }

  TWebActionItems = class(TCollection)
  private
    FWebDispatcher: TCustomWebDispatcher;
    function GetActionItem(Index: Integer): TWebActionItem;
    procedure SetActionItem(Index: Integer; Value: TWebActionItem);
  protected
    function GetAttrCount: Integer; override;
    function GetAttr(Index: Integer): string; override;
    function GetItemAttr(Index, ItemIndex: Integer): string; override;
    function GetOwner: TPersistent; override;
    procedure SetItemName(Item: TCollectionItem); override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(WebDispatcher: TCustomWebDispatcher;
      ItemClass: TCollectionItemClass);
    function  Add: TWebActionItem;
    property WebDispatcher: TCustomWebDispatcher read FWebDispatcher;
    property Items[Index: Integer]: TWebActionItem read GetActionItem
      write SetActionItem; default;
  end;

{ TCustomWebDispatcher }

  TCustomWebDispatcher = class(TDataModule)
  private
    FRequest: TWebRequest;
    FResponse: TWebResponse;
    FActions: TWebActionItems;
    FBeforeDispatch: THTTPMethodEvent;
    FAfterDispatch: THTTPMethodEvent;
    function GetAction(Index: Integer): TWebActionItem;
    procedure SetActions(Value: TWebActionItems);
  protected
    function DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
    function DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
    function DispatchAction(Request: TWebRequest;
      Response: TWebResponse): Boolean;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property BeforeDispatch: THTTPMethodEvent read FBeforeDispatch write FBeforeDispatch;
    property AfterDispatch: THTTPMethodEvent read FAfterDispatch write FAfterDispatch;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ActionByName(const AName: string): TWebActionItem;
    property Actions: TWebActionItems read FActions write SetActions;
    property Action[Index: Integer]: TWebActionItem read GetAction;
    property Request: TWebRequest read FRequest;
    property Response: TWebResponse read FResponse;
  end;

{ TWebDispatcher }

  TWebDispatcher = class(TCustomWebDispatcher)
  published
    property Actions;
    property BeforeDispatch;
    property AfterDispatch;
  end;

{ TWebModule }

  TWebModule = class(TCustomWebDispatcher)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Actions;
    property BeforeDispatch;
    property AfterDispatch;
  end;

  TWebApplication = class(TComponent)
  private
    FWebModuleClass: TComponentClass;
    FCriticalSection: TCriticalSection;
    FUniqueNumbers: TBits;
    FActiveWebModules: TList;
    FInactiveWebModules: TList;
    FTitle: string;
    FMaxConnections: Integer;
    FCacheConnections: Boolean;
    function GetActiveCount: Integer;
    function GetInactiveCount: Integer;
    procedure SetCacheConnections(Value: Boolean);
    procedure OnExceptionHandler(Sender: TObject; E: Exception);
  protected
    function ActivateWebModule: TDataModule;
    procedure DeactivateWebModule(DataModule: TDataModule);
    procedure DoHandleException(E: Exception); dynamic;
    function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // The following is uses the current behaviour of the IDE module manager
    procedure CreateForm(InstanceClass: TComponentClass; var Reference); virtual;
    procedure Initialize; virtual;
    procedure Run; virtual;
    property ActiveCount: Integer read GetActiveCount;
    property CacheConnections: Boolean read FCacheConnections write SetCacheConnections;
    property InactiveCount: Integer read GetInactiveCount;
    property MaxConnections: Integer read FMaxConnections write FMaxConnections;
    property Title: string read FTitle write FTitle;
  end;

function DosPathToUnixPath(const Path: string): string;
function HTTPDecode(const AStr: String): string;
function HTTPEncode(const AStr: String): string;
function ParseDate(const DateStr: string): TDateTime;
procedure ExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings);
procedure ExtractHeaderFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings; Decode: Boolean);
function StatusString(StatusCode: Integer): string;
function UnixPathToDosPath(const Path: string): string;
function MonthStr(DateTime: TDateTime): string;
function DayOfWeekStr(DateTime: TDateTime): string;

var
  Application: TWebApplication = nil;

implementation

uses Windows, CopyPrsr, WebConst;

{ TWebRequest }

constructor TWebRequest.Create;
begin
  inherited Create;
  if CompareText(Method, 'GET') = 0 then
    FMethodType := mtGet
  else if CompareText(Method, 'PUT') = 0 then
    FMethodType := mtPut
  else if CompareText(Method, 'POST') = 0 then
    FMethodType := mtPost
  else if CompareText(Method, 'HEAD') = 0 then
    FMethodType := mtHead;
end;

destructor TWebRequest.Destroy;
begin
  FContentFields.Free;
  FCookieFields.Free;
  FQueryFields.Free;
  inherited Destroy;
end;

procedure TWebRequest.ExtractFields(Separators, WhiteSpace: TSysCharSet;
  Content: PChar; Strings: TStrings);
begin
  ExtractHTTPFields(Separators, WhiteSpace, Content, Strings);
end;

procedure TWebRequest.ExtractContentFields(Strings: TStrings);
var
  ContentStr: string;
begin
  if ContentLength > 0 then
  begin
    ContentStr := Content;
    if Length(ContentStr) < ContentLength then
      ContentStr := ContentStr + ReadString(ContentLength - Length(ContentStr));
    ExtractFields(['&'], [], PChar(ContentStr), Strings);
  end;
end;

procedure TWebRequest.ExtractCookieFields(Strings: TStrings);
var
  CookieStr: string;
begin
  CookieStr := Cookie;
  ExtractHeaderFields([';'], [' '], PChar(CookieStr), Strings, False);
end;

procedure TWebRequest.ExtractQueryFields(Strings: TStrings);
var
  ContentStr: string;
begin
  ContentStr := Query;
  ExtractFields(['&'], [], PChar(ContentStr), Strings);
end;

function TWebRequest.GetContentFields: TStrings;
begin
  if FContentFields = nil then
  begin
    FContentFields := TStringList.Create;
    ExtractContentFields(FContentFields);
  end;
  Result := FContentFields;
end;

function TWebRequest.GetCookieFields: TStrings;
begin
  if FCookieFields = nil then
  begin
    FCookieFields := TStringList.Create;
    ExtractCookieFields(FCookieFields);
  end;
  Result := FCookieFields;
end;

function TWebRequest.GetQueryFields: TStrings;
begin
  if FQueryFields = nil then
  begin
    FQueryFields := TStringList.Create;
    ExtractQueryFields(FQueryFields);
  end;
  Result := FQueryFields;
end;

{ TCookie }

constructor TCookie.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FExpires := -1;
end;

procedure TCookie.AssignTo(Dest: TPersistent);
begin
  if Dest is TCookie then
    with TCookie(Dest) do
    begin
      Name := Self.FName;
      Value := Self.FValue;
      Domain := Self.FDomain;
      Path := Self.FPath;
      Expires := Self.FExpires;
      Secure := Self.FSecure;
    end else inherited AssignTo(Dest);
end;

function TCookie.GetHeaderValue: string;
begin
  Result := Format('%s=%s; ', [FName, FValue]);
  if Domain <> '' then
    Result := Result + Format('domain=%s; ', [Domain]);
  if Path <> '' then
    Result := Result + Format('path=%s; ', [Path]);
  if Expires > -1 then
    Result := Result +
      Format(FormatDateTime('"expires="' + sDateFormat + ' "GMT; "', Expires),
        [DayOfWeekStr(Expires), MonthStr(Expires)]);
  if Secure then Result := Result + 'secure';
  if Copy(Result, Length(Result) - 2, MaxInt) = '; ' then
    SetLength(Result, Length(Result) - 2);
end;

{ TCookieCollection }

constructor TCookieCollection.Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
begin
  inherited Create(ItemClass);
  FWebResponse := WebResponse;
end;

function TCookieCollection.Add: TCookie;
begin
  Result := TCookie(inherited Add);
end;

function TCookieCollection.GetCookie(Index: Integer): TCookie;
begin
  Result := TCookie(inherited Items[Index]);
end;

procedure TCookieCollection.SetCookie(Index: Integer; Cookie: TCookie);
begin
  Items[Index].Assign(Cookie);
end;

{ TWebResponse }

constructor TWebResponse.Create(HTTPRequest: TWebRequest);
begin
  inherited Create;
  FHTTPRequest := HTTPRequest;
  FCustomHeaders := TStringList.Create;
  FCookies := TCookieCollection.Create(Self, TCookie);
end;

destructor TWebResponse.Destroy;
begin
  FContentStream.Free;
  FCustomHeaders.Free;
  FCookies.Free;
  inherited Destroy;
end;

procedure TWebResponse.AddCustomHeaders(var Headers: string);
var
  I: Integer;
  Name, Value: string;
begin
  for I := 0 to FCustomHeaders.Count - 1 do
  begin
    Name := FCustomHeaders.Names[I];
    Value := FCustomHeaders.values[Name];
    Headers := Headers + Name + ': ' + Value + #13#10;
  end;
end;

function TWebResponse.GetCustomHeader(const Name: string): string;
begin
  Result := FCustomHeaders.Values[Name];
end;

function TWebResponse.Sent: Boolean;
begin
  Result := False;
end;

procedure TWebResponse.SetContentStream(Value: TStream);
begin
  if Value <> FContentStream then
  begin
    FContentStream.Free;
    FContentStream := Value;
    if FContentStream <> nil then
      ContentLength := FContentStream.Size;
  end;
end;

procedure TWebResponse.SetCookieField(Values: TStrings; const ADomain,
  APath: string; AExpires: TDateTime; ASecure: Boolean);
var
  I: Integer;
begin
  for I := 0 to Values.Count - 1 do
    with Cookies.Add do
    begin
      Name := Values.Names[I];
      Value := Values.Values[Values.Names[I]];
      Domain := ADomain;
      Path := APath;
      Expires := AExpires;
      Secure := ASecure;
    end;
end;

procedure TWebResponse.SetCustomHeader(const Name, Value: string);
begin
  FCustomHeaders.Values[Name] := Value;
end;

procedure TWebResponse.SetCustomHeaders(Value: TStrings);
begin
  FCustomHeaders.Assign(Value);
end;

{ THTMLTagAttributes }

constructor THTMLTagAttributes.Create(Producer: TCustomContentProducer);
begin
  inherited Create;
  FProducer := Producer;
end;

procedure THTMLTagAttributes.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure THTMLTagAttributes.RestoreDefaults;
begin
  FCustom := '';
  Changed;
end;

procedure THTMLTagAttributes.SetCustom(const Value: string);
begin
  if Value <> FCustom then
  begin
    FCustom := Value;
    Changed;
  end;
end;

{ THTMLTableAttributes }

constructor THTMLTableAttributes.Create(Producer: TCustomContentProducer);
begin
  inherited Create(Producer);
  FWidth := 100;
  FBorder := -1;
  FCellPadding := -1;
  FCellSpacing := -1;
end;

procedure THTMLTableAttributes.AssignTo(Dest: TPersistent);
begin
  if Dest is THTMLTableAttributes then
    with THTMLTableAttributes(Dest) do
    begin
      FWidth := Self.FWidth;
      FAlign := Self.FAlign;
      FBorder := Self.FBorder;
      FBgColor := Self.FBgColor;
      FCellSpacing := Self.FCellSpacing;
      FCellPadding := Self.FCellPadding;
      Changed;
    end else inherited AssignTo(Dest);
end;

procedure THTMLTableAttributes.RestoreDefaults;
begin
  FCustom := '';
  FAlign := haDefault;
  FWidth := 100;
  FBorder := -1;
  FCellPadding := -1;
  FCellSpacing := -1;
  Changed;
end;

procedure THTMLTableAttributes.SetAlign(Value: THTMLAlign);
begin
  if Value <> FAlign then
  begin
    FAlign := Value;
    Changed;
  end;
end;

procedure THTMLTableAttributes.SetBorder(Value: Integer);
begin
  if Value <> FBorder then
  begin
    FBorder := Value;
    Changed;
  end;
end;

procedure THTMLTableAttributes.SetBGColor(Value: THTMLBgColor);
begin
  if Value <> FBgColor then
  begin
    FBgColor := Value;
    Changed;
  end;
end;

procedure THTMLTableAttributes.SetCellSpacing(Value: Integer);
begin
  if Value <> FCellSpacing then
  begin
    FCellSpacing := Value;
    Changed;
  end;
end;

procedure THTMLTableAttributes.SetCellPadding(Value: Integer);
begin
  if Value <> FCellPadding then
  begin
    FCellPadding := Value;
    Changed;
  end;
end;

procedure THTMLTableAttributes.SetWidth(Value: Integer);
begin
  if Value <> FWidth then
  begin
    FWidth := Value;
    Changed;
  end;
end;

{ THTMLTableElementAttributes }

procedure THTMLTableElementAttributes.AssignTo(Dest: TPersistent);
begin
  if Dest is THTMLTableElementAttributes then
    with THTMLTableElementAttributes(Dest) do
    begin
      FAlign := Self.FAlign;
      FVAlign := Self.FVAlign;
      FBgColor := Self.FBgColor;
      Changed;
    end else inherited AssignTo(Dest);
end;

procedure THTMLTableElementAttributes.RestoreDefaults;
begin
  FCustom := '';
  FAlign := haDefault;
  FVAlign := haVDefault;
  FBgColor := '';
  Changed;
end;

procedure THTMLTableElementAttributes.SetAlign(Value: THTMLAlign);
begin
  if Value <> FAlign then
  begin
    FAlign := Value;
    Changed;
  end;
end;

procedure THTMLTableElementAttributes.SetBGColor(Value: THTMLBgColor);
begin
  if Value <> FBgColor then
  begin
    FBgColor := Value;
    Changed;
  end;
end;

procedure THTMLTableElementAttributes.SetVAlign(Value: THTMLVAlign);
begin
  if Value <> FVAlign then
  begin
    FVAlign := Value;
    Changed;
  end;
end;

{ THTMLTableHeaderAttributes }

procedure THTMLTableHeaderAttributes.AssignTo(Dest: TPersistent);
begin
  if Dest is THTMLTableHeaderAttributes then
    with THTMLTableHeaderAttributes(Dest) do
    begin
      FAlign := Self.FAlign;
      FVAlign := Self.FVAlign;
      FBgColor := Self.FBgColor;
      FCaption := Self.FCaption;
      Changed;
    end else inherited AssignTo(Dest);
end;

procedure THTMLTableHeaderAttributes.RestoreDefaults;
begin
  FCustom := '';
  FAlign := haDefault;
  FVAlign := haVDefault;
  FBgColor := '';
  FCaption := '';
  Changed;
end;

procedure THTMLTableHeaderAttributes.SetCaption(Value: string);
begin
  if AnsiCompareStr(Value, FCaption) <> 0 then
  begin
    FCaption := Value;
    Changed;
  end;
end;

{ TCustomHTMLProducer }

procedure TCustomContentProducer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FDispatcher) then
    FDispatcher := nil;
end;

procedure TCustomContentProducer.SetDispatcher(Value: TCustomWebDispatcher);
begin
  if FDispatcher <> Value then
  begin
    if Value <> nil then Value.FreeNotification(Self);
    FDispatcher := Value;
  end;
end;

function TCustomContentProducer.Content: string;
begin
  Result := '';
end;

function TCustomContentProducer.ContentFromStream(Stream: TStream): string;
begin
  Result := Content;
end;

function TCustomContentProducer.ContentFromString(const S: string): string;
begin
  Result := Content;
end;

{ TCustomPageProducer }

constructor TCustomPageProducer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  RPR;
  FHTMLDoc := TStringList.Create;
end;

destructor TCustomPageProducer.Destroy;
begin
  FHTMLDoc.Free;
  inherited Destroy;
end;

function TCustomPageProducer.Content: string;
var
  InStream: TStream;
begin
  Result := '';
  if FHTMLFile <> '' then
    InStream := TFileStream.Create(FHTMLFile, fmOpenRead + fmShareDenyWrite)
  else InStream := TStringStream.Create(FHTMLDoc.Text);
  if InStream <> nil then
  try
    Result := ContentFromStream(InStream);
  finally
    InStream.Free;
  end;
end;

function TCustomPageProducer.ContentFromStream(Stream: TStream): string;
var
  Parser: TCopyParser;
  OutStream: TStringStream;
  ParamStr, ReplaceStr, TokenStr: string;
  ParamList: TStringList;
begin
  OutStream := TStringStream.Create('');
  try
    Parser := TCopyParser.Create(Stream, OutStream);
    with Parser do
    try
      while True do
      begin
        while not (Token in [toEof, '<']) do
        begin
          CopyTokenToOutput;
          SkipToken(True);
        end;
        if Token = toEOF then Break;
        if Token = '<' then
        begin
          if SkipToken(False) = '#' then
          begin
            SkipToken(False);
            TokenStr := TokenString;
            ParamStr := TrimLeft(TrimRight(SkipToToken('>')));
            ParamList := TStringList.Create;
            try
              ExtractHTTPFields([' '], [' '], PChar(ParamStr), ParamList);
              ReplaceStr := HandleTag(TokenStr, ParamList);
              OutStream.WriteString(ReplaceStr);
            finally
              ParamList.Free;
            end;
            SkipToken(True);
          end else
          begin
            OutStream.WriteString('<');
            CopyTokenToOutput;
            SkipToken(True);
          end;
        end;
      end;
    finally
      Parser.Free;
    end;
    Result := OutStream.DataString;
  finally
    OutStream.Free;
  end;
end;

function TCustomPageProducer.ContentFromString(const S: string): string;
var
  InStream: TStream;
begin
  InStream := TStringStream.Create(S);
  try
    Result := ContentFromStream(InStream);
  finally
    InStream.Free;
  end;
end;

function TCustomPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
begin
  Result := Format('<#%s>', [TagString]);
end;

procedure TCustomPageProducer.SetHTMLFile(const Value: TFileName);
begin
  if CompareText(FHTMLFile, Value) <> 0 then
  begin
    FHTMLDoc.Clear;
    FHTMLFile := Value;
  end;
end;

procedure TCustomPageProducer.SetHTMLDoc(Value: TStrings);
begin
  FHTMLDoc.Assign(Value);
  FHTMLFile := '';
end;

{ TPageProducer }

var
  TagSymbols: array[TTag] of string =
    ('', 'LINK', 'IMAGE', 'TABLE', 'IMAGEMAP', 'OBJECT', 'EMBED');

function TPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
var
  Tag: TTag;
begin
  Tag := High(TTag);
  while Tag >= Low(TTag) do
  begin
    if (Tag = tgCustom) or (CompareText(TagSymbols[Tag], TagString) = 0) then Break;
    Dec(Tag);
  end;
  Result := '';
  DoTagEvent(Tag, TagString, TagParams, Result);
end;

procedure TPageProducer.DoTagEvent(Tag: TTag; const TagString: string;
  TagParams: TStrings; var ReplaceText: string);
begin
  if Assigned(FOnHTMLTag) then
    FOnHTMLTag(Self, Tag, TagString, TagParams, ReplaceText);
end;

{ TWebActionItem }

constructor TWebActionItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FEnabled := True;
  FMask := TMask.Create('');
end;

destructor TWebActionItem.Destroy;
begin
  FMask.Free;
  inherited Destroy;
end;

procedure TWebActionItem.AssignTo(Dest: TPersistent);
begin
  if Dest is TWebActionItem then
  begin
    if Assigned(Collection) then Collection.BeginUpdate;
    try
      with TWebActionItem(Dest) do
      begin
        Default := Self.Default;
        PathInfo := Self.PathInfo;
        Enabled := Self.Enabled;
        MethodType := Self.MethodType;
      end;
    finally
      if Assigned(Collection) then Collection.EndUpdate;
    end;
  end else inherited AssignTo(Dest);
end;

function TWebActionItem.DispatchAction(Request: TWebRequest; Response: TWebResponse;
  DoDefault: Boolean): Boolean;
begin
  Result := False;
  if (FDefault and DoDefault) or (FEnabled and ((FMethodType = mtAny) or
    (FMethodType = Request.MethodType)) and
    FMask.Matches(Request.PathInfo)) then
    if Assigned(FOnAction) then
    begin
      Result := True;
      FOnAction(Self, Request, Response, Result);
    end;
end;

function TWebActionItem.GetDisplayName: string;
begin
  Result := FName;
end;

procedure TWebActionItem.SetDefault(Value: Boolean);
var
  I: Integer;
  Action: TWebActionItem;
begin
  if Value <> FDefault then
  begin
    if Value and (Collection <> nil) then
      for I := 0 to Collection.Count - 1 do
      begin
        Action := TWebActionItems(Collection).Items[I];
        if (Action <> Self) and (Action is TWebActionItem) then
          Action.Default := False;
      end;
    FDefault := Value;
    Changed(False);
  end;
end;

procedure TWebActionItem.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    Changed(False);
  end;
end;

procedure TWebActionItem.SetMethodType(Value: TMethodType);
begin
  if Value <> FMethodType then
  begin
    FMethodType := Value;
    Changed(False);
  end;
end;

procedure TWebActionItem.SetDisplayName(const Value: string);
var
  I: Integer;
  Action: TWebActionItem;
begin
  if AnsiCompareText(Value, FName) <> 0 then
  begin
    if Collection <> nil then
      for I := 0 to Collection.Count - 1 do
      begin
        Action := TWebActionItems(Collection).Items[I];
        if (Action <> Self) and (Action is TWebActionItem) and
          (AnsiCompareText(Value, Action.Name) = 0) then
          raise Exception.Create(sDuplicateActionName);
      end;
    FName := Value;
    Changed(False);
  end;
end;

procedure TWebActionItem.SetOnAction(Value: THTTPMethodEvent);
begin
  FOnAction := Value;
  Changed(False);
end;

procedure TWebActionItem.SetPathInfo(const Value: string);
var
  Mask: TMask;
  NewValue: string;
begin
  if Value <> '' then NewValue := DosPathToUnixPath(Value);
  if (NewValue <> '') and (NewValue[1] <> '/') then Insert('/', NewValue, 1);
  if AnsiCompareText(FPathInfo, NewValue) <> 0 then
  begin
    Mask := TMask.Create(NewValue);
    try
      FPathInfo := NewValue;
      FMask.Free;
      FMask := nil;
    except
      Mask.Free;
      raise;
    end;
    FMask := Mask;
    Changed(False);
  end;
end;

{ TWebActionItems }

constructor TWebActionItems.Create(WebDispatcher: TCustomWebDispatcher;
  ItemClass: TCollectionItemClass);
begin
  inherited Create(ItemClass);
  FWebDispatcher := WebDispatcher;
end;

function TWebActionItems.Add: TWebActionItem;
begin
  Result := TWebActionItem(inherited Add);
end;

function TWebActionItems.GetActionItem(Index: Integer): TWebActionItem;
begin
  Result := TWebActionItem(inherited Items[Index]);
end;

function TWebActionItems.GetAttrCount: Integer;
begin
  Result := 4;
end;

function TWebActionItems.GetAttr(Index: Integer): string;
begin
  case Index of
    0: Result := sHTTPItemName;
    1: Result := sHTTPItemURI;
    2: Result := sHTTPItemEnabled;
    3: Result := sHTTPItemDefault;
  else
    Result := '';
  end;
end;

function TWebActionItems.GetItemAttr(Index, ItemIndex: Integer): string;
begin
  case Index of
    0: Result := Items[ItemIndex].Name;
    1: Result := Items[ItemIndex].PathInfo;
    2: if Items[ItemIndex].Enabled then
         Result := 'True' else Result := 'False'; // do not localize
    3: if Items[ItemIndex].Default then
         Result := '*' else Result := '';  //do not localize
  else
    Result := '';
  end;
end;

function TWebActionItems.GetOwner: TPersistent;
begin
  Result := FWebDispatcher;
end;

procedure TWebActionItems.SetActionItem(Index: Integer; Value: TWebActionItem);
begin
  Items[Index].Assign(Value);
end;

procedure TWebActionItems.SetItemName(Item: TCollectionItem);
var
  I, J: Integer;
  ItemName: string;
  CurItem: TWebActionItem;
begin
  J := 1;
  while True do
  begin
    ItemName := Format('WebActionItem%d', [J]);
    I := 0;
    while I < Count do
    begin
      CurItem := Items[I] as TWebActionItem;
      if (CurItem <> Item) and (CompareText(CurItem.Name, ItemName) = 0) then
      begin
        Inc(J);
        Break;
      end;
      Inc(I);
    end;
    if I >= Count then
    begin
      (Item as TWebActionItem).Name := ItemName;
      Break;
    end;
  end;
end;

procedure TWebActionItems.Update(Item: TCollectionItem);
begin
{!!!  if (FWebDispatcher <> nil) and
    not (csLoading in FWebDispatcher.ComponentState) then }
end;

{ TCustomWebDispatcher }

constructor TCustomWebDispatcher.Create(AOwner: TComponent);
var
  I: Integer;
  Component: TComponent;
begin
  RPR;
  if (AOwner <> nil) and (AOwner <> Application) then
    if AOwner is TCustomWebDispatcher then
      raise Exception.Create(sOnlyOneDispatcher)
    else for I := 0 to AOwner.ComponentCount - 1 do
      if AOwner.Components[I] is TCustomWebDispatcher then
        raise Exception.Create(sOnlyOneDispatcher);
  inherited CreateNew(AOwner);
  FActions := TWebActionItems.Create(Self, TWebActionItem);
  if Owner <> nil then
    for I := 0 to Owner.ComponentCount - 1 do
    begin
      Component := Owner.Components[I];
      if Component is TCustomContentProducer then
        TCustomContentProducer(Component).Dispatcher := Self;
    end;
end;

destructor TCustomWebDispatcher.Destroy;
begin
  inherited Destroy;
  FActions.Free;
end;

function TCustomWebDispatcher.ActionByName(const AName: string): TWebActionItem;
var
  I: Integer;
begin
  for I := 0 to FActions.Count - 1 do
  begin
    Result := FActions[I];
    if AnsiCompareText(AName, Result.Name) = 0 then Exit;
  end;
  Result := nil;
end;

function TCustomWebDispatcher.DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
begin
  Result := True;
  if Assigned(FAfterDispatch) then
    FAfterDispatch(Self, Request, Response, Result);
end;

function TCustomWebDispatcher.DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
begin
  Result := False;
  if Assigned(FBeforeDispatch) then
    FBeforeDispatch(Self, Request, Response, Result);
end;

function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
  Response: TWebResponse): Boolean;
var
  I: Integer;
  Action, Default: TWebActionItem;
begin
  FRequest := Request;
  FResponse := Response;
  I := 0;
  Default := nil;
  Result := DoBeforeDispatch(Request, Response) or Response.Sent;
  while not Result and (I < FActions.Count) do
  begin
    Action := FActions[I];
    Result := Action.DispatchAction(Request, Response, False);
    if Action.Default then Default := Action;
    Inc(I);
  end;
  if not Result and Assigned(Default) then
    Result := Default.DispatchAction(Request, Response, True);
  if Result and not Response.Sent then
    Result := DoAfterDispatch(Request, Response);
end;

function TCustomWebDispatcher.GetAction(Index: Integer): TWebActionItem;
begin
  Result := FActions[Index];
end;

procedure TCustomWebDispatcher.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opInsert) and (AComponent is TCustomContentProducer) then
    TCustomContentProducer(AComponent).Dispatcher := Self;
end;

procedure TCustomWebDispatcher.SetActions(Value: TWebActionItems);
begin
  FActions.Assign(Value);
end;

{ TWebModule }

constructor TWebModule.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (ClassType <> TCustomWebDispatcher) and not (csDesigning in ComponentState) then
  begin
    if not InitInheritedComponent(Self, TCustomWebDispatcher) then
      raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
    try
      if Assigned(OnCreate) then OnCreate(Self);
    except
      Forms.Application.HandleException(Self);
    end;
  end;
end;

{ TWebApplication }

procedure DoneVCLApplication;
begin
  with Forms.Application do
  begin
    if Handle <> 0 then ShowOwnedPopups(Handle, False);
    ShowHint := False;
    Destroying;
    DestroyComponents;
  end;
  with Application do
  begin
    Destroying;
    DestroyComponents;
  end;
end;

procedure DLLExitProc(Reason: Integer); register;
begin
  if Reason = DLL_PROCESS_DETACH then DoneVCLApplication;
end;

constructor TWebApplication.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCriticalSection := TCriticalSection.Create;
  FUniqueNumbers := TBits.Create;
  FActiveWebModules := TList.Create;
  FInactiveWebModules := TList.Create;
  FMaxConnections := 32;
  FCacheConnections := True;
  if IsLibrary then
  begin
    IsMultiThread := True;
    DLLProc := @DLLExitProc;
  end;
end;

destructor TWebApplication.Destroy;
begin
  Forms.Application.OnException := nil;
  FCriticalSection.Free;
  FUniqueNumbers.Free;
  FActiveWebModules.Free;
  FInactiveWebModules.Free;
  inherited Destroy;
end;

procedure TWebApplication.CreateForm(InstanceClass: TComponentClass;
  var Reference);
begin
  if FWebModuleClass = nil then
    FWebModuleClass := InstanceClass
  else raise Exception.Create(sOnlyOneDataModuleAllowed);
end;

function TWebApplication.ActivateWebModule: TDataModule;
begin
  FCriticalSection.Enter;
  try
    Result := nil;
    if (FMaxConnections > 0) and (FActiveWebModules.Count >= FMaxConnections) then
      raise Exception.Create(sTooManyActiveConnections);
    if FInactiveWebModules.Count > 0 then
    begin
      Result := FInactiveWebModules[0];
      FInactiveWebModules.Delete(0);
      FActiveWebModules.Add(Result);
    end else if FWebModuleClass <> nil then
    begin
      TComponent(Result) := FWebModuleClass.Create(Self);
      FActiveWebModules.Add(Result);
    end else raise Exception.Create(sNoDataModulesRegistered);
  finally
    FCriticalSection.Leave;
  end;
end;

procedure TWebApplication.DeactivateWebModule(DataModule: TDataModule);
begin
  FCriticalSection.Enter;
  try
    FActiveWebModules.Remove(DataModule);
    if FCacheConnections then
      FInactiveWebModules.Add(DataModule)
    else DataModule.Free;  
  finally
    FCriticalSection.Leave;
  end;
end;

procedure TWebApplication.DoHandleException(E: Exception);
begin
end;

function TWebApplication.GetActiveCount: Integer;
begin
  FCriticalSection.Enter;
  try
    Result := FActiveWebModules.Count;
  finally
    FCriticalSection.Leave;
  end;
end;

function TWebApplication.GetInactiveCount: Integer;
begin
  FCriticalSection.Enter;
  try
    Result := FInactiveWebModules.Count;
  finally
    FCriticalSection.Leave;
  end;
end;

function TWebApplication.HandleRequest(Request: TWebRequest;
  Response: TWebResponse): Boolean;
var
  DataModule: TDataModule;
  Dispatcher: TCustomWebDispatcher;
  I: Integer;
begin
  Result := False;
  DataModule := ActivateWebModule;
  if DataModule <> nil then
  try
    if DataModule is TCustomWebDispatcher then
      Dispatcher := TCustomWebDispatcher(DataModule)
    else with DataModule do
    begin
      Dispatcher := nil;
      for I := 0 to ComponentCount - 1 do
      begin
        if Components[I] is TCustomWebDispatcher then
        begin
          Dispatcher := TCustomWebDispatcher(Components[I]);
          Break;
        end;
      end;
    end;
    if Dispatcher <> nil then
    begin
      Result := Dispatcher.DispatchAction(Request, Response);
      if Result and not Response.Sent then
        Response.SendResponse;
    end else raise Exception.Create(sNoDispatcherComponent);
  finally
    DeactivateWebModule(DataModule);
  end;
end;

procedure TWebApplication.Initialize;
begin
  // This is a place holder
end;

procedure TWebApplication.OnExceptionHandler(Sender: TObject; E: Exception);
begin
  DoHandleException(E);
end;

procedure TWebApplication.SetCacheConnections(Value: Boolean);
var
  I: Integer;
begin
  if Value <> FCacheConnections then
  begin
    FCacheConnections := Value;
    if not Value then
    begin
      FCriticalSection.Enter;
      try
        for I := 0 to FInactiveWebModules.Count - 1 do
          TDataModule(FInactiveWebModules[I]).Free;
        FInactiveWebModules.Clear;  
      finally
        FCriticalSection.Leave;
      end;
    end;
  end;
end;

procedure TWebApplication.Run;
begin
  if not IsLibrary then AddExitProc(DoneVCLApplication);
  Forms.Application.OnException := OnExceptionHandler;
end;

function HTTPDecode(const AStr: String): String;
var
  Sp, Rp, Cp: PChar;
begin
  SetLength(Result, Length(AStr));
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do
  begin
    if not (Sp^ in ['+','%']) then
      Rp^ := Sp^
    else
      if Sp^ = '+' then
        Rp^ := ' '
      else
      begin
        inc(Sp);
        if Sp^ = '%' then
          Rp^ := '%'
        else
        begin
          Cp := Sp;
          Inc(Sp);
          Rp^ := Chr(StrToInt(Format('$%s%s',[Cp^, Sp^])));
        end;
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

function HTTPEncode(const AStr: String): String;
const
  NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-',
                  '0'..'9','$','!','''','(',')'];
var
  Sp, Rp: PChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else
      if Sp^ = ' ' then
        Rp^ := '+'
      else
      begin
        FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
        Inc(Rp,2);
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

const
// These strings are NOT to be resourced

  Months: array[1..12] of string = (
    'Jan', 'Feb', 'Mar', 'Apr',
    'May', 'Jun', 'Jul', 'Aug',
    'Sep', 'Oct', 'Nov', 'Dec');
  DaysOfWeek: array[1..7] of string = (
    'Sun', 'Mon', 'Tue', 'Wed',
    'Thu', 'Fri', 'Sat');

function ParseDate(const DateStr: string): TDateTime;
var
  Month, Day, Year, Hour, Minute, Sec: Integer;
  Parser: TParser;
  StringStream: TStringStream;

  function GetMonth: Boolean;
  begin
    Month := 1;
    while not Parser.TokenSymbolIs(Months[Month]) and (Month < 13) do Inc(Month);
    Result := Month < 13;
  end;

  procedure GetTime;
  begin
    with Parser do
    begin
      Hour := TokenInt;
      NextToken;
      if Token = ':' then NextToken;
      Minute := TokenInt;
      NextToken;
      if Token = ':' then NextToken;
      Sec := TokenInt;
      NextToken;
    end;
  end;

begin
  StringStream := TStringStream.Create(DateStr);
  try
    Parser := TParser.Create(StringStream);
    with Parser do
    try
      NextToken;
      if Token = ':' then NextToken;
      NextToken;
      if Token = ',' then NextToken;
      if GetMonth then
      begin
        NextToken;
        Day := TokenInt;
        NextToken;
        GetTime;
        Year := TokenInt;
      end else
      begin
        Day := TokenInt;
        NextToken;
        if Token = '-' then NextToken;
        GetMonth;
        NextToken;
        if Token = '-' then NextToken;
        Year := TokenInt;
        if Year < 100 then Inc(Year, 1900);
        NextToken;
        GetTime;
      end;
      Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Sec, 0);
    finally
      Free;
    end;
  finally
    StringStream.Free;
  end;
end;

procedure ExtractHeaderFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings; Decode: Boolean);
var
  Head, Tail: PChar;
  EOS, InQuote: Boolean;
  QuoteChar: Char;
begin
  if (Content = nil) or (Content^=#0) then Exit;
  Tail := Content;
  InQuote := False;
  QuoteChar := #0;
  repeat
    while Tail^ in WhiteSpace + [#13, #10] do Inc(Tail);
    Head := Tail;
    while True do
    begin
      while (InQuote and (Tail^ <> '"')) or
        not (Tail^ in Separators + [#0, #13, #10, '"']) do Inc(Tail);
      if Tail^ = '"' then
      begin
        if (QuoteChar <> #0) and (QuoteChar = Tail^) then
          QuoteChar := #0
        else
        begin
          QuoteChar := Tail^;
          Inc(Head);
        end;
        InQuote := QuoteChar <> #0;
        if InQuote then
          Inc(Tail)
        else Break;
      end else Break;
    end;
    EOS := Tail^ = #0;
    Tail^ := #0;
    if Head^ <> #0 then
      if Decode then
        Strings.Add(HTTPDecode(Head))
      else Strings.Add(Head);
    Inc(Tail);
  until EOS;
end;

procedure ExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  Strings: TStrings);
begin
  ExtractHeaderFields(Separators, WhiteSpace, Content, Strings, True);
end;

function StatusString(StatusCode: Integer): string;
begin
  case StatusCode of
    100: Result := 'Continue';
    101: Result := 'Switching Protocols';
    200: Result := 'OK';
    201: Result := 'Created';
    202: Result := 'Accepted';
    203: Result := 'Non-Authoritative Information';
    204: Result := 'No Content';
    205: Result := 'Reset Content';
    206: Result := 'Partial Content';
    300: Result := 'Multiple Choices';
    301: Result := 'Moved Permanently';
    302: Result := 'Moved Temporarily';
    303: Result := 'See Other';
    304: Result := 'Not Modified';
    305: Result := 'Use Proxy';
    400: Result := 'Bad Request';
    401: Result := 'Unauthorized';
    402: Result := 'Payment Required';
    403: Result := 'Forbidden';
    404: Result := 'Not Found';
    405: Result := 'Method Not Allowed';
    406: Result := 'None Acceptable';
    407: Result := 'Proxy Authentication Required';
    408: Result := 'Request Timeout';
    409: Result := 'Conflict';
    410: Result := 'Gone';
    411: Result := 'Length Required';
    412: Result := 'Unless True';
    500: Result := 'Internal Server Error';
    501: Result := 'Not Implemented';
    502: Result := 'Bad Gateway';
    503: Result := 'Service Unavailable';
    504: Result := 'Gateway Timeout';
  else
    Result := '';
  end
end;

function TranslateChar(const Str: string; FromChar, ToChar: Char): string;
var
  I: Integer;
begin
  Result := Str;
  for I := 1 to Length(Result) do
    if Result[I] = FromChar then
      Result[I] := ToChar;
end;

function UnixPathToDosPath(const Path: string): string;
begin
  Result := TranslateChar(Path, '/', '\');
end;

function DosPathToUnixPath(const Path: string): string;
begin
  Result := TranslateChar(Path, '\', '/');
end;

function MonthStr(DateTime: TDateTime): string;
var
  Year, Month, Day: Word;
begin
  DecodeDate(DateTime, Year, Month, Day);
  Result := Months[Month];
end;

function DayOfWeekStr(DateTime: TDateTime): string;
begin
  Result := DaysOfWeek[DayOfWeek(DateTime)];
end;

end.
