path: root/packages/fcl-web/src/fphtml.pp

{
    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit fphtml; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, htmlelements, htmlwriter, httpdefs, fphttp, DB, DOM, contnrs;

type
  THtmlEntities = (heHtml,heBody,heHead,heDiv,heParagraph);

const
  THtmlEntitiesClasses : array[THtmlEntities] of THTMLElementClass =
    (THTML_html, THTML_body, THTML_head, THTML_div, THTML_p);

type

  { TJavaScriptStack }
  TWebButtonType = (btOk, btCancel, btCustom);
  TWebButton = record
    ButtonType: TWebButtonType;
    Caption: String;
    OnClick: String;
  end;
  TWebButtons = array of TWebButton;

  TMessageBoxHandler = function(Sender: TObject; AText: String; Buttons: TWebButtons): string of object;
  TWebController = class;
  THTMLContentProducer = class;

  TJavaScriptStack = class(TObject)
  private
    FMessageBoxHandler: TMessageBoxHandler;
    FScript: TStrings;
    FWebController: TWebController;
  protected
    function GetWebController: TWebController;
  public
    constructor Create(const AWebController: TWebController); virtual;
    destructor Destroy; override;
    procedure AddScriptLine(ALine: String); virtual;
    procedure MessageBox(AText: String; Buttons: TWebButtons); virtual;
    procedure RedrawContentProducer(AContentProducer: THTMLContentProducer); virtual;
    procedure CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = ''); virtual;
    procedure Clear; virtual;
    function ScriptIsEmpty: Boolean; virtual;
    function GetScript: String; virtual;
    property WebController: TWebController read GetWebController;
  end;

  { TWebController }

  TWebController = class(TComponent)
  private
    FBaseURL: string;
    FMessageBoxHandler: TMessageBoxHandler;
    FScriptName: string;
    procedure SetBaseURL(const AValue: string);
    procedure SetScriptName(const AValue: string);
  protected
    function GetScriptFileReferences: TStringList; virtual; abstract;
    function GetCurrentJavaScriptStack: TJavaScriptStack; virtual; abstract;
    function GetScripts: TFPObjectList; virtual; abstract;
    function GetRequest: TRequest;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddScriptFileReference(AScriptFile: String); virtual; abstract;
    function InitializeJavaScriptStack: TJavaScriptStack; virtual; abstract;
    function HasJavascriptStack: boolean; virtual; abstract;
    function GetUrl(ParamNames, ParamValues, KeepParams: array of string; Action: string = ''): string; virtual; abstract;
    procedure InitializeAjaxRequest; virtual;
    procedure InitializeShowRequest; virtual;
    procedure FreeJavascriptStack; virtual; abstract;
    procedure BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string); virtual; abstract;
    function MessageBox(AText: String; Buttons: TWebButtons): string; virtual;
    function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons): string; virtual; abstract;
    function CreateNewScript: TStringList; virtual; abstract;
    property ScriptFileReferences: TStringList read GetScriptFileReferences;
    property Scripts: TFPObjectList read GetScripts;
    property CurrentJavaScriptStack: TJavaScriptStack read GetCurrentJavaScriptStack;
    property MessageBoxHandler: TMessageBoxHandler read FMessageBoxHandler write FMessageBoxHandler;
  published
    property BaseURL: string read FBaseURL write SetBaseURL;
    property ScriptName: string read FScriptName write SetScriptName;
  end;

  { TAjaxResponse }

  TAjaxResponse= class(TObject)
  private
    FJavascriptCallStack: TJavaScriptStack;
    FResponse: TResponse;
    FSendXMLAnswer: boolean;
    FXMLAnswer: TXMLDocument;
    FRootNode: TDOMNode;
    function GetXMLAnswer: TXMLDocument;
  public
    constructor Create(AWebController: TWebController; AResponse: TResponse); virtual;
    destructor Destroy; override;
    procedure BindToResponse; virtual;
    property Response: TResponse read FResponse;
    property XMLAnswer: TXMLDocument read GetXMLAnswer;
    property SendXMLAnswer: boolean read FSendXMLAnswer;
    property JavascriptCallStack: TJavaScriptStack read FJavascriptCallStack;
  end;

  TCSAjaxEvent=procedure(Sender: TComponent; AJavascriptClass: TJavaScriptStack; var Handled: boolean) of object;
  THandleAjaxEvent = procedure(Sender: TObject; ARequest: TRequest; AnAjaxResponse: TAjaxResponse) of object;

  TEventRecord = record
    csCallback: TCSAjaxEvent;
    ServerEvent: THandleAjaxEvent;
    ServerEventID: integer;
    JavaEventName: string;
  end;
  TEventRecords = array of TEventRecord;

  TForeachContentProducerProc = procedure(const AContentProducer: THTMLContentProducer) of object;

  IHTMLContentProducerContainer = interface
   ['{8B4D8AE0-4873-49BF-B677-D03C8A02CDA5}']
    procedure AddContentProducer(AContentProducer: THTMLContentProducer);
    procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
    function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
    function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
    procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
  end;

  { THTMLContentProducer }

  THTMLContentProducer = Class(THTTPContentProducer, IHTMLContentProducerContainer)
  private
    FDocument: THTMLDocument;
    FElement: THTMLCustomElement;
    FWriter: THTMLWriter;
    procedure SetDocument(const AValue: THTMLDocument);
    procedure SetWriter(const AValue: THTMLWriter);
  private
    // for streaming
    FChilds: TFPList; // list of THTMLContentProducer
    FParent: TComponent;
    function GetContentProducerList: TFPList;
    function GetContentProducers(Index: integer): THTMLContentProducer;
    procedure SetParent(const AValue: TComponent);
  Protected
    function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
  protected
    // Methods for streaming
    FAcceptChildsAtDesignTime: boolean;
    procedure SetParentComponent(Value: TComponent); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
    function GetEvents: TEventRecords; virtual;
    procedure AddEvent(var Events: TEventRecords; AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string; AcsCallBack: TCSAjaxEvent); virtual;
    procedure DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean); virtual;
    procedure SetupEvents(AHtmlElement: THtmlCustomElement); virtual;
    function GetWebController(const ExceptIfNotAvailable: boolean = true): TWebController;
    property ContentProducerList: TFPList read GetContentProducerList;
  public
    procedure BeforeGenerateContent; virtual;
    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; virtual;
    Function ProduceContent : String; override; // Here to test the output. Replace to protected after tests
    function GetParentComponent: TComponent; override;
    property ParentElement : THTMLCustomElement read FElement write FElement;
    property Writer : THTMLWriter read FWriter write SetWriter;
    Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
  public
    // for streaming
    constructor Create(AOwner: TComponent); override;
    destructor destroy; override;
    function HasParent: Boolean; override;
    function ChildCount: integer;
    procedure CleanupAfterRequest; virtual;
    procedure AddContentProducer(AContentProducer: THTMLContentProducer);
    procedure RemoveContentProducer(AContentProducer: THTMLContentProducer);
    function ExchangeContentProducers(Child1, Child2: THTMLContentProducer) : boolean;
    function MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer) : boolean;
    procedure HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse); virtual;
    procedure ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
    property Childs[Index: integer]: THTMLContentProducer read GetContentProducers;
    property AcceptChildsAtDesignTime: boolean read FAcceptChildsAtDesignTime;
    property parent: TComponent read FParent write SetParent;
  end;
  THTMLContentProducerClas = class of THTMLContentProducer;


  TWriterElementEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter; var anElement : THTMLCustomElement) of object;
  TAfterElementEvent = procedure (Sender:THTMLContentProducer; anElement : THTMLCustomElement) of object;
  TWriterEvent = procedure (Sender:THTMLContentProducer; aWriter : THTMLWriter) of object;
  TBooleanEvent = procedure (Sender:THTMLContentProducer; var flag : boolean) of object;

  { THTMLCustomEntityProducer }

  THTMLCustomEntityProducer = class (THTMLContentProducer)
  private
    FOnWriteEntity: TWriterEvent;
    FEntity: THtmlEntities;
  protected
    procedure DoWriteEntity (aWriter : THTMLWriter); virtual;
    Property OnWriteEntity : TWriterEvent read FOnWriteEntity write FOnWriteEntity;
    Property Entity : THtmlEntities read FEntity write FEntity default heHtml;
  public
    constructor Create(AOwner: TComponent); override;
    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
  end;

  { THTMLEntityContentProducer }

  THTMLEntityProducer = class (THTMLCustomEntityProducer)
  published
    Property OnWriteEntity;
    Property Entity;
  end;

  { THTMLCustomPageProducer }

  THTMLCustomPageProducer = class (THTMLCustomEntityProducer)
  private
    FHeaderProducer : THTMLContentProducer;
    FOnWriteHeader: TWriterEvent;
    FOnWriteVisualBody: TWriterEvent;
    FOnWriteVisualFooter: TWriterEvent;
    FOnWriteVisualHeader: TWriterEvent;
    FVisualHeaderProducer : THTMLContentProducer;
    FVisualBodyProducer : THTMLContentProducer;
    FVisualFooterProducer : THTMLContentProducer;
  protected
    procedure DoWriteEntity (aWriter : THTMLWriter); override;
    procedure DoWriteHeader (aWriter : THTMLWriter); virtual;
    procedure DoWriteVisualHeader (aWriter : THTMLWriter); virtual;
    procedure DoWriteVisualBody (aWriter : THTMLWriter); virtual;
    procedure DoWriteVisualFooter (aWriter : THTMLWriter); virtual;
    Property HeaderProducer : THTMLContentProducer read FHeaderProducer write FHeaderProducer;
    Property VisualHeaderProducer : THTMLContentProducer read FVisualHeaderProducer write FVisualHeaderProducer;
    Property VisualBodyProducer : THTMLContentProducer read FVisualBodyProducer write FVisualBodyProducer;
    Property VisualFooterProducer : THTMLContentProducer read FVisualFooterProducer write FVisualFooterProducer;
    Property OnWriteHeader : TWriterEvent read FOnWriteHeader write FOnWriteHeader;
    Property OnWriteVisualHeader : TWriterEvent read FOnWriteVisualHeader write FOnWriteVisualHeader;
    Property OnWriteVisualBody : TWriterEvent read FOnWriteVisualBody write FOnWriteVisualBody;
    Property OnWriteVisualFooter : TWriterEvent read FOnWriteVisualFooter write FOnWriteVisualFooter;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { THTMLPageProducer }

  THTMLPageProducer = class (THTMLCustomPageProducer)
  published
    property OnWriteHeader;
    property OnWriteVisualHeader;
    property OnWriteVisualBody;
    property OnWriteVisualFooter;
    Property HeaderProducer;
    Property VisualHeaderProducer;
    Property VisualBodyProducer;
    Property VisualFooterProducer;
  end;

  { THTMLCustomDatasetContentProducer }

  THTMLCustomDatasetContentProducer = class (THTMLContentProducer)
  private
    FDatasource: TDatasource;
    FOnWriteFooter: TWriterEvent;
    FOnWriteHeader: TWriterElementEvent;
    FOnWriteRecord: TWriterEvent;
    function WriteHeader (aWriter : THTMLWriter) : THTMLCustomElement;
    procedure WriteFooter (aWriter : THTMLWriter);
    procedure WriteRecord (aWriter : THTMLWriter);
  protected
    procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); virtual;
    procedure DoWriteFooter (aWriter : THTMLWriter); virtual;
    procedure DoWriteRecord (aWriter : THTMLWriter); virtual;
  public
    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
    Property OnWriteHeader : TWriterElementEvent read FOnWriteHeader write FOnWriteHeader;
    Property OnWriteFooter : TWriterEvent read FOnWriteFooter write FOnWriteFooter;
    Property OnWriteRecord : TWriterEvent read FOnWriteRecord write FOnWriteRecord;
  published
    Property DataSource : TDataSource read FDataSource write FDataSource;
  end;

  { THTMLDatasetContentProducer }

  THTMLDatasetContentProducer = class (THTMLCustomDatasetContentProducer)
  published
    Property OnWriteHeader;
    Property OnWriteFooter;
    Property OnWriteRecord;
  end;
  
  { THTMLSelectProducer }

  THTMLSelectProducer = class (THTMLContentProducer)
  private
    FControlName: string;
    FItems: TStrings;
    FjsOnChange: string;
    FPreSelected: string;
    FSize: integer;
    FUseValues: boolean;
    procedure SetItems(const AValue: TStrings);
  public
    constructor create (aOwner : TComponent); override;
    destructor destroy; override;
    function WriteContent (aWriter : THTMLWriter) : THTMLCustomElement; override;
  published
    property Items : TStrings read FItems write SetItems;
    property UseValues : boolean read FUseValues write FUseValues default false;
    property PreSelected : string read FPreSelected write FPreSelected;
    property Size : integer read FSize write FSize default 1;
    property ControlName : string read FControlName write FControlName;
    property jsOnChange: string read FjsOnChange write FjsOnChange;
  end;

  { THTMLDatasetSelectProducer }

  THTMLDatasetSelectProducer = class (THTMLCustomDatasetContentProducer)
  private
    FControlName: string;
    FIsPreSelected: TBooleanEvent;
    FItemField: string;
    FSize: integer;
    FValueField: string;
    FValue, FItem : TField;
    FPreSelected: string;
    FUseValues: boolean;
  protected
    procedure DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement); override;
    procedure DoWriteFooter (aWriter : THTMLWriter); override;
    procedure DoWriteRecord (aWriter : THTMLWriter); override;
  public
    constructor create (aOwner : TComponent); override;
  published
    property UseValues : boolean read FUseValues write FUseValues default false;
    property PreSelected : string read FPreSelected write FPreSelected;
    property ItemField : string read FItemField write FItemField;
    property ValueField : string read FValueField write FValueField;
    property OnIsPreSelected : TBooleanEvent read FIsPreSelected write FIsPreSelected;
    property Size : integer read FSize write FSize;
    property ControlName : string read FControlName write FControlName;
    property OnWriteHeader;
  end;
  
  { THTMLDataModule }
  THTMLGetContentEvent = Procedure (Sender : TObject; ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean) of object;
  TCreateDocumentEvent = Procedure(Sender : TObject; var ADocument : THTMLDocument) of object;
  TCreateWriterEvent = Procedure(Sender : TObject; ADocument : THTMLDocument; Var AWriter : THTMLWriter) of object;

  { THTMLContentAction }

  THTMLContentAction = Class(TCustomWebAction)
  private
    FOnGetContent: THTMLGetContentEvent;
  Public
    Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
  Published
    Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
  end;
  
  { THTMLContentActions }

  THTMLContentActions = Class(TCustomWebActions)
    Procedure HandleRequest(ARequest : TRequest; HTMLPage : THTMLWriter; Var Handled : Boolean);
  end;

  { TCustomHTMLDataModule }

  { TCustomHTMLModule }

  TCustomHTMLModule = Class(TCustomHTTPModule)
  private
    FDocument : THTMLDocument;
    FActions: THTMLContentActions;
    FOnCreateDocument: TCreateDocumentEvent;
    FOnCreateWriter: TCreateWriterEvent;
    FOnGetContent: THTMLGetContentEvent;
    procedure SetActions(const AValue: THTMLContentActions);
  Protected
    Function CreateWriter(ADocument : THTMLDocument) : THTMLWriter;
    Function CreateDocument : THTMLDocument;
    Property OnGetContent : THTMLGetContentEvent Read FOnGetContent Write FOnGetContent;
    Property Actions : THTMLContentActions Read FActions Write SetActions;
    Property OnCreateDocument : TCreateDocumentEvent Read FOnCreateDocument Write FOnCreateDocument;
    Property OnCreateWriter : TCreateWriterEvent Read FOnCreateWriter Write FOnCreateWriter;
  Public
    Constructor Create(AOwner : TComponent);override;
    Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
  end;
  
  TFPHTMLModule=Class(TCustomHTMLModule)
  Published
    Property OnGetContent;
    Property Actions;
    Property OnCreateDocument;
    Property OnCreateWriter;
  end;
  
  EHTMLError = Class(Exception);

