home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Internet / HTTPAPP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  53.2 KB  |  1,856 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {       Web server application components               }
  6. {                                                       }
  7. {       Copyright (c) 1997,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit HTTPApp;
  12.  
  13. interface
  14.  
  15. uses SyncObjs, SysUtils, Classes, Forms, Masks, Contnrs;
  16.  
  17. const
  18.   sDateFormat = '"%s", dd "%s" yyyy hh:mm:ss';
  19.  
  20.   MAX_STRINGS = 12;
  21.   MAX_INTEGERS = 1;
  22.   MAX_DATETIMES = 3;
  23.  
  24. type
  25.   TMethodType = (mtAny, mtGet, mtPut, mtPost, mtHead);
  26.  
  27. { Forward declaration }
  28.  
  29.   TWebResponse = class;
  30.  
  31. { TWebRequest }
  32.  
  33.   TWebRequest = class(TObject)
  34.   private
  35.     FMethodType: TMethodType;
  36.     FContentFields,
  37.     FCookieFields,
  38.     FQueryFields: TStrings;
  39.     function GetContentFields: TStrings;
  40.     function GetCookieFields: TStrings;
  41.     function GetQueryFields: TStrings;
  42.   protected
  43.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  44.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  45.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  46.   public
  47.     constructor Create;
  48.     destructor Destroy; override;
  49.     // Read count bytes from client
  50.     function ReadClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  51.     // Read count characters as a string from client
  52.     function ReadString(Count: Integer): string; virtual; abstract;
  53.     // Translate a relative URI to a local absolute path
  54.     function TranslateURI(const URI: string): string; virtual; abstract;
  55.     // Write count bytes back to client
  56.     function WriteClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  57.     // Write string contents back to client
  58.     function WriteString(const AString: string): Boolean; virtual; abstract;
  59.     // Utility to extract fields from a given string buffer
  60.     procedure ExtractFields(Separators, WhiteSpace: TSysCharSet;
  61.       Content: PChar; Strings: TStrings);
  62.     // Fills the given string list with the content fields as the result
  63.     // of a POST method
  64.     procedure ExtractContentFields(Strings: TStrings);
  65.     // Fills the given string list with values from the cookie header field
  66.     procedure ExtractCookieFields(Strings: TStrings);
  67.     // Fills the given TStrings with the values from the Query data
  68.     // (ie: data following the "?" in the URL)
  69.     procedure ExtractQueryFields(Strings: TStrings);
  70.     // Read an arbitrary HTTP/Server Field not lists here
  71.     function GetFieldByName(const Name: string): string; virtual; abstract;
  72.     // The request method as an enumeration
  73.     property MethodType: TMethodType read FMethodType;
  74.     // Field lists
  75.     property ContentFields: TStrings read GetContentFields;
  76.     property CookieFields: TStrings read GetCookieFields;
  77.     property QueryFields: TStrings read GetQueryFields;
  78.     // HTTP header Fields
  79.     property Method: string index 0 read GetStringVariable;
  80.     property ProtocolVersion: string index 1 read GetStringVariable;
  81.     property URL: string index 2 read GetStringVariable;
  82.     property Query: string index 3 read GetStringVariable;
  83.     property PathInfo: string index 4 read GetStringVariable;
  84.     property PathTranslated: string index 5 read GetStringVariable;
  85.     property Authorization: string index 28 read GetStringVariable;
  86.     property CacheControl: string index 6 read GetStringVariable;
  87.     property Cookie: string index 27 read GetStringVariable;
  88.     property Date: TDateTime index 7 read GetDateVariable;
  89.     property Accept: string index 8 read GetStringVariable;
  90.     property From: string index 9 read GetStringVariable;
  91.     property Host: string index 10 read GetStringVariable;
  92.     property IfModifiedSince: TDateTime index 11 read GetDateVariable;
  93.     property Referer: string index 12 read GetStringVariable;
  94.     property UserAgent: string index 13 read GetStringVariable;
  95.     property ContentEncoding: string index 14 read GetStringVariable;
  96.     property ContentType: string index 15 read GetStringVariable;
  97.     property ContentLength: Integer index 16 read GetIntegerVariable;
  98.     property ContentVersion: string index 17 read GetStringVariable;
  99.     property Content: string index 25 read GetStringVariable;
  100.     property Connection: string index 26 read GetStringVariable;
  101.     property DerivedFrom: string index 18 read GetStringVariable;
  102.     property Expires: TDateTime index 19 read GetDateVariable;
  103.     property Title: string index 20 read GetStringVariable;
  104.     property RemoteAddr: string index 21 read GetStringVariable;
  105.     property RemoteHost: string index 22 read GetStringVariable;
  106.     property ScriptName: string index 23 read GetStringVariable;
  107.     property ServerPort: Integer index 24 read GetIntegerVariable;
  108.   end;
  109.  
  110. { TCookie }
  111.  
  112.   TCookie = class(TCollectionItem)
  113.   private
  114.     FName: string;
  115.     FValue: string;
  116.     FPath: string;
  117.     FDomain: string;
  118.     FExpires: TDateTime;
  119.     FSecure: Boolean;
  120.   protected
  121.     function GetHeaderValue: string;
  122.   public
  123.     constructor Create(Collection: TCollection); override;
  124.     procedure AssignTo(Dest: TPersistent); override;
  125.     property Name: string read FName write FName;
  126.     property Value: string read FValue write FValue;
  127.     property Domain: string read FDomain write FDomain;
  128.     property Path: string read FPath write FPath;
  129.     property Expires: TDateTime read FExpires write FExpires;
  130.     property Secure: Boolean read FSecure write FSecure;
  131.     property HeaderValue: string read GetHeaderValue;
  132.   end;
  133.  
  134. { TCookieCollection }
  135.  
  136.   TCookieCollection = class(TCollection)
  137.   private
  138.     FWebResponse: TWebResponse;
  139.   protected
  140.     function GetCookie(Index: Integer): TCookie;
  141.     procedure SetCookie(Index: Integer; Cookie: TCookie);
  142.   public
  143.     constructor Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
  144.     function  Add: TCookie;
  145.     property WebResponse: TWebResponse read FWebResponse;
  146.     property Items[Index: Integer]: TCookie read GetCookie write SetCookie; default;
  147.   end;
  148.  
  149. { TWebResponse }
  150.  
  151.   TWebResponse = class(TObject)
  152.   private
  153.     FContentStream: TStream;
  154.     FCustomHeaders: TStrings;
  155.     FCookies: TCookieCollection;
  156.     procedure SetCustomHeaders(Value: TStrings);
  157.   protected
  158.     FHTTPRequest: TWebRequest;
  159.     procedure AddCustomHeaders(var Headers: string);
  160.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  161.     procedure SetStringVariable(Index: Integer; const Value: string); virtual; abstract;
  162.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  163.     procedure SetDateVariable(Index: Integer; const Value: TDateTime); virtual; abstract;
  164.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  165.     procedure SetIntegerVariable(Index: Integer; Value: Integer); virtual; abstract;
  166.     function GetContent: string; virtual; abstract;
  167.     procedure SetContent(const Value: string); virtual; abstract;
  168.     procedure SetContentStream(Value: TStream); virtual;
  169.     function GetStatusCode: Integer; virtual; abstract;
  170.     procedure SetStatusCode(Value: Integer); virtual; abstract;
  171.     function GetLogMessage: string; virtual; abstract;
  172.     procedure SetLogMessage(const Value: string); virtual; abstract;
  173.   public
  174.     constructor Create(HTTPRequest: TWebRequest);
  175.     destructor Destroy; override;
  176.     function GetCustomHeader(const Name: string): String;
  177.     procedure SendResponse; virtual; abstract;
  178.     procedure SendRedirect(const URI: string); virtual; abstract;
  179.     procedure SendStream(AStream: TStream); virtual; abstract;
  180.     function Sent: Boolean; virtual;
  181.     procedure SetCookieField(Values: TStrings; const ADomain, APath: string;
  182.       AExpires: TDateTime; ASecure: Boolean);
  183.     procedure SetCustomHeader(const Name, Value: string);
  184.     property Cookies: TCookieCollection read FCookies;
  185.     property HTTPRequest: TWebRequest read FHTTPRequest;
  186.     property Version: string index 0 read GetStringVariable write SetStringVariable;
  187.     property ReasonString: string index 1 read GetStringVariable write SetStringVariable;
  188.     property Server: string index 2 read GetStringVariable write SetStringVariable;
  189.     property WWWAuthenticate: string index 3 read GetStringVariable write SetStringVariable;
  190.     property Realm: string index 4 read GetStringVariable write SetStringVariable;
  191.     property Allow: string index 5 read GetStringVariable write SetStringVariable;
  192.     property Location: string index 6 read GetStringVariable write SetStringVariable;
  193.     property ContentEncoding: string index 7 read GetStringVariable write SetStringVariable;
  194.     property ContentType: string index 8 read GetStringVariable write SetStringVariable;
  195.     property ContentVersion: string index 9 read GetStringVariable write SetStringVariable;
  196.     property DerivedFrom: string index 10 read GetStringVariable write SetStringVariable;
  197.     property Title: string index 11 read GetStringVariable write SetStringVariable;
  198.  
  199.     property StatusCode: Integer read GetStatusCode write SetStatusCode;
  200.     property ContentLength: Integer index 0 read GetIntegerVariable write SetIntegerVariable;
  201.  
  202.     property Date: TDateTime index 0 read GetDateVariable write SetDateVariable;
  203.     property Expires: TDateTime index 1 read GetDateVariable write SetDateVariable;
  204.     property LastModified: TDateTime index 2 read GetDateVariable write SetDateVariable;
  205.  
  206.     property Content: string read GetContent write SetContent;
  207.     property ContentStream: TStream read FContentStream write SetContentStream;
  208.  
  209.     property LogMessage: string read GetLogMessage write SetLogMessage;
  210.  
  211.     property CustomHeaders: TStrings read FCustomHeaders write SetCustomHeaders;
  212.   end;
  213.  
  214. { TWebDispatcherEditor }
  215.  
  216.   TCustomWebDispatcher = class;
  217.   TCustomContentProducer = class;
  218.  
  219. { THTMLTagAttributes }
  220.  
  221.   THTMLAlign = (haDefault, haLeft, haRight, haCenter);
  222.   THTMLVAlign = (haVDefault, haTop, haMiddle, haBottom, haBaseline);
  223.   THTMLBgColor = type string;
  224.  
  225.   THTMLTagAttributes = class(TPersistent)
  226.   private
  227.     FProducer: TCustomContentProducer;
  228.     FCustom: string;
  229.     FOnChange: TNotifyEvent;
  230.     procedure SetCustom(const Value: string);
  231.   protected
  232.     procedure Changed;
  233.   public
  234.     constructor Create(Producer: TCustomContentProducer);
  235.     procedure RestoreDefaults; virtual;
  236.     property Producer: TCustomContentProducer read FProducer;
  237.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  238.   published
  239.     property Custom: string read FCustom write SetCustom;
  240.   end;
  241.  
  242.   THTMLTableAttributes = class(THTMLTagAttributes)
  243.   private
  244.     FAlign: THTMLAlign;
  245.     FBorder: Integer;
  246.     FBgColor: THTMLBgColor;
  247.     FCellSpacing: Integer;
  248.     FCellPadding: Integer;
  249.     FWidth: Integer;
  250.     procedure SetAlign(Value: THTMLAlign);
  251.     procedure SetBorder(Value: Integer);
  252.     procedure SetBGColor(Value: THTMLBgColor);
  253.     procedure SetCellSpacing(Value: Integer);
  254.     procedure SetCellPadding(Value: Integer);
  255.     procedure SetWidth(Value: Integer);
  256.   protected
  257.     procedure AssignTo(Dest: TPersistent); override;
  258.   public
  259.     constructor Create(Producer: TCustomContentProducer);
  260.     procedure RestoreDefaults; override;
  261.   published
  262.     property Align: THTMLAlign read FAlign write SetAlign default haDefault;
  263.     property BgColor: THTMLBgColor read FBgColor write SetBgColor;
  264.     property Border: Integer read FBorder write SetBorder default -1;
  265.     property CellSpacing: Integer read FCellSpacing write SetCellSpacing default -1;
  266.     property CellPadding: Integer read FCellPadding write SetCellPAdding default -1;
  267.     property Width: Integer read FWidth write SetWidth default 100;
  268.   end;
  269.  
  270.   THTMLTableElementAttributes = class(THTMLTagAttributes)
  271.   private
  272.     FAlign: THTMLAlign;
  273.     FBgColor: THTMLBgColor;
  274.     FVAlign: THTMLVAlign;
  275.     procedure SetAlign(Value: THTMLAlign);
  276.     procedure SetBGColor(Value: THTMLBgColor);
  277.     procedure SetVAlign(Value: THTMLVAlign);
  278.   protected
  279.     procedure AssignTo(Dest: TPersistent); override;
  280.   public  
  281.     procedure RestoreDefaults; override;
  282.   published
  283.     property Align: THTMLAlign read FAlign write SetAlign default haDefault;
  284.     property BgColor: THTMLBgColor read FBgColor write SetBgColor;
  285.     property VAlign: THTMLVAlign read FVAlign write SetVAlign default haVDefault;
  286.   end;
  287.  
  288.   THTMLTableHeaderAttributes = class(THTMLTableElementAttributes)
  289.   private
  290.     FCaption: string;
  291.     procedure SetCaption(Value: string);
  292.   protected
  293.     procedure AssignTo(Dest: TPersistent); override;
  294.   public
  295.     procedure RestoreDefaults; override;
  296.   published
  297.     property Caption: string read FCaption write SetCaption;
  298.   end;
  299.  
  300.   THTMLTableRowAttributes = class(THTMLTableElementAttributes);
  301.   THTMLTableCellAttributes = class(THTMLTableElementAttributes);
  302.  
  303. { TCustomContentProducer }
  304.  
  305.   TCustomContentProducer = class(TComponent)
  306.   private
  307.     FDispatcher: TCustomWebDispatcher;
  308.   protected
  309.     procedure SetDispatcher(Value: TCustomWebDispatcher); virtual;
  310.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  311.   public
  312.     function Content: string; virtual;
  313.     function ContentFromStream(Stream: TStream): string; virtual;
  314.     function ContentFromString(const S: string): string; virtual;
  315.   published
  316.     property Dispatcher: TCustomWebDispatcher read FDispatcher
  317.       write SetDispatcher stored False;
  318.   end;
  319.  
  320. { TCustomHTTPPageProducer }
  321.  
  322.   TCustomPageProducer = class(TCustomContentProducer)
  323.   private
  324.     FHTMLFile: TFileName;
  325.     FHTMLDoc: TStrings;
  326.     FStripParamQuotes: Boolean;
  327.     procedure SetHTMLFile(const Value: TFileName);
  328.     procedure SetHTMLDoc(Value: TStrings);
  329.   protected
  330.     function HandleTag(const TagString: string; TagParams: TStrings): string; virtual;
  331.     property HTMLDoc: TStrings read FHTMLDoc write SetHTMLDoc;
  332.     property HTMLFile: TFileName read FHTMLFile write SetHTMLFile;
  333.     property StripParamQuotes: Boolean read FStripParamQuotes write FStripParamQuotes default True;
  334.   public
  335.     constructor Create(AOwner: TComponent); override;
  336.     destructor Destroy; override;
  337.     function Content: string; override;
  338.     function ContentFromStream(Stream: TStream): string; override;
  339.     function ContentFromString(const S: string): string; override;
  340.   end;
  341.  
  342. { TPageProducer }
  343.  
  344.   TTag = (tgCustom, tgLink, tgImage, tgTable, tgImageMap, tgObject, tgEmbed);
  345.  
  346.   THTMLTagEvent = procedure (Sender: TObject; Tag: TTag; const TagString: string;
  347.     TagParams: TStrings; var ReplaceText: string) of object;
  348.  
  349.   TPageProducer = class(TCustomPageProducer)
  350.   private
  351.     FOnHTMLTag: THTMLTagEvent;
  352.   protected
  353.     function HandleTag(const TagString: string; TagParams: TStrings): string; override;
  354.     procedure DoTagEvent(Tag: TTag; const TagString: string; TagParams: TStrings;
  355.       var ReplaceText: string); dynamic;
  356.   published
  357.     property HTMLDoc;
  358.     property HTMLFile;
  359.     property StripParamQuotes;
  360.     property OnHTMLTag: THTMLTagEvent read FOnHTMLTag write FOnHTMLTag;
  361.   end;
  362.  
  363. { TWebActionItem }
  364.  
  365.   THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest;
  366.     Response: TWebResponse; var Handled: Boolean) of object;
  367.  
  368.   TWebActionItem = class(TCollectionItem)
  369.   private
  370.     FOnAction: THTTPMethodEvent;
  371.     FPathInfo: string;
  372.     FMethodType: TMethodType;
  373.     FDefault: Boolean;
  374.     FEnabled: Boolean;
  375.     FMaskPathInfo: string;
  376.     FMask: TMask;
  377.     FName: string;
  378.     FProducer: TCustomContentProducer;
  379.     function DispatchAction(Request: TWebRequest; Response: TWebResponse;
  380.       DoDefault: Boolean): Boolean;
  381.     procedure SetDefault(Value: Boolean);
  382.     procedure SetEnabled(Value: Boolean);
  383.     procedure SetMethodType(Value: TMethodType);
  384.     procedure SetOnAction(Value: THTTPMethodEvent);
  385.     procedure SetPathInfo(const Value: string);
  386.     procedure SetProducer(const Value: TCustomContentProducer);
  387.     function GetMask: TMask;
  388.     function ProducerPathInfo: string;
  389.   protected
  390.     function GetDisplayName: string; override;
  391.     procedure SetDisplayName(const Value: string); override;
  392.     function GetPathInfo: string;
  393.   public
  394.     constructor Create(Collection: TCollection); override;
  395.     destructor Destroy; override;
  396.     procedure AssignTo(Dest: TPersistent); override;
  397.   published
  398.     property Default: Boolean read FDefault write SetDefault default False;
  399.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  400.     property MethodType: TMethodType read FMethodType write SetMethodType default mtAny;
  401.     property Name: string read GetDisplayName write SetDisplayName;
  402.     property PathInfo: string read GetPathInfo write SetPathInfo;
  403.     property Producer: TCustomContentProducer read FProducer write SetProducer;
  404.     property OnAction: THTTPMethodEvent read FOnAction write SetOnAction;
  405.   end;
  406.  
  407. { TWebActionItems }
  408.  
  409.   TWebActionItems = class(TCollection)
  410.   private
  411.     FWebDispatcher: TCustomWebDispatcher;
  412.     function GetActionItem(Index: Integer): TWebActionItem;
  413.     procedure SetActionItem(Index: Integer; Value: TWebActionItem);
  414.   protected
  415.     function GetAttrCount: Integer; override;
  416.     function GetAttr(Index: Integer): string; override;
  417.     function GetItemAttr(Index, ItemIndex: Integer): string; override;
  418.     function GetOwner: TPersistent; override;
  419.     procedure SetItemName(Item: TCollectionItem); override;
  420.     procedure Update(Item: TCollectionItem); override;
  421.   public
  422.     constructor Create(WebDispatcher: TCustomWebDispatcher;
  423.       ItemClass: TCollectionItemClass);
  424.     function  Add: TWebActionItem;
  425.     property WebDispatcher: TCustomWebDispatcher read FWebDispatcher;
  426.     property Items[Index: Integer]: TWebActionItem read GetActionItem
  427.       write SetActionItem; default;
  428.   end;
  429.  
  430. { IWebDispatch }
  431.  
  432.   IWebDispatch = interface
  433.   ['{F358F272-DB6D-11D2-AA3F-00A024C11562}']
  434.     function DispatchEnabled: Boolean;
  435.     function DispatchMethodType: TMethodType;
  436.     function DispatchRequest(Sender: TObject; Request: TWebRequest; Response: TWebResponse): Boolean;
  437.     function DispatchMask: TMask;
  438.     function DispatchSubItems: IInterfaceList;
  439.     property Enabled: Boolean read DispatchEnabled;
  440.     property MethodType: TMethodType read DispatchMethodType;
  441.     property Mask: TMask read DispatchMask;
  442.     property SubItems: IInterfaceList read DispatchSubItems;
  443.   end;
  444.  
  445. { TCustomWebDispatcher }
  446.  
  447.   TCustomWebDispatcher = class(TDataModule)
  448.   private
  449.     FRequest: TWebRequest;
  450.     FResponse: TWebResponse;
  451.     FActions: TWebActionItems;
  452.     FBeforeDispatch: THTTPMethodEvent;
  453.     FAfterDispatch: THTTPMethodEvent;
  454.     FDispatchList: TComponentList;
  455.     function GetAction(Index: Integer): TWebActionItem;
  456.     procedure SetActions(Value: TWebActionItems);
  457.   protected
  458.     function DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  459.     function DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  460.     function DispatchAction(Request: TWebRequest;
  461.       Response: TWebResponse): Boolean;
  462.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  463.     property BeforeDispatch: THTTPMethodEvent read FBeforeDispatch write FBeforeDispatch;
  464.     property AfterDispatch: THTTPMethodEvent read FAfterDispatch write FAfterDispatch;
  465.   public
  466.     constructor Create(AOwner: TComponent); override;
  467.     destructor Destroy; override;
  468.     function ActionByName(const AName: string): TWebActionItem;
  469.     property Actions: TWebActionItems read FActions write SetActions;
  470.     property Action[Index: Integer]: TWebActionItem read GetAction;
  471.     property Request: TWebRequest read FRequest;
  472.     property Response: TWebResponse read FResponse;
  473.   end;
  474.  
  475. { TWebDispatcher }
  476.  
  477.   TWebDispatcher = class(TCustomWebDispatcher)
  478.   published
  479.     property Actions;
  480.     property BeforeDispatch;
  481.     property AfterDispatch;
  482.   end;
  483.  
  484. { TWebModule }
  485.  
  486.   TWebModule = class(TCustomWebDispatcher)
  487.   public
  488.     constructor Create(AOwner: TComponent); override;
  489.   published
  490.     property Actions;
  491.     property BeforeDispatch;
  492.     property AfterDispatch;
  493.   end;
  494.  
  495. const
  496.   HTMLAlign: array[THTMLAlign] of string =
  497.     ('',
  498.      ' Align="Left"',
  499.      ' Align="Right"',
  500.      ' Align="Center"');
  501.   HTMLVAlign: array[THTMLVAlign] of string =
  502.     ('',
  503.      ' VAlign="Top"',
  504.      ' VAlign="Middle"',
  505.      ' VAlign="Bottom"',
  506.      ' VAlign="Basline"');
  507.  
  508. function DosPathToUnixPath(const Path: string): string;
  509. function HTTPDecode(const AStr: String): string;
  510. function HTTPEncode(const AStr: String): string;
  511. function ParseDate(const DateStr: string): TDateTime;
  512. procedure ExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  513.   Strings: TStrings; StripQuotes: Boolean = False);
  514. procedure ExtractHeaderFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  515.   Strings: TStrings; Decode: Boolean; StripQuotes: Boolean = False);
  516. function StatusString(StatusCode: Integer): string;
  517. function UnixPathToDosPath(const Path: string): string;
  518. function MonthStr(DateTime: TDateTime): string;
  519. function DayOfWeekStr(DateTime: TDateTime): string;
  520.  
  521. implementation
  522.  
  523. uses Windows, CopyPrsr, WebConst;
  524.  
  525. { TWebRequest }
  526.  
  527. constructor TWebRequest.Create;
  528. begin
  529.   inherited Create;
  530.   if CompareText(Method, 'GET') = 0 then
  531.     FMethodType := mtGet
  532.   else if CompareText(Method, 'PUT') = 0 then
  533.     FMethodType := mtPut
  534.   else if CompareText(Method, 'POST') = 0 then
  535.     FMethodType := mtPost
  536.   else if CompareText(Method, 'HEAD') = 0 then
  537.     FMethodType := mtHead;
  538. end;
  539.  
  540. destructor TWebRequest.Destroy;
  541. begin
  542.   FContentFields.Free;
  543.   FCookieFields.Free;
  544.   FQueryFields.Free;
  545.   inherited Destroy;
  546. end;
  547.  
  548. procedure TWebRequest.ExtractFields(Separators, WhiteSpace: TSysCharSet;
  549.   Content: PChar; Strings: TStrings);
  550. begin
  551.   ExtractHTTPFields(Separators, WhiteSpace, Content, Strings);
  552. end;
  553.  
  554. procedure TWebRequest.ExtractContentFields(Strings: TStrings);
  555. var
  556.   ContentStr: string;
  557. begin
  558.   if ContentLength > 0 then
  559.   begin
  560.     ContentStr := Content;
  561.     if Length(ContentStr) < ContentLength then
  562.       ContentStr := ContentStr + ReadString(ContentLength - Length(ContentStr));
  563.     ExtractFields(['&'], [], PChar(ContentStr), Strings);
  564.   end;
  565. end;
  566.  
  567. procedure TWebRequest.ExtractCookieFields(Strings: TStrings);
  568. var
  569.   CookieStr: string;
  570. begin
  571.   CookieStr := Cookie;
  572.   ExtractHeaderFields([';'], [' '], PChar(CookieStr), Strings, False);
  573. end;
  574.  
  575. procedure TWebRequest.ExtractQueryFields(Strings: TStrings);
  576. var
  577.   ContentStr: string;
  578. begin
  579.   ContentStr := Query;
  580.   ExtractFields(['&'], [], PChar(ContentStr), Strings);
  581. end;
  582.  
  583. function TWebRequest.GetContentFields: TStrings;
  584. begin
  585.   if FContentFields = nil then
  586.   begin
  587.     FContentFields := TStringList.Create;
  588.     ExtractContentFields(FContentFields);
  589.   end;
  590.   Result := FContentFields;
  591. end;
  592.  
  593. function TWebRequest.GetCookieFields: TStrings;
  594. begin
  595.   if FCookieFields = nil then
  596.   begin
  597.     FCookieFields := TStringList.Create;
  598.     ExtractCookieFields(FCookieFields);
  599.   end;
  600.   Result := FCookieFields;
  601. end;
  602.  
  603. function TWebRequest.GetQueryFields: TStrings;
  604. begin
  605.   if FQueryFields = nil then
  606.   begin
  607.     FQueryFields := TStringList.Create;
  608.     ExtractQueryFields(FQueryFields);
  609.   end;
  610.   Result := FQueryFields;
  611. end;
  612.  
  613. { TCookie }
  614.  
  615. constructor TCookie.Create(Collection: TCollection);
  616. begin
  617.   inherited Create(Collection);
  618.   FExpires := -1;
  619. end;
  620.  
  621. procedure TCookie.AssignTo(Dest: TPersistent);
  622. begin
  623.   if Dest is TCookie then
  624.     with TCookie(Dest) do
  625.     begin
  626.       Name := Self.FName;
  627.       Value := Self.FValue;
  628.       Domain := Self.FDomain;
  629.       Path := Self.FPath;
  630.       Expires := Self.FExpires;
  631.       Secure := Self.FSecure;
  632.     end else inherited AssignTo(Dest);
  633. end;
  634.  
  635. function TCookie.GetHeaderValue: string;
  636. begin
  637.   Result := Format('%s=%s; ', [FName, FValue]);
  638.   if Domain <> '' then
  639.     Result := Result + Format('domain=%s; ', [Domain]);
  640.   if Path <> '' then
  641.     Result := Result + Format('path=%s; ', [Path]);
  642.   if Expires > -1 then
  643.     Result := Result +
  644.       Format(FormatDateTime('"expires="' + sDateFormat + ' "GMT; "', Expires),
  645.         [DayOfWeekStr(Expires), MonthStr(Expires)]);
  646.   if Secure then Result := Result + 'secure';
  647.   if Copy(Result, Length(Result) - 2, MaxInt) = '; ' then
  648.     SetLength(Result, Length(Result) - 2);
  649. end;
  650.  
  651. { TCookieCollection }
  652.  
  653. constructor TCookieCollection.Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
  654. begin
  655.   inherited Create(ItemClass);
  656.   FWebResponse := WebResponse;
  657. end;
  658.  
  659. function TCookieCollection.Add: TCookie;
  660. begin
  661.   Result := TCookie(inherited Add);
  662. end;
  663.  
  664. function TCookieCollection.GetCookie(Index: Integer): TCookie;
  665. begin
  666.   Result := TCookie(inherited Items[Index]);
  667. end;
  668.  
  669. procedure TCookieCollection.SetCookie(Index: Integer; Cookie: TCookie);
  670. begin
  671.   Items[Index].Assign(Cookie);
  672. end;
  673.  
  674. { TWebResponse }
  675.  
  676. constructor TWebResponse.Create(HTTPRequest: TWebRequest);
  677. begin
  678.   inherited Create;
  679.   FHTTPRequest := HTTPRequest;
  680.   FCustomHeaders := TStringList.Create;
  681.   FCookies := TCookieCollection.Create(Self, TCookie);
  682. end;
  683.  
  684. destructor TWebResponse.Destroy;
  685. begin
  686.   FContentStream.Free;
  687.   FCustomHeaders.Free;
  688.   FCookies.Free;
  689.   inherited Destroy;
  690. end;
  691.  
  692. procedure TWebResponse.AddCustomHeaders(var Headers: string);
  693. var
  694.   I: Integer;
  695.   Name, Value: string;
  696. begin
  697.   for I := 0 to FCustomHeaders.Count - 1 do
  698.   begin
  699.     Name := FCustomHeaders.Names[I];
  700.     Value := FCustomHeaders.values[Name];
  701.     Headers := Headers + Name + ': ' + Value + #13#10;
  702.   end;
  703. end;
  704.  
  705. function TWebResponse.GetCustomHeader(const Name: string): string;
  706. begin
  707.   Result := FCustomHeaders.Values[Name];
  708. end;
  709.  
  710. function TWebResponse.Sent: Boolean;
  711. begin
  712.   Result := False;
  713. end;
  714.  
  715. procedure TWebResponse.SetContentStream(Value: TStream);
  716. begin
  717.   if Value <> FContentStream then
  718.   begin
  719.     FContentStream.Free;
  720.     FContentStream := Value;
  721.     if FContentStream <> nil then
  722.       ContentLength := FContentStream.Size
  723.     else ContentLength := Length(Content);  
  724.   end;
  725. end;
  726.  
  727. procedure TWebResponse.SetCookieField(Values: TStrings; const ADomain,
  728.   APath: string; AExpires: TDateTime; ASecure: Boolean);
  729. var
  730.   I: Integer;
  731. begin
  732.   for I := 0 to Values.Count - 1 do
  733.     with Cookies.Add do
  734.     begin
  735.       Name := Values.Names[I];
  736.       Value := Values.Values[Values.Names[I]];
  737.       Domain := ADomain;
  738.       Path := APath;
  739.       Expires := AExpires;
  740.       Secure := ASecure;
  741.     end;
  742. end;
  743.  
  744. procedure TWebResponse.SetCustomHeader(const Name, Value: string);
  745. begin
  746.   FCustomHeaders.Values[Name] := Value;
  747. end;
  748.  
  749. procedure TWebResponse.SetCustomHeaders(Value: TStrings);
  750. begin
  751.   FCustomHeaders.Assign(Value);
  752. end;
  753.  
  754. { THTMLTagAttributes }
  755.  
  756. constructor THTMLTagAttributes.Create(Producer: TCustomContentProducer);
  757. begin
  758.   inherited Create;
  759.   FProducer := Producer;
  760. end;
  761.  
  762. procedure THTMLTagAttributes.Changed;
  763. begin
  764.   if Assigned(FOnChange) then FOnChange(Self);
  765. end;
  766.  
  767. procedure THTMLTagAttributes.RestoreDefaults;
  768. begin
  769.   FCustom := '';
  770.   Changed;
  771. end;
  772.  
  773. procedure THTMLTagAttributes.SetCustom(const Value: string);
  774. begin
  775.   if Value <> FCustom then
  776.   begin
  777.     FCustom := Value;
  778.     Changed;
  779.   end;
  780. end;
  781.  
  782. { THTMLTableAttributes }
  783.  
  784. constructor THTMLTableAttributes.Create(Producer: TCustomContentProducer);
  785. begin
  786.   inherited Create(Producer);
  787.   FWidth := 100;
  788.   FBorder := -1;
  789.   FCellPadding := -1;
  790.   FCellSpacing := -1;
  791. end;
  792.  
  793. procedure THTMLTableAttributes.AssignTo(Dest: TPersistent);
  794. begin
  795.   if Dest is THTMLTableAttributes then
  796.     with THTMLTableAttributes(Dest) do
  797.     begin
  798.       FWidth := Self.FWidth;
  799.       FAlign := Self.FAlign;
  800.       FBorder := Self.FBorder;
  801.       FBgColor := Self.FBgColor;
  802.       FCellSpacing := Self.FCellSpacing;
  803.       FCellPadding := Self.FCellPadding;
  804.       Changed;
  805.     end else inherited AssignTo(Dest);
  806. end;
  807.  
  808. procedure THTMLTableAttributes.RestoreDefaults;
  809. begin
  810.   FCustom := '';
  811.   FAlign := haDefault;
  812.   FWidth := 100;
  813.   FBorder := -1;
  814.   FCellPadding := -1;
  815.   FCellSpacing := -1;
  816.   Changed;
  817. end;
  818.  
  819. procedure THTMLTableAttributes.SetAlign(Value: THTMLAlign);
  820. begin
  821.   if Value <> FAlign then
  822.   begin
  823.     FAlign := Value;
  824.     Changed;
  825.   end;
  826. end;
  827.  
  828. procedure THTMLTableAttributes.SetBorder(Value: Integer);
  829. begin
  830.   if Value <> FBorder then
  831.   begin
  832.     FBorder := Value;
  833.     Changed;
  834.   end;
  835. end;
  836.  
  837. procedure THTMLTableAttributes.SetBGColor(Value: THTMLBgColor);
  838. begin
  839.   if Value <> FBgColor then
  840.   begin
  841.     FBgColor := Value;
  842.     Changed;
  843.   end;
  844. end;
  845.  
  846. procedure THTMLTableAttributes.SetCellSpacing(Value: Integer);
  847. begin
  848.   if Value <> FCellSpacing then
  849.   begin
  850.     FCellSpacing := Value;
  851.     Changed;
  852.   end;
  853. end;
  854.  
  855. procedure THTMLTableAttributes.SetCellPadding(Value: Integer);
  856. begin
  857.   if Value <> FCellPadding then
  858.   begin
  859.     FCellPadding := Value;
  860.     Changed;
  861.   end;
  862. end;
  863.  
  864. procedure THTMLTableAttributes.SetWidth(Value: Integer);
  865. begin
  866.   if Value <> FWidth then
  867.   begin
  868.     FWidth := Value;
  869.     Changed;
  870.   end;
  871. end;
  872.  
  873. { THTMLTableElementAttributes }
  874.  
  875. procedure THTMLTableElementAttributes.AssignTo(Dest: TPersistent);
  876. begin
  877.   if Dest is THTMLTableElementAttributes then
  878.     with THTMLTableElementAttributes(Dest) do
  879.     begin
  880.       FAlign := Self.FAlign;
  881.       FVAlign := Self.FVAlign;
  882.       FBgColor := Self.FBgColor;
  883.       Changed;
  884.     end else inherited AssignTo(Dest);
  885. end;
  886.  
  887. procedure THTMLTableElementAttributes.RestoreDefaults;
  888. begin
  889.   FCustom := '';
  890.   FAlign := haDefault;
  891.   FVAlign := haVDefault;
  892.   FBgColor := '';
  893.   Changed;
  894. end;
  895.  
  896. procedure THTMLTableElementAttributes.SetAlign(Value: THTMLAlign);
  897. begin
  898.   if Value <> FAlign then
  899.   begin
  900.     FAlign := Value;
  901.     Changed;
  902.   end;
  903. end;
  904.  
  905. procedure THTMLTableElementAttributes.SetBGColor(Value: THTMLBgColor);
  906. begin
  907.   if Value <> FBgColor then
  908.   begin
  909.     FBgColor := Value;
  910.     Changed;
  911.   end;
  912. end;
  913.  
  914. procedure THTMLTableElementAttributes.SetVAlign(Value: THTMLVAlign);
  915. begin
  916.   if Value <> FVAlign then
  917.   begin
  918.     FVAlign := Value;
  919.     Changed;
  920.   end;
  921. end;
  922.  
  923. { THTMLTableHeaderAttributes }
  924.  
  925. procedure THTMLTableHeaderAttributes.AssignTo(Dest: TPersistent);
  926. begin
  927.   if Dest is THTMLTableHeaderAttributes then
  928.     with THTMLTableHeaderAttributes(Dest) do
  929.     begin
  930.       FAlign := Self.FAlign;
  931.       FVAlign := Self.FVAlign;
  932.       FBgColor := Self.FBgColor;
  933.       FCaption := Self.FCaption;
  934.       Changed;
  935.     end else inherited AssignTo(Dest);
  936. end;
  937.  
  938. procedure THTMLTableHeaderAttributes.RestoreDefaults;
  939. begin
  940.   FCustom := '';
  941.   FAlign := haDefault;
  942.   FVAlign := haVDefault;
  943.   FBgColor := '';
  944.   FCaption := '';
  945.   Changed;
  946. end;
  947.  
  948. procedure THTMLTableHeaderAttributes.SetCaption(Value: string);
  949. begin
  950.   if AnsiCompareStr(Value, FCaption) <> 0 then
  951.   begin
  952.     FCaption := Value;
  953.     Changed;
  954.   end;
  955. end;
  956.  
  957. { TCustomHTMLProducer }
  958.  
  959. procedure TCustomContentProducer.Notification(AComponent: TComponent;
  960.   Operation: TOperation);
  961. begin
  962.   inherited Notification(AComponent, Operation);
  963.   if (Operation = opRemove) and (AComponent = FDispatcher) then
  964.     FDispatcher := nil;
  965. end;
  966.  
  967. procedure TCustomContentProducer.SetDispatcher(Value: TCustomWebDispatcher);
  968. begin
  969.   if FDispatcher <> Value then
  970.   begin
  971.     if Value <> nil then Value.FreeNotification(Self);
  972.     FDispatcher := Value;
  973.   end;
  974. end;
  975.  
  976. function TCustomContentProducer.Content: string;
  977. begin
  978.   Result := '';
  979. end;
  980.  
  981. function TCustomContentProducer.ContentFromStream(Stream: TStream): string;
  982. begin
  983.   Result := Content;
  984. end;
  985.  
  986. function TCustomContentProducer.ContentFromString(const S: string): string;
  987. begin
  988.   Result := Content;
  989. end;
  990.  
  991. { TCustomPageProducer }
  992.  
  993. constructor TCustomPageProducer.Create(AOwner: TComponent);
  994. begin
  995.   inherited Create(AOwner);
  996.   RPR;
  997.   FStripParamQuotes := True;
  998.   FHTMLDoc := TStringList.Create;
  999. end;
  1000.  
  1001. destructor TCustomPageProducer.Destroy;
  1002. begin
  1003.   FHTMLDoc.Free;
  1004.   inherited Destroy;
  1005. end;
  1006.  
  1007. function TCustomPageProducer.Content: string;
  1008. var
  1009.   InStream: TStream;
  1010. begin
  1011.   Result := '';
  1012.   if FHTMLFile <> '' then
  1013.     InStream := TFileStream.Create(FHTMLFile, fmOpenRead + fmShareDenyWrite)
  1014.   else InStream := TStringStream.Create(FHTMLDoc.Text);
  1015.   if InStream <> nil then
  1016.   try
  1017.     Result := ContentFromStream(InStream);
  1018.   finally
  1019.     InStream.Free;
  1020.   end;
  1021. end;
  1022.  
  1023. function TCustomPageProducer.ContentFromStream(Stream: TStream): string;
  1024. var
  1025.   Parser: TCopyParser;
  1026.   OutStream: TStringStream;
  1027.   ParamStr, ReplaceStr, TokenStr: string;
  1028.   ParamList: TStringList;
  1029. begin
  1030.   OutStream := TStringStream.Create('');
  1031.   try
  1032.     Parser := TCopyParser.Create(Stream, OutStream);
  1033.     with Parser do
  1034.     try
  1035.       while True do
  1036.       begin
  1037.         while not (Token in [toEof, '<']) do
  1038.         begin
  1039.           CopyTokenToOutput;
  1040.           SkipToken(True);
  1041.         end;
  1042.         if Token = toEOF then Break;
  1043.         if Token = '<' then
  1044.         begin
  1045.           if SkipToken(False) = '#' then
  1046.           begin
  1047.             SkipToken(False);
  1048.             TokenStr := TokenString;
  1049.             ParamStr := TrimLeft(TrimRight(SkipToToken('>')));
  1050.             ParamList := TStringList.Create;
  1051.             try
  1052.               ExtractHTTPFields([' '], [' '], PChar(ParamStr), ParamList, FStripParamQuotes);
  1053.               ReplaceStr := HandleTag(TokenStr, ParamList);
  1054.               OutStream.WriteString(ReplaceStr);
  1055.             finally
  1056.               ParamList.Free;
  1057.             end;
  1058.             SkipToken(True);
  1059.           end else
  1060.           begin
  1061.             OutStream.WriteString('<');
  1062.             CopyTokenToOutput;
  1063.             SkipToken(True);
  1064.           end;
  1065.         end;
  1066.       end;
  1067.     finally
  1068.       Parser.Free;
  1069.     end;
  1070.     Result := OutStream.DataString;
  1071.   finally
  1072.     OutStream.Free;
  1073.   end;
  1074. end;
  1075.  
  1076. function TCustomPageProducer.ContentFromString(const S: string): string;
  1077. var
  1078.   InStream: TStream;
  1079. begin
  1080.   InStream := TStringStream.Create(S);
  1081.   try
  1082.     Result := ContentFromStream(InStream);
  1083.   finally
  1084.     InStream.Free;
  1085.   end;
  1086. end;
  1087.  
  1088. function TCustomPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
  1089. begin
  1090.   Result := Format('<#%s>', [TagString]);
  1091. end;
  1092.  
  1093. procedure TCustomPageProducer.SetHTMLFile(const Value: TFileName);
  1094. begin
  1095.   if CompareText(FHTMLFile, Value) <> 0 then
  1096.   begin
  1097.     FHTMLDoc.Clear;
  1098.     FHTMLFile := Value;
  1099.   end;
  1100. end;
  1101.  
  1102. procedure TCustomPageProducer.SetHTMLDoc(Value: TStrings);
  1103. begin
  1104.   FHTMLDoc.Assign(Value);
  1105.   FHTMLFile := '';
  1106. end;
  1107.  
  1108. { TPageProducer }
  1109.  
  1110. var
  1111.   TagSymbols: array[TTag] of string =
  1112.     ('', 'LINK', 'IMAGE', 'TABLE', 'IMAGEMAP', 'OBJECT', 'EMBED');
  1113.  
  1114. function TPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
  1115. var
  1116.   Tag: TTag;
  1117. begin
  1118.   Tag := High(TTag);
  1119.   while Tag >= Low(TTag) do
  1120.   begin
  1121.     if (Tag = tgCustom) or (CompareText(TagSymbols[Tag], TagString) = 0) then Break;
  1122.     Dec(Tag);
  1123.   end;
  1124.   Result := '';
  1125.   DoTagEvent(Tag, TagString, TagParams, Result);
  1126. end;
  1127.  
  1128. procedure TPageProducer.DoTagEvent(Tag: TTag; const TagString: string;
  1129.   TagParams: TStrings; var ReplaceText: string);
  1130. begin
  1131.   if Assigned(FOnHTMLTag) then
  1132.     FOnHTMLTag(Self, Tag, TagString, TagParams, ReplaceText);
  1133. end;
  1134.  
  1135. { TWebActionItem }
  1136.  
  1137. constructor TWebActionItem.Create(Collection: TCollection);
  1138. begin
  1139.   inherited Create(Collection);
  1140.   FEnabled := True;
  1141. end;
  1142.  
  1143. destructor TWebActionItem.Destroy;
  1144. begin
  1145.   FMask.Free;
  1146.   inherited Destroy;
  1147. end;
  1148.  
  1149. procedure TWebActionItem.AssignTo(Dest: TPersistent);
  1150. begin
  1151.   if Dest is TWebActionItem then
  1152.   begin
  1153.     if Assigned(Collection) then Collection.BeginUpdate;
  1154.     try
  1155.       with TWebActionItem(Dest) do
  1156.       begin
  1157.         Default := Self.Default;
  1158.         PathInfo := Self.PathInfo;
  1159.         Enabled := Self.Enabled;
  1160.         MethodType := Self.MethodType;
  1161.       end;
  1162.     finally
  1163.       if Assigned(Collection) then Collection.EndUpdate;
  1164.     end;
  1165.   end else inherited AssignTo(Dest);
  1166. end;
  1167.  
  1168. function TWebActionItem.DispatchAction(Request: TWebRequest; Response: TWebResponse;
  1169.   DoDefault: Boolean): Boolean;
  1170. begin
  1171.   Result := False;
  1172.   if (FDefault and DoDefault) or (FEnabled and ((FMethodType = mtAny) or
  1173.     (FMethodType = Request.MethodType)) and
  1174.     GetMask.Matches(Request.PathInfo)) then
  1175.   begin
  1176.     if Assigned(FProducer) then
  1177.     begin
  1178.       Result := True;
  1179.       Response.Content := FProducer.Content;
  1180.     end;
  1181.     if Assigned(FOnAction) then
  1182.     begin
  1183.       Result := True;
  1184.       FOnAction(Self, Request, Response, Result);
  1185.     end
  1186.   end;
  1187. end;
  1188.  
  1189. function TWebActionItem.GetDisplayName: string;
  1190. begin
  1191.   Result := FName;
  1192. end;
  1193.  
  1194. procedure TWebActionItem.SetDefault(Value: Boolean);
  1195. var
  1196.   I: Integer;
  1197.   Action: TWebActionItem;
  1198. begin
  1199.   if Value <> FDefault then
  1200.   begin
  1201.     if Value and (Collection <> nil) then
  1202.       for I := 0 to Collection.Count - 1 do
  1203.       begin
  1204.         Action := TWebActionItems(Collection).Items[I];
  1205.         if (Action <> Self) and (Action is TWebActionItem) then
  1206.           Action.Default := False;
  1207.       end;
  1208.     FDefault := Value;
  1209.     Changed(False);
  1210.   end;
  1211. end;
  1212.  
  1213. procedure TWebActionItem.SetEnabled(Value: Boolean);
  1214. begin
  1215.   if Value <> FEnabled then
  1216.   begin
  1217.     FEnabled := Value;
  1218.     Changed(False);
  1219.   end;
  1220. end;
  1221.  
  1222. procedure TWebActionItem.SetMethodType(Value: TMethodType);
  1223. begin
  1224.   if Value <> FMethodType then
  1225.   begin
  1226.     FMethodType := Value;
  1227.     Changed(False);
  1228.   end;
  1229. end;
  1230.  
  1231. procedure TWebActionItem.SetDisplayName(const Value: string);
  1232. var
  1233.   I: Integer;
  1234.   Action: TWebActionItem;
  1235. begin
  1236.   if AnsiCompareText(Value, FName) <> 0 then
  1237.   begin
  1238.     if Collection <> nil then
  1239.       for I := 0 to Collection.Count - 1 do
  1240.       begin
  1241.         Action := TWebActionItems(Collection).Items[I];
  1242.         if (Action <> Self) and (Action is TWebActionItem) and
  1243.           (AnsiCompareText(Value, Action.Name) = 0) then
  1244.           raise Exception.Create(sDuplicateActionName);
  1245.       end;
  1246.     FName := Value;
  1247.     Changed(False);
  1248.   end;
  1249. end;
  1250.  
  1251. procedure TWebActionItem.SetOnAction(Value: THTTPMethodEvent);
  1252. begin
  1253.   FOnAction := Value;
  1254.   Changed(False);
  1255. end;
  1256.  
  1257. procedure TWebActionItem.SetPathInfo(const Value: string);
  1258. var
  1259.   NewValue: string;
  1260. begin
  1261.   if Value <> '' then NewValue := DosPathToUnixPath(Value);
  1262.   if (NewValue <> '') and (NewValue[1] <> '/') then Insert('/', NewValue, 1);
  1263.   if Assigned(FProducer) and (NewValue = ProducerPathInfo) then
  1264.     NewValue := '';
  1265.   if AnsiCompareText(FPathInfo, NewValue) <> 0 then
  1266.   begin
  1267.     FPathInfo := NewValue;
  1268.     Changed(False);
  1269.   end;
  1270. end;
  1271.  
  1272. procedure TWebActionItem.SetProducer(const Value: TCustomContentProducer);
  1273. begin
  1274.   if Assigned(Value) then
  1275.     Value.FreeNotification(TWebActionItems(Collection).WebDispatcher);
  1276.   FProducer := Value;
  1277. end;
  1278.  
  1279. function TWebActionItem.ProducerPathInfo: string;
  1280. begin
  1281.   Assert(Assigned(FProducer));
  1282.   Result := '/' + FProducer.Name
  1283. end;
  1284.  
  1285. function TWebActionItem.GetPathInfo: string;
  1286. begin
  1287.   if (FPathInfo = '') and Assigned(FProducer) then
  1288.     Result := ProducerPathInfo
  1289.   else
  1290.     Result := FPathInfo;
  1291. end;
  1292.  
  1293. function TWebActionItem.GetMask: TMask;
  1294. var
  1295.   Mask: TMask;
  1296.   MaskPathInfo: string;
  1297. begin
  1298.   MaskPathInfo := GetPathInfo;
  1299.   if (not Assigned(FMask)) or
  1300.     (AnsiCompareText(FMaskPathInfo, MaskPathInfo) <> 0) then
  1301.   begin
  1302.     Mask := TMask.Create(MaskPathInfo);
  1303.     try
  1304.       FMaskPathInfo := MaskPathInfo;
  1305.       if Assigned(FMask) then
  1306.       begin
  1307.         FMask.Free;
  1308.         FMask := nil;
  1309.       end;
  1310.     except
  1311.       Mask.Free;
  1312.       raise;
  1313.     end;
  1314.     FMask := Mask;
  1315.   end;
  1316.   Result := FMask;
  1317. end;
  1318.  
  1319. { TWebActionItems }
  1320.  
  1321. constructor TWebActionItems.Create(WebDispatcher: TCustomWebDispatcher;
  1322.   ItemClass: TCollectionItemClass);
  1323. begin
  1324.   inherited Create(ItemClass);
  1325.   FWebDispatcher := WebDispatcher;
  1326. end;
  1327.  
  1328. function TWebActionItems.Add: TWebActionItem;
  1329. begin
  1330.   Result := TWebActionItem(inherited Add);
  1331. end;
  1332.  
  1333. function TWebActionItems.GetActionItem(Index: Integer): TWebActionItem;
  1334. begin
  1335.   Result := TWebActionItem(inherited Items[Index]);
  1336. end;
  1337.  
  1338. function TWebActionItems.GetAttrCount: Integer;
  1339. begin
  1340.   Result := 5;
  1341. end;
  1342.  
  1343. function TWebActionItems.GetAttr(Index: Integer): string;
  1344. begin
  1345.   case Index of
  1346.     0: Result := sHTTPItemName;
  1347.     1: Result := sHTTPItemURI;
  1348.     2: Result := sHTTPItemEnabled;
  1349.     3: Result := sHTTPItemDefault;
  1350.     4: Result := sHTTPItemProducer;
  1351.   else
  1352.     Result := '';
  1353.   end;
  1354. end;
  1355.  
  1356. function TWebActionItems.GetItemAttr(Index, ItemIndex: Integer): string;
  1357. begin
  1358.   case Index of
  1359.     0: Result := Items[ItemIndex].Name;
  1360.     1: Result := Items[ItemIndex].PathInfo;
  1361.     2: if Items[ItemIndex].Enabled then
  1362.          Result := 'True' else Result := 'False'; // do not localize
  1363.     3: if Items[ItemIndex].Default then
  1364.          Result := '*' else Result := '';  //do not localize
  1365.     4: if Items[ItemIndex].Producer <> nil then
  1366.          Result := Items[ItemIndex].Producer.Name else Result := '';  //do not localize
  1367.   else
  1368.     Result := '';
  1369.   end;
  1370. end;
  1371.  
  1372. function TWebActionItems.GetOwner: TPersistent;
  1373. begin
  1374.   Result := FWebDispatcher;
  1375. end;
  1376.  
  1377. procedure TWebActionItems.SetActionItem(Index: Integer; Value: TWebActionItem);
  1378. begin
  1379.   Items[Index].Assign(Value);
  1380. end;
  1381.  
  1382. procedure TWebActionItems.SetItemName(Item: TCollectionItem);
  1383. var
  1384.   I, J: Integer;
  1385.   ItemName: string;
  1386.   CurItem: TWebActionItem;
  1387. begin
  1388.   J := 1;
  1389.   while True do
  1390.   begin
  1391.     ItemName := Format('WebActionItem%d', [J]);
  1392.     I := 0;
  1393.     while I < Count do
  1394.     begin
  1395.       CurItem := Items[I] as TWebActionItem;
  1396.       if (CurItem <> Item) and (CompareText(CurItem.Name, ItemName) = 0) then
  1397.       begin
  1398.         Inc(J);
  1399.         Break;
  1400.       end;
  1401.       Inc(I);
  1402.     end;
  1403.     if I >= Count then
  1404.     begin
  1405.       (Item as TWebActionItem).Name := ItemName;
  1406.       Break;
  1407.     end;
  1408.   end;
  1409. end;
  1410.  
  1411. procedure TWebActionItems.Update(Item: TCollectionItem);
  1412. begin
  1413. {!!!  if (FWebDispatcher <> nil) and
  1414.     not (csLoading in FWebDispatcher.ComponentState) then }
  1415. end;
  1416.  
  1417. { TCustomWebDispatcher }
  1418.  
  1419. constructor TCustomWebDispatcher.Create(AOwner: TComponent);
  1420. var
  1421.   I: Integer;
  1422.   Component: TComponent;
  1423.   DispatchIntf: IWebDispatch;
  1424. begin
  1425.   RPR;
  1426.   FDispatchList := TComponentList.Create;
  1427.   FDispatchList.OwnsObjects := False;
  1428.   if (AOwner <> nil) and (AOwner <> Application) then
  1429.     if AOwner is TCustomWebDispatcher then
  1430.       raise Exception.Create(sOnlyOneDispatcher)
  1431.     else if csDesigning in ComponentState then 
  1432.       for I := 0 to AOwner.ComponentCount - 1 do
  1433.         if AOwner.Components[I] is TCustomWebDispatcher then
  1434.           raise Exception.Create(sOnlyOneDispatcher);
  1435.   inherited CreateNew(AOwner);
  1436.   FActions := TWebActionItems.Create(Self, TWebActionItem);
  1437.   if Owner <> nil then
  1438.     for I := 0 to Owner.ComponentCount - 1 do
  1439.     begin
  1440.       Component := Owner.Components[I];
  1441.       if Component is TCustomContentProducer then
  1442.         TCustomContentProducer(Component).Dispatcher := Self
  1443.       else if Component.GetInterface(IWebDispatch, DispatchIntf) then
  1444.         FDispatchList.Add(Component);
  1445.     end;
  1446. end;
  1447.  
  1448. destructor TCustomWebDispatcher.Destroy;
  1449. begin
  1450.   inherited Destroy;
  1451.   FActions.Free;
  1452.   FDispatchList.Free;
  1453. end;
  1454.  
  1455. function TCustomWebDispatcher.ActionByName(const AName: string): TWebActionItem;
  1456. var
  1457.   I: Integer;
  1458. begin
  1459.   for I := 0 to FActions.Count - 1 do
  1460.   begin
  1461.     Result := FActions[I];
  1462.     if AnsiCompareText(AName, Result.Name) = 0 then Exit;
  1463.   end;
  1464.   Result := nil;
  1465. end;
  1466.  
  1467. function TCustomWebDispatcher.DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  1468. begin
  1469.   Result := True;
  1470.   if Assigned(FAfterDispatch) then
  1471.     FAfterDispatch(Self, Request, Response, Result);
  1472. end;
  1473.  
  1474. function TCustomWebDispatcher.DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  1475. begin
  1476.   Result := False;
  1477.   if Assigned(FBeforeDispatch) then
  1478.     FBeforeDispatch(Self, Request, Response, Result);
  1479. end;
  1480.  
  1481. function DispatchHandler(Sender: TObject; Dispatch: IWebDispatch; Request: TWebRequest; Response: TWebResponse;
  1482.   DoDefault: Boolean): Boolean;
  1483. begin
  1484.   Result := False;
  1485.   if (Dispatch.Enabled and ((Dispatch.MethodType = mtAny) or
  1486.     (Dispatch.MethodType = Dispatch.MethodType)) and
  1487.     Dispatch.Mask.Matches(Request.PathInfo)) then
  1488.   begin
  1489.     Result := Dispatch.DispatchRequest(Sender, Request, Response);
  1490.   end;
  1491. end;
  1492.  
  1493. function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
  1494.   Response: TWebResponse): Boolean;
  1495. var
  1496.   I: Integer;
  1497.   Action, Default: TWebActionItem;
  1498.   Dispatch: IWebDispatch;
  1499. begin
  1500.   FRequest := Request;
  1501.   FResponse := Response;
  1502.   I := 0;
  1503.   Default := nil;
  1504.   Result := DoBeforeDispatch(Request, Response) or Response.Sent;
  1505.   while not Result and (I < FActions.Count) do
  1506.   begin
  1507.     Action := FActions[I];
  1508.     Result := Action.DispatchAction(Request, Response, False);
  1509.     if Action.Default then Default := Action;
  1510.     Inc(I);
  1511.   end;
  1512.   // Dispatch to self registering components
  1513.   I := 0;
  1514.   while not Result and (I < FDispatchList.Count) do
  1515.   begin
  1516.     if FDispatchList.Items[I].GetInterface(IWebDispatch, Dispatch) then
  1517.     begin
  1518.       Result := DispatchHandler(Self, Dispatch,
  1519.         Request, Response, False);
  1520.     end;
  1521.     Inc(I);
  1522.   end;
  1523.  
  1524.   if not Result and Assigned(Default) then
  1525.     Result := Default.DispatchAction(Request, Response, True);
  1526.   if Result and not Response.Sent then
  1527.     Result := DoAfterDispatch(Request, Response);
  1528.  
  1529. end;
  1530.  
  1531. function TCustomWebDispatcher.GetAction(Index: Integer): TWebActionItem;
  1532. begin
  1533.   Result := FActions[Index];
  1534. end;
  1535.  
  1536. procedure TCustomWebDispatcher.Notification(AComponent: TComponent;
  1537.   Operation: TOperation);
  1538. var
  1539.   I: Integer;
  1540.   DispatchIntf: IWebDispatch;
  1541. begin
  1542.   inherited Notification(AComponent, Operation);
  1543.   if (Operation = opInsert) then
  1544.   begin
  1545.     if (AComponent is TCustomContentProducer) then
  1546.       TCustomContentProducer(AComponent).Dispatcher := Self
  1547.     else if AComponent.GetInterface(IWebDispatch, DispatchIntf) then
  1548.       FDispatchList.Add(AComponent);
  1549.   end;
  1550.   if (Operation = opRemove) and (AComponent is TCustomContentProducer) then
  1551.     for I := 0 to FActions.Count - 1 do
  1552.       if FActions.Items[I].Producer = AComponent then
  1553.         FActions.Items[I].Producer := nil;
  1554. end;
  1555.  
  1556. procedure TCustomWebDispatcher.SetActions(Value: TWebActionItems);
  1557. begin
  1558.   FActions.Assign(Value);
  1559. end;
  1560.  
  1561. { TWebModule }
  1562.  
  1563. constructor TWebModule.Create(AOwner: TComponent);
  1564. begin
  1565.   inherited Create(AOwner);
  1566.   if (ClassType <> TCustomWebDispatcher) and not (csDesigning in ComponentState) then
  1567.   begin
  1568.     if not InitInheritedComponent(Self, TCustomWebDispatcher) then
  1569.       raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  1570.     try
  1571.       if Assigned(OnCreate) and OldCreateOrder then OnCreate(Self);
  1572.     except
  1573.       Forms.Application.HandleException(Self);
  1574.     end;
  1575.   end;
  1576. end;
  1577.  
  1578. function HTTPDecode(const AStr: String): String;
  1579. var
  1580.   Sp, Rp, Cp: PChar;
  1581. begin
  1582.   SetLength(Result, Length(AStr));
  1583.   Sp := PChar(AStr);
  1584.   Rp := PChar(Result);
  1585.   while Sp^ <> #0 do
  1586.   begin
  1587.     if not (Sp^ in ['+','%']) then
  1588.       Rp^ := Sp^
  1589.     else
  1590.       if Sp^ = '+' then
  1591.         Rp^ := ' '
  1592.       else
  1593.       begin
  1594.         inc(Sp);
  1595.         if Sp^ = '%' then
  1596.           Rp^ := '%'
  1597.         else
  1598.         begin
  1599.           Cp := Sp;
  1600.           Inc(Sp);
  1601.           Rp^ := Chr(StrToInt(Format('$%s%s',[Cp^, Sp^])));
  1602.         end;
  1603.       end;
  1604.     Inc(Rp);
  1605.     Inc(Sp);
  1606.   end;
  1607.   SetLength(Result, Rp - PChar(Result));
  1608. end;
  1609.  
  1610. function HTTPEncode(const AStr: String): String;
  1611. const
  1612.   NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-',
  1613.                   '0'..'9','$','!','''','(',')'];
  1614. var
  1615.   Sp, Rp: PChar;
  1616. begin
  1617.   SetLength(Result, Length(AStr) * 3);
  1618.   Sp := PChar(AStr);
  1619.   Rp := PChar(Result);
  1620.   while Sp^ <> #0 do
  1621.   begin
  1622.     if Sp^ in NoConversion then
  1623.       Rp^ := Sp^
  1624.     else
  1625.       if Sp^ = ' ' then
  1626.         Rp^ := '+'
  1627.       else
  1628.       begin
  1629.         FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
  1630.         Inc(Rp,2);
  1631.       end;
  1632.     Inc(Rp);
  1633.     Inc(Sp);
  1634.   end;
  1635.   SetLength(Result, Rp - PChar(Result));
  1636. end;
  1637.  
  1638. const
  1639. // These strings are NOT to be resourced
  1640.  
  1641.   Months: array[1..12] of string = (
  1642.     'Jan', 'Feb', 'Mar', 'Apr',
  1643.     'May', 'Jun', 'Jul', 'Aug',
  1644.     'Sep', 'Oct', 'Nov', 'Dec');
  1645.   DaysOfWeek: array[1..7] of string = (
  1646.     'Sun', 'Mon', 'Tue', 'Wed',
  1647.     'Thu', 'Fri', 'Sat');
  1648.  
  1649. function ParseDate(const DateStr: string): TDateTime;
  1650. var
  1651.   Month, Day, Year, Hour, Minute, Sec: Integer;
  1652.   Parser: TParser;
  1653.   StringStream: TStringStream;
  1654.  
  1655.   function GetMonth: Boolean;
  1656.   begin
  1657.     Month := 1;
  1658.     while not Parser.TokenSymbolIs(Months[Month]) and (Month < 13) do Inc(Month);
  1659.     Result := Month < 13;
  1660.   end;
  1661.  
  1662.   procedure GetTime;
  1663.   begin
  1664.     with Parser do
  1665.     begin
  1666.       Hour := TokenInt;
  1667.       NextToken;
  1668.       if Token = ':' then NextToken;
  1669.       Minute := TokenInt;
  1670.       NextToken;
  1671.       if Token = ':' then NextToken;
  1672.       Sec := TokenInt;
  1673.       NextToken;
  1674.     end;
  1675.   end;
  1676.  
  1677. begin
  1678.   StringStream := TStringStream.Create(DateStr);
  1679.   try
  1680.     Parser := TParser.Create(StringStream);
  1681.     with Parser do
  1682.     try
  1683.       NextToken;
  1684.       if Token = ':' then NextToken;
  1685.       NextToken;
  1686.       if Token = ',' then NextToken;
  1687.       if GetMonth then
  1688.       begin
  1689.         NextToken;
  1690.         Day := TokenInt;
  1691.         NextToken;
  1692.         GetTime;
  1693.         Year := TokenInt;
  1694.       end else
  1695.       begin
  1696.         Day := TokenInt;
  1697.         NextToken;
  1698.         if Token = '-' then NextToken;
  1699.         GetMonth;
  1700.         NextToken;
  1701.         if Token = '-' then NextToken;
  1702.         Year := TokenInt;
  1703.         if Year < 100 then Inc(Year, 1900);
  1704.         NextToken;
  1705.         GetTime;
  1706.       end;
  1707.       Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Sec, 0);
  1708.     finally
  1709.       Free;
  1710.     end;
  1711.   finally
  1712.     StringStream.Free;
  1713.   end;
  1714. end;
  1715.  
  1716. procedure ExtractHeaderFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  1717.   Strings: TStrings; Decode: Boolean; StripQuotes: Boolean = False);
  1718. var
  1719.   Head, Tail: PChar;
  1720.   EOS, InQuote, LeadQuote: Boolean;
  1721.   QuoteChar: Char;
  1722.  
  1723.   function DoStripQuotes(const S: string): string;
  1724.   var
  1725.     I: Integer;
  1726.   begin
  1727.     Result := S;
  1728.     if StripQuotes then
  1729.       for I := Length(Result) downto 1 do
  1730.         if Result[I] in ['''', '"'] then
  1731.           Delete(Result, I, 1);
  1732.   end;
  1733.  
  1734. begin
  1735.   if (Content = nil) or (Content^ = #0) then Exit;
  1736.   Tail := Content;
  1737.   InQuote := False;
  1738.   QuoteChar := #0;
  1739.   repeat
  1740.     while Tail^ in WhiteSpace + [#13, #10] do Inc(Tail);
  1741.     Head := Tail;
  1742.     LeadQuote := False;
  1743.     while True do
  1744.     begin
  1745.       while (InQuote and (Tail^ <> '"')) or
  1746.         not (Tail^ in Separators + [#0, #13, #10, '"']) do Inc(Tail);
  1747.       if Tail^ = '"' then
  1748.       begin
  1749.         if (QuoteChar <> #0) and (QuoteChar = Tail^) then
  1750.           QuoteChar := #0
  1751.         else
  1752.         begin
  1753.           LeadQuote := Head = Tail;
  1754.           QuoteChar := Tail^;
  1755.           if LeadQuote then Inc(Head);
  1756.         end;
  1757.         InQuote := QuoteChar <> #0;
  1758.         if InQuote then
  1759.           Inc(Tail)
  1760.         else Break;
  1761.       end else Break;
  1762.     end;
  1763.     if not LeadQuote and (Tail^ <> #0) and (Tail^ = '"') then
  1764.       Inc(Tail);
  1765.     EOS := Tail^ = #0;
  1766.     Tail^ := #0;
  1767.     if Head^ <> #0 then
  1768.       if Decode then
  1769.         Strings.Add(DoStripQuotes(HTTPDecode(Head)))
  1770.       else Strings.Add(DoStripQuotes(Head));
  1771.     Inc(Tail);
  1772.   until EOS;
  1773. end;
  1774.  
  1775. procedure ExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  1776.   Strings: TStrings; StripQuotes: Boolean = False);
  1777. begin
  1778.   ExtractHeaderFields(Separators, WhiteSpace, Content, Strings, True, StripQuotes);
  1779. end;
  1780.  
  1781. function StatusString(StatusCode: Integer): string;
  1782. begin
  1783.   case StatusCode of
  1784.     100: Result := 'Continue';
  1785.     101: Result := 'Switching Protocols';
  1786.     200: Result := 'OK';
  1787.     201: Result := 'Created';
  1788.     202: Result := 'Accepted';
  1789.     203: Result := 'Non-Authoritative Information';
  1790.     204: Result := 'No Content';
  1791.     205: Result := 'Reset Content';
  1792.     206: Result := 'Partial Content';
  1793.     300: Result := 'Multiple Choices';
  1794.     301: Result := 'Moved Permanently';
  1795.     302: Result := 'Moved Temporarily';
  1796.     303: Result := 'See Other';
  1797.     304: Result := 'Not Modified';
  1798.     305: Result := 'Use Proxy';
  1799.     400: Result := 'Bad Request';
  1800.     401: Result := 'Unauthorized';
  1801.     402: Result := 'Payment Required';
  1802.     403: Result := 'Forbidden';
  1803.     404: Result := 'Not Found';
  1804.     405: Result := 'Method Not Allowed';
  1805.     406: Result := 'None Acceptable';
  1806.     407: Result := 'Proxy Authentication Required';
  1807.     408: Result := 'Request Timeout';
  1808.     409: Result := 'Conflict';
  1809.     410: Result := 'Gone';
  1810.     411: Result := 'Length Required';
  1811.     412: Result := 'Unless True';
  1812.     500: Result := 'Internal Server Error';
  1813.     501: Result := 'Not Implemented';
  1814.     502: Result := 'Bad Gateway';
  1815.     503: Result := 'Service Unavailable';
  1816.     504: Result := 'Gateway Timeout';
  1817.   else
  1818.     Result := '';
  1819.   end
  1820. end;
  1821.  
  1822. function TranslateChar(const Str: string; FromChar, ToChar: Char): string;
  1823. var
  1824.   I: Integer;
  1825. begin
  1826.   Result := Str;
  1827.   for I := 1 to Length(Result) do
  1828.     if Result[I] = FromChar then
  1829.       Result[I] := ToChar;
  1830. end;
  1831.  
  1832. function UnixPathToDosPath(const Path: string): string;
  1833. begin
  1834.   Result := TranslateChar(Path, '/', '\');
  1835. end;
  1836.  
  1837. function DosPathToUnixPath(const Path: string): string;
  1838. begin
  1839.   Result := TranslateChar(Path, '\', '/');
  1840. end;
  1841.  
  1842. function MonthStr(DateTime: TDateTime): string;
  1843. var
  1844.   Year, Month, Day: Word;
  1845. begin
  1846.   DecodeDate(DateTime, Year, Month, Day);
  1847.   Result := Months[Month];
  1848. end;
  1849.  
  1850. function DayOfWeekStr(DateTime: TDateTime): string;
  1851. begin
  1852.   Result := DaysOfWeek[DayOfWeek(DateTime)];
  1853. end;
  1854.  
  1855. end.
  1856.