const SimpleOkButton: array[0..0] of TWebButton = ((buttontype: btok;caption: 'Ok';onclick: ''));

implementation
Uses
{$ifdef cgidebug}
  dbugintf
{$endif cgidebug}
  webpage, XMLWrite;

resourcestring
  SErrRequestNotHandled = 'Web request was not handled by actions.';
  SErrNoContentProduced = 'The content producer "%s" didn''t produce any content.';

{ TJavaScriptStack }

function TJavaScriptStack.GetWebController: TWebController;
begin
  result := FWebController;
end;

constructor TJavaScriptStack.Create(const AWebController: TWebController);
begin
  FWebController := AWebController;
  FScript := TStringList.Create;
end;

destructor TJavaScriptStack.Destroy;
begin
  FScript.Free;
  inherited Destroy;
end;

procedure TJavaScriptStack.AddScriptLine(ALine: String);
begin
  FScript.Add(ALine);
end;

procedure TJavaScriptStack.MessageBox(AText: String; Buttons: TWebButtons);
begin
  AddScriptLine(WebController.MessageBox(AText,Buttons));
end;

procedure TJavaScriptStack.RedrawContentProducer(AContentProducer: THTMLContentProducer);
begin
  raise exception.Create('RedrawContentProducer not supported by current WebController');
end;

procedure TJavaScriptStack.CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = '');
begin
  raise exception.Create('SendServerEvent not supported by current WebController');
end;

procedure TJavaScriptStack.Clear;
begin
  FScript.Clear;
end;

function TJavaScriptStack.ScriptIsEmpty: Boolean;
begin
  result := FScript.Count=0;
end;

function TJavaScriptStack.GetScript: String;
begin
  result := FScript.Text;
end;


{ THTMLContentProducer }

procedure THTMLContentProducer.SetWriter(const AValue: THTMLWriter);
begin
  FWriter := AValue;
  if not assigned (FDocument) then
    FDocument := AValue.Document
  else if FDocument <> AValue.Document then
    AValue.document := FDocument;
end;

procedure THTMLContentProducer.SetDocument(const AValue: THTMLDocument);
begin
  FDocument := AValue;
  if assigned (FWriter) and (AValue <> FWriter.Document) then
    FWriter.Document := AValue;
end;

procedure THTMLContentProducer.SetParent(const AValue: TComponent);
begin
  if FParent=AValue then exit;
  if FParent<>nil then
    (FParent as IHTMLContentProducerContainer).RemoveContentProducer(Self);
  FParent:=AValue;
  if FParent<>nil then
    (FParent as IHTMLContentProducerContainer).AddContentProducer(Self);
end;

function THTMLContentProducer.GetContentProducers(Index: integer): THTMLContentProducer;
begin
  Result:=THTMLContentProducer(ContentProducerList[Index]);
end;

function THTMLContentProducer.GetContentProducerList: TFPList;
begin
  if not assigned(FChilds) then
    fchilds := tfplist.Create;
  Result := FChilds;
end;

function THTMLContentProducer.ProduceContent: String;
var WCreated, created : boolean;
    el : THtmlCustomElement;
begin
  created := not assigned (FDocument);
  if created then
    FDocument := THTMLDocument.Create;
  try
    WCreated := not assigned(FWriter);
    if WCreated then
      FWriter := CreateWriter (FDocument);
    try
      FWriter.CurrentElement := ParentElement;
      el := WriteContent (FWriter);
      if not assigned(el) then
        Raise EHTMLError.CreateFmt(SErrNoContentProduced,[Self.Name]);
      ForeachContentProducer(@DoBeforeGenerateContent,True);
      result := el.asstring;
    finally
      if WCreated then
        FreeAndNil(FWriter);
    end;
  finally
    if created then
      FreeAndNil(FDocument);
  end;
end;

constructor THTMLContentProducer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAcceptChildsAtDesignTime:=True;
end;

destructor THTMLContentProducer.destroy;
begin
  Parent:=nil;
  while ChildCount>0 do Childs[ChildCount-1].Free;
  FreeAndNil(FChilds);
  inherited destroy;
end;

function THTMLContentProducer.GetEvents: TEventRecords;
begin
  result := nil;
end;

procedure THTMLContentProducer.AddEvent(var Events: TEventRecords;
  AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string;
  AcsCallBack: TCSAjaxEvent);
begin
  SetLength(Events,length(Events)+1);
  with Events[high(Events)] do
    begin
    ServerEvent:=AServerEvent;
    ServerEventID:=AServerEventID;
    JavaEventName:=AJavaEventName;
    csCallback:=AcsCallBack;
    end;
end;

procedure THTMLContentProducer.DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean);
begin
  if assigned(AnEvent.csCallback) then
    AnEvent.csCallback(self, AJavascriptStack, Handled);
end;

procedure THTMLContentProducer.SetupEvents(AHtmlElement: THtmlCustomElement);
var AJSClass: TJavaScriptStack;
    wc: TWebController;
    Handled: boolean;
    Events: TEventRecords;
    i: integer;
begin
  Events := GetEvents;
  if length(Events)>0 then
    begin
    wc := GetWebController(false);
    if assigned(wc) then
      begin
      AJSClass := wc.InitializeJavaScriptStack;
      try
        for i := 0 to high(Events) do
          begin
          Handled:=false;
          DoOnEventCS(events[i],AJSClass, Handled);
          if not handled and assigned(events[i].ServerEvent) then
            AJSClass.CallServerEvent(self,events[i].ServerEventID);
          wc.BindJavascriptCallstackToElement(Self, AHtmlElement,events[i].JavaEventName);
          AJSClass.clear;
          end;
      finally
        wc.FreeJavascriptStack;
      end;
      end
    else
      begin
      for i := 0 to high(Events) do if assigned(events[i].csCallback) or assigned(events[i].ServerEvent) then
        raise exception.Create('There is no webcontroller available, which is necessary to use events.');
      end;
    end;
end;

function THTMLContentProducer.GetWebController(const ExceptIfNotAvailable: boolean): TWebController;
var i : integer;
begin
  result := nil;
  if assigned(owner)  then
    begin
    if (owner is TWebPage) and TWebPage(owner).HasWebController then
      begin
      result := TWebPage(owner).WebController;
      exit;
      end
    else //if (owner is TDataModule) then
      begin
      for i := 0 to owner.ComponentCount-1 do if owner.Components[i] is TWebController then
        begin
        result := TWebController(Owner.Components[i]);
        Exit;
        end;
      end;
    end;
  if ExceptIfNotAvailable then
    raise Exception.Create('No webcontroller available');
end;

procedure THTMLContentProducer.BeforeGenerateContent;
begin
  // do nothing
end;

function THTMLContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
var i: integer;
begin
  for i := 0 to ChildCount-1 do
    if Childs[i] is THTMLContentProducer then
      result := THTMLContentProducer(Childs[i]).WriteContent(aWriter);
end;

function THTMLContentProducer.ChildCount: integer;
begin
  if assigned(FChilds) then
    result := FChilds.Count
  else
    result := 0;
end;

procedure THTMLContentProducer.CleanupAfterRequest;
begin
  // Do Nothing
end;

procedure THTMLContentProducer.AddContentProducer(AContentProducer: THTMLContentProducer);
begin
  ContentProducerList.Add(AContentProducer);
end;

procedure THTMLContentProducer.RemoveContentProducer(AContentProducer: THTMLContentProducer);
begin
  ContentProducerList.Remove(AContentProducer);
end;

function THTMLContentProducer.ExchangeContentProducers(Child1, Child2: THTMLContentProducer): boolean;
var ChildIndex1, ChildIndex2: integer;
begin
  result := false;
  ChildIndex1:=GetContentProducerList.IndexOf(Child1);
  if (ChildIndex1=-1) then
    Exit;
  ChildIndex2:=GetContentProducerList.IndexOf(Child2);
  if (ChildIndex2=-1) then
    Exit;
  GetContentProducerList.Exchange(ChildIndex1,ChildIndex2);
  result := true;
end;

function THTMLContentProducer.MoveContentProducer(MoveElement, MoveBeforeElement: THTMLContentProducer): boolean;
var ChildIndex1, ChildIndex2: integer;
begin
  result := false;
  ChildIndex1:=GetContentProducerList.IndexOf(MoveElement);
  if (ChildIndex1=-1) then
    Exit;
  ChildIndex2:=GetContentProducerList.IndexOf(MoveBeforeElement);
  if (ChildIndex2=-1) then
    Exit;
  GetContentProducerList.Move(ChildIndex1,ChildIndex2);
  result := true;
end;

procedure THTMLContentProducer.HandleAjaxRequest(ARequest: TRequest; AnAjaxResponse: TAjaxResponse);
begin
  // Do nothing
end;

procedure THTMLContentProducer.ForeachContentProducer(AForeachChildsProc: TForeachContentProducerProc; Recursive: boolean);
var i : integer;
    tmpChild: THTMLContentProducer;
begin
  for i := 0 to ChildCount -1 do
    begin
    tmpChild := Childs[i];
    AForeachChildsProc(tmpChild);
    if recursive then
      tmpChild.ForeachContentProducer(AForeachChildsProc,Recursive);
    end;
end;

function THTMLContentProducer.CreateWriter (Doc : THTMLDocument): THTMLWriter;
begin
  FDocument := Doc;
  result := THTMLWriter.Create (Doc);
end;

procedure THTMLContentProducer.SetParentComponent(Value: TComponent);
begin
  if Supports(Value,IHTMLContentProducerContainer) then
    Parent:=Value;
end;

function THTMLContentProducer.HasParent: Boolean;
begin
  Result:=FParent<>nil;
end;

function THTMLContentProducer.GetParentComponent: TComponent;
begin
  Result:=TComponent(Parent);
end;

procedure THTMLContentProducer.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  i: Integer;
begin
  for i:=0 to ChildCount-1 do
    if Childs[i].Owner=Root then
      Proc(Childs[i]);
end;

procedure THTMLContentProducer.DoBeforeGenerateContent(const AContentProducer: THTMLContentProducer);
begin
  AContentProducer.BeforeGenerateContent;
end;

{ THTMLCustomDatasetContentProducer }

function THTMLCustomDatasetContentProducer.WriteHeader(aWriter: THTMLWriter): THTMLCustomElement;
var el : THTmlCustomElement;
begin
  el := nil;
  DoWriteHeader (aWriter, el);
  result := el;
end;

procedure THTMLCustomDatasetContentProducer.WriteFooter(aWriter: THTMLWriter);
begin
  DoWriteFooter (aWriter);
end;

procedure THTMLCustomDatasetContentProducer.WriteRecord(aWriter: THTMLWriter);
begin
  DoWriteRecord (aWriter);
end;

function THTMLCustomDatasetContentProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
var opened : boolean;
begin
  if assigned (FDataSource) and assigned(datasource.dataset) then
    begin
    result := WriteHeader (aWriter);
    try
        with FDataSource.dataset do
          try
            opened := Active;
            if not opened then
              Open;
            first;
            while not eof do
              begin
              WriteRecord(aWriter);
              next;
              end;
          finally
            if not opened then
              close;
          end;
    finally
      WriteFooter (aWriter);
    end;
    end;
end;

procedure THTMLCustomDatasetContentProducer.DoWriteHeader(aWriter: THTMLWriter; var el : THTMLCustomElement);
begin
  if assigned (FOnWriteHeader) then
    FOnWriteHeader (self, aWriter, el);
end;

procedure THTMLCustomDatasetContentProducer.DoWriteFooter(aWriter: THTMLWriter);
begin
  if assigned (FOnWriteFooter) then
    FOnWriteFooter (self, aWriter);
end;

procedure THTMLCustomDatasetContentProducer.DoWriteRecord(aWriter: THTMLWriter);
begin
  if assigned (FOnWriteRecord) then
    FOnWriteRecord (self, aWriter);
end;

{ THTMLSelectProducer }

procedure THTMLSelectProducer.SetItems(const AValue: TStrings);
begin
  if FItems<>AValue then
    FItems.assign(AValue);
end;

function THTMLSelectProducer.WriteContent(aWriter: THTMLWriter): THTMLCustomElement;
begin
  result := aWriter.FormSelect(FControlName, FPreselected, FSize, FItems, FUseValues);
  THTML_select(result).onchange:=FjsOnChange;
end;

constructor THTMLSelectProducer.create(aOwner: TComponent);
begin
  inherited create (aOwner);
  FUseValues := False;
  FItems := TStringlist.Create;
  size := 1;
end;

destructor THTMLSelectProducer.destroy;
begin
  FItems.Free;
  inherited;
end;

{ THTMLDatasetSelectProducer }

procedure THTMLDatasetSelectProducer.DoWriteHeader (aWriter : THTMLWriter; var el : THTMLCustomElement);
var s : THTML_Select;
begin
  s := aWriter.StartSelect;
  s.size := IntToStr(FSize);
  s.name := FControlName;
  el := s;
  if FValueField <> '' then
    FValue := datasource.dataset.findfield (FValueField);
  if FItemField <> '' then
    FItem := DataSource.dataset.findfield (FItemField);
  inherited DoWriteHeader(aWriter, el);
end;

procedure THTMLDatasetSelectProducer.DoWriteFooter(aWriter: THTMLWriter);
begin
  inherited DoWriteFooter(aWriter);
  aWriter.EndSelect;
end;

procedure THTMLDatasetSelectProducer.DoWriteRecord(aWriter: THTMLWriter);
var sel : boolean;
begin
  if assigned (FItem) then
    with aWriter.Option(FItem.asstring) do
      begin
      if FUseValues then
        begin
        if assigned(FValue) then
          sel := (FValue.AsString = FPreSelected)
        end
      else if assigned(FItem) then
        sel := (FItem.AsString = FPreSelected);
      if assigned (FIsPreSelected) then
        FIsPreSelected (self, sel);
      selected := sel;
      if assigned (FValue) then
        Value := FValue.Asstring;
      end;
end;

constructor THTMLDatasetSelectProducer.create(aOwner: TComponent);
begin
  inherited create(aOwner);
  Size := 1;
  FUseValues := False;
end;

{ TCustomHTMLDataModule }

Function TCustomHTMLModule.CreateDocument : THTMLDocument;

begin
  If Assigned(FOnCreateDocument) then
    FOnCreateDocument(Self,Result);
  If (Result=Nil) then
    Result:=THTMLDocument.Create;
end;

constructor TCustomHTMLModule.Create(AOwner: TComponent);
begin
  FActions:=THTMLContentActions.Create(THTMLContentAction);
  inherited Create(AOwner);
end;

procedure TCustomHTMLModule.SetActions(const AValue: THTMLContentActions);
begin

end;

Function TCustomHTMLModule.CreateWriter(ADocument : THTMLDocument) : THTMLWriter;

begin
  If Assigned(FOnCreateWriter) then
    FOnCreateWriter(Self,ADocument,Result);
  if (Result=Nil) then
    Result:=THTMLWriter.Create(ADocument);
end;


procedure TCustomHTMLModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);

Var
  FWriter : THTMLWriter;
  B : Boolean;
  M : TMemoryStream;
  
begin
  FDocument := CreateDocument;
  Try
    FWriter:=CreateWriter(FDocument);
    Try
      B:=False;
      If Assigned(OnGetContent) then
        OnGetContent(Self,ARequest,FWriter,B);
      If Not B then
        Raise EHTMLError.Create(SErrRequestNotHandled);
      If (AResponse.ContentStream=Nil) then
        begin
        M:=TMemoryStream.Create;
        AResponse.ContentStream:=M;
        end;
      FDocument.SaveToStream(AResponse.ContentStream);
    Finally
      FreeAndNil(FWriter);
    end;
  Finally
    FreeAndNil(FDocument);
  end;
end;

{ THTMLContentActions }

procedure THTMLContentActions.HandleRequest(ARequest: TRequest;
  HTMLPage: THTMLWriter; var Handled: Boolean);
  
Var
  A : TCustomWebAction;

begin
{$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
  A:=GetRequestAction(ARequest);
  if Assigned(A) then
    (A as THTMLContentAction).HandleRequest(ARequest,HTMLPage,Handled);
{$ifdef cgidebug}SendMethodEnter('HTMLContentWebActions.handlerequest');{$endif cgidebug}
end;


{ THTMLContentAction }

procedure THTMLContentAction.HandleRequest(ARequest: TRequest;
  HTMLPage: THTMLWriter; var Handled: Boolean);
begin
  If Assigned(FOngetContent) then
    FOnGetContent(Self,ARequest,HTMLPage,Handled);
end;

{ THTMLCustomEntityProducer }

function THTMLCustomEntityProducer.WriteContent(aWriter: THTMLWriter
  ): THTMLCustomElement;
begin
  result := aWriter.StartElement(THtmlEntitiesClasses[FEntity]);
  DoWriteEntity(aWriter);
  inherited WriteContent(aWriter);
  aWriter.EndElement(THtmlEntitiesClasses[FEntity]);
end;

procedure THTMLCustomEntityProducer.DoWriteEntity(aWriter: THTMLWriter);
begin
  if assigned (FOnWriteEntity) then
    FOnWriteEntity (self, aWriter);
end;

constructor THTMLCustomEntityProducer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEntity := heHtml;
end;

{ THTMLCustomPageProducer }

procedure THTMLCustomPageProducer.DoWriteEntity(aWriter: THTMLWriter);
begin
  inherited DoWriteEntity(aWriter);
  DoWriteHeader(aWriter);
  aWriter.Startbody;
  DoWriteVisualHeader(aWriter);
  DoWriteVisualBody(aWriter);
  DoWriteVisualFooter(aWriter);
  awriter.Endbody;
end;

procedure THTMLCustomPageProducer.DoWriteHeader(aWriter: THTMLWriter);
begin
  if assigned(FOnWriteHeader) then
    FOnWriteHeader(self,aWriter);
  if assigned(FHeaderProducer) then
    aWriter.AddElement(FHeaderProducer.WriteContent(aWriter));
end;

procedure THTMLCustomPageProducer.DoWriteVisualHeader(aWriter: THTMLWriter);
begin
  if assigned(FOnWriteVisualHeader) then
    FOnWriteVisualHeader(self,aWriter);
  if assigned(FVisualHeaderProducer) then
    aWriter.AddElement(FVisualHeaderProducer.WriteContent(aWriter));
end;

procedure THTMLCustomPageProducer.DoWriteVisualBody(aWriter: THTMLWriter);
begin
  if assigned(FOnWriteVisualBody) then
    FOnWriteVisualBody(self,aWriter);
  if assigned(FVisualBodyProducer) then
    aWriter.AddElement(FVisualBodyProducer.WriteContent(aWriter));
end;

procedure THTMLCustomPageProducer.DoWriteVisualFooter(aWriter: THTMLWriter);
begin
  if assigned(FOnWriteVisualFooter) then
    FOnWriteVisualFooter(self,aWriter);
  if assigned(FVisualFooterProducer) then
    aWriter.AddElement(FVisualFooterProducer.WriteContent(aWriter));
end;

constructor THTMLCustomPageProducer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Entity := heHtml;
end;

{ TAjaxResponse }

function TAjaxResponse.GetXMLAnswer: TXMLDocument;
begin
  if not assigned(FXMLAnswer) then
    begin
    FXMLAnswer := TXMLDocument.create;
    FRootNode := FXMLAnswer.CreateElement('CallResponse');
    FXMLAnswer.Appendchild(FRootNode);
    end;
  result := FXMLAnswer;
end;

constructor TAjaxResponse.Create(AWebController: TWebController;
  AResponse: TResponse);
begin
  FSendXMLAnswer:=true;
  FResponse:=AResponse;
  FJavascriptCallStack:=AWebController.InitializeJavaScriptStack;
end;

destructor TAjaxResponse.Destroy;
begin
  FXMLAnswer.Free;
  FJavascriptCallStack.Free;
  inherited Destroy;
end;

procedure TAjaxResponse.BindToResponse;
var SubNode: TDOMNode;
begin
  if SendXMLAnswer then
    begin
    SubNode := XMLAnswer.CreateElement('ExecScript');
    FRootNode.Appendchild(SubNode);
    SubNode.Appendchild(XMLAnswer.CreateTextNode(FJavascriptCallStack.GetScript));

    Response.ContentStream := TMemoryStream.Create;
    Response.ContentType:='text/xml';
    writeXMLFile(XMLAnswer,Response.ContentStream);
    end;
end;

{ TWebController }

procedure TWebController.SetBaseURL(const AValue: string);
begin
  if FBaseURL=AValue then exit;
  FBaseURL:=AValue;
end;

procedure TWebController.SetScriptName(const AValue: string);
begin
  if FScriptName=AValue then exit;
  FScriptName:=AValue;
end;

procedure TWebController.InitializeAjaxRequest;
begin
  // do nothing
end;

procedure TWebController.InitializeShowRequest;
begin
  // do nothing
end;

function TWebController.MessageBox(AText: String; Buttons: TWebButtons): string;
begin
  if assigned(MessageBoxHandler) then
    result := MessageBoxHandler(self,AText,Buttons)
  else
    result := DefaultMessageBoxHandler(self,AText,Buttons);
end;

function TWebController.GetRequest: TRequest;
begin
  if assigned(Owner) and (owner is TWebPage) then
    result := TWebPage(Owner).Request
  else
    result := nil;
end;

constructor TWebController.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { TODO : Do this prperly using a notification. And make the WebController property readonly }
  if owner is TWebPage then TWebPage(Owner).WebController := self;
end;

destructor TWebController.Destroy;
begin
  if (Owner is TWebPage) and (TWebPage(Owner).WebController=self) then
    TWebPage(Owner).WebController := nil;
  inherited Destroy;
end;


end.