source: trunk/Packages/CoolWeb/Common/HtmlClasses.pas

unit HtmlClasses;

interface

uses
  XmlClasses, Classes, SysUtils, Generics.Collections, Generics, IpAddress;

type
  { TURL }

  TURL = class(TPersistent)
  private
    function GetAsString: string;
    procedure SetAsString(Value: string);
  public
    Scheme: string;
    UserName: string;
    Password: string;
    Host: THostAddress;
    Port: Word;
    Path: string;
    Query: string;
    Fragment: string;
    constructor Create;
    destructor Destroy; override;
    property AsString: string read GetAsString write SetAsString;
  end;

  { THtmlElement }

  THtmlElement = class
  protected
    function GetAsXmlElement: TXmlElement; virtual;
  public
    Id: string;
    Name: string;
    ClassId: string;
    Style: string;
    procedure Assign(Source: THtmlElement); virtual;
    property AsXmlElement: TXmlElement read GetAsXmlElement;
  end;

  THtmlString = class;
  THtmlBlock = class;
  THtmlList = class;
  THtmlInput = class;

  { THtmlElements }

  THtmlElements = class(TObjectList<THtmlElement>)
    function AddString(Text: string = ''): THtmlString;
    function AddBlock: THtmlBlock;
    function AddList: THtmlList;
    function AddInput: THtmlInput;
  end;

  TBlockType = (btNoTag, btBlockLevel, btInline);

  { THtmlString }

  THtmlString = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Text: string;
    procedure Assign(Source: THtmlElement); override;
  end;

  { THtmlLineBreak }

  THtmlLineBreak = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    constructor Create;
  end;

  THtmlBlock = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    BlockType: TBlockType;
    SubItems: THtmlElements;
    constructor Create;
    destructor Destroy; override;
  end;

  TListType = (ltUnordered, ltOrdered);

  { THtmlList }

  THtmlList = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    ListType: TListType;
    SubItems: THtmlElements;
    constructor Create;
    destructor Destroy; override;
  end;

  THtmlLink = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Target: TURL;
    Content: THtmlElement;
    constructor Create;
    destructor Destroy; override;
  end;

  TSizeUnits = (suPixels, suPercents);

  THtmlSize = record
    Width: Integer;
    Height: Integer;
    Units: TSizeUnits;
  end;

  THtmlImage = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Size: THtmlSize;
    Source: TURL;
    AlternateText: string;
    constructor Create;
    destructor Destroy; override;
  end;

  THtmlInputType = (itText, itComboBox, itRadioButton, itReset, itPassword,
    itSubmit, itHidden, itFileSelect, itButton, itCheckBox);

  { THtmlInput }

  THtmlInput = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    InputType: THtmlInputType;
    Value: Variant;
    ItemName: string;
    procedure Assign(Source: THtmlElement); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { THtmlForm }

  THtmlForm = class(THtmlBlock)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Method: string;
    Action: TURL;
    constructor Create;
    destructor Destroy; override;
  end;

  THtmlDocument = class
  private
    function GetAsXmlDocument: TXmlDocument;
  public
    Title: string;
    ContentEncoding: string;
    ContentLanguage: string;
    Body: THtmlBlock;
    Styles: TStringList;
    Scripts: TStringList;
    FavIcon: string;
    property AsXmlDocument: TXmlDocument read GetAsXmlDocument;
    constructor Create;
    destructor Destroy; override;
  end;

  { THtmlCell }

  THtmlCell = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    RowSpan: Integer;
    ColSpan: Integer;
    Value: THtmlElement;
    constructor Create;
    destructor Destroy; override;
  end;

  { THtmlCells }

  THtmlCells = class(TObjectList<THtmlCell>)
    function AddCell: THtmlCell;
  end;

  { THtmlRow }

  THtmlRow = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Cells: THtmlCells;
    constructor Create;
    destructor Destroy; override;
  end;

  { THtmlRows }

  THtmlRows = class(TObjectList<THtmlRow>)
    function AddRow: THtmlRow;
  end;

  { THtmlTable }

  THtmlTable = class(THtmlElement)
  protected
    function GetAsXmlElement: TXmlElement; override;
  public
    Rows: THtmlRows;
    constructor Create;
    destructor Destroy; override;
  end;

  { TQueryString }

  TQueryString = class
    Data: TStringList;
    procedure SetStringServer;
    procedure SetString(QueryString: string);
    function GetString: string;
    constructor Create;
    destructor Destroy; override;
  end;


implementation

function LeftCutString(var Source, Output: string; Delimiter: string; Allowed: string = ''): Boolean;
var
  I, J: Integer;
  Matched: Boolean;
begin
  I := 1;
  Matched := True;
  while (I < Length(Source)) and Matched do begin
    Matched := False;
    if (Source[I] >= 'A') and (Source[I] <= 'Z') then Matched := True;
    if (Source[I] >= 'a') and (Source[I] <= 'z') then Matched := True;
    if (Source[I] >= '0') and (Source[I] <= '9') then Matched := True;
    for J := 1 to Length(Allowed) do
      if Source[I] = Allowed[J] then Matched := True;
    if Matched then Inc(I);
  end;
  if (Delimiter = Copy(Source, I, Length(Delimiter))) or (I = Length(Source)) then begin
    Output := Copy(Source, 1, I-1);
    Delete(Source, 1, Length(Output) + Length(Delimiter));
    Result := True;
  end else begin
    Output := '';
    Result := False;
  end;
end;

function RightCutString(var Source, Output: string; Delimiter: string; Allowed: string = ''): Boolean;
var
  I, J: Integer;
  Matched: Boolean;
begin
  I := Length(Source);
  Matched := True;
  while (I > 0) and Matched do begin
    Matched := False;
    if (Source[I] >= 'A') and (Source[I] <= 'Z') then Matched := True;
    if (Source[I] >= 'a') and (Source[I] <= 'z') then Matched := True;
    if (Source[I] >= '0') and (Source[I] <= '9') then Matched := True;
    for J := 1 to Length(Allowed) do
      if Source[I] = Allowed[J] then Matched := True;
    if Matched then Dec(I);
  end;
  if (Delimiter = Copy(Source, I - Length(Delimiter) + 1, Length(Delimiter))) or (I = 0) then begin
    Output := Copy(Source, I+1, Length(Source) - I);
    Delete(Source, I, Length(Output) + Length(Delimiter));
    Result := True;
  end else begin
    Output := '';
    Result := False;
  end;
end;

{ THtmlCells }

function THtmlCells.AddCell: THtmlCell;
begin
  Result := THtmlCell.Create;
  Add(Result);
end;

{ THtmlRows }

function THtmlRows.AddRow: THtmlRow;
begin
  Result := THtmlRow.Create;
  Add(Result);
end;

{ THtmlList }

function THtmlList.GetAsXmlElement: TXmlElement;
var
  I: Integer;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    case ListType of
      ltOrdered: Name := 'ol';
      ltUnordered: Name := 'ul';
    end;
    for I := 0 to SubItems.Count - 1 do begin
      with SubElements.AddTag('li') do
        SubElements.Add(SubItems[I].AsXmlElement);
    end;
  end;
end;

constructor THtmlList.Create;
begin
  inherited;
  SubItems := THtmlElements.Create;
end;

destructor THtmlList.Destroy;
begin
  FreeAndNil(SubItems);
  inherited;
end;

{ THtmlElements }

function THtmlElements.AddString(Text: string = ''): THtmlString;
begin
  Result := THtmlString.Create;
  Result.Text := Text;
  Add(Result);
end;

function THtmlElements.AddBlock: THtmlBlock;
begin
  Result := THtmlBlock.Create;
  Add(Result);
end;

function THtmlElements.AddList: THtmlList;
begin
  Result := THtmlList.Create;
  Add(Result);
end;

function THtmlElements.AddInput: THtmlInput;
begin
  Result := THtmlInput.Create;
  Add(Result);
end;

{ THtmlCell }

function THtmlCell.GetAsXmlElement: TXmlElement;
begin
  Result := inherited GetAsXmlElement;
  TXmlTag(Result).Name := 'td';
  with TXmlTag(Result).Attributes do begin
    if ColSpan > 1 then Add('colspan', IntToStr(ColSpan));
    if RowSpan > 1 then Add('rowspan', IntToStr(RowSpan));
  end;
  TXmlTag(Result).SubElements.Add(Value.AsXmlElement);
end;

constructor THtmlCell.Create;
begin
  ColSpan := 1;
  RowSpan := 1;
end;

destructor THtmlCell.Destroy;
begin
  FreeAndNil(Value);
  inherited;
end;

{ THtmlRow }

function THtmlRow.GetAsXmlElement: TXmlElement;
var
  Column: Integer;
begin
  Result := inherited GetAsXmlElement;
  TXmlTag(Result).Name := 'tr';
  for Column := 0 to Cells.Count - 1 do
    TXmlTag(Result).SubElements.Add(Cells[Column].AsXmlElement);
end;

constructor THtmlRow.Create;
begin
  Cells := THtmlCells.Create;
end;

destructor THtmlRow.Destroy;
begin
  FreeAndNil(Cells);
  inherited;
end;

{ THtmlTable }

function THtmlTable.GetAsXmlElement: TXmlElement;
var
  Row: Integer;
begin
  Result := inherited;
  with TXmlTag(Result) do begin
    Name := 'table';
    for Row := 0 to Rows.Count - 1 do
      SubElements.Add(Rows[Row].AsXmlElement);
  end;
end;

constructor THtmlTable.Create;
begin
  Rows := THtmlRows.Create;
end;

destructor THtmlTable.Destroy;
begin
  FreeAndNil(Rows);
  inherited;
end;

{ THtmlLineBreak }

function THtmlLineBreak.GetAsXmlElement: TXmlElement;
begin
  Result := inherited GetAsXmlElement;
  TXmlTag(Result).Name := 'br';
end;

constructor THtmlLineBreak.Create;
begin
end;

{ THtmlInput }

function THtmlInput.GetAsXmlElement: TXmlElement;
var
  InputTypeString: string;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    Name := 'input';
    case InputType of
      itButton: InputTypeString := 'button';
      itRadioButton: InputTypeString := 'radio';
      itCheckBox: InputTypeString := 'checkbox';
      itText: InputTypeString := 'text';
      itFileSelect: InputTypeString := 'file';
      itSubmit: InputTypeString := 'submit';
      itHidden: InputTypeString := 'hidden';
      itPassword: InputTypeString := 'password';
    end;
    Attributes.Add('type', InputTypeString);
    Attributes.Add('value', Value);
    if Self.ItemName <> '' then
      Attributes.Add('name', Self.ItemName);
  end;
end;

procedure THtmlInput.Assign(Source: THtmlElement);
begin
  inherited Assign(Source);
  InputType := THtmlInput(Source).InputType;
  Value := THtmlInput(Source).Value;
  ItemName := THtmlInput(Source).ItemName;
end;

constructor THtmlInput.Create;
begin
end;

destructor THtmlInput.Destroy;
begin
  inherited;
end;

{ THtmlForm }

function THtmlForm.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    Name := 'form';
    Attributes.Add('action', Action.AsString);
    Attributes.Add('method', Method);
  end;
end;

constructor THtmlForm.Create;
begin
  inherited;
  Action := TURL.Create;
  BlockType := btBlockLevel;
  Method := 'get';
end;

destructor THtmlForm.Destroy;
begin
  FreeAndNil(Action);
  inherited;
end;

{ THtmlDocument }

constructor THtmlDocument.Create;
begin
  Body := THtmlBlock.Create;
  Styles := TStringList.Create;
  Scripts := TStringList.Create;
  ContentLanguage := 'en';
  ContentEncoding := 'utf-8';
end;

destructor THtmlDocument.Destroy;
begin
  FreeAndNil(Body);
  FreeAndNil(Styles);
  FreeAndNil(Scripts);
  inherited;
end;

function THtmlDocument.GetAsXmlDocument: TXmlDocument;
var
  I: Integer;
begin
  Result := TXmlDocument.Create;
  with Result, Content do begin
    with SubElements.AddTag('!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"') do begin
      EndTagSymbol := '';
    end;
    with SubElements.AddTag('html') do begin
      with SubElements.AddTag('head') do begin
        with SubElements.AddTag('title') do begin
          SubElements.AddString(Title);
        end;
        with SubElements.AddTag('meta') do begin
          Attributes.Add('http-equiv', 'Content-Language');
          Attributes.Add('content', ContentLanguage);
        end;
        with SubElements.AddTag('meta') do begin
          Attributes.Add('http-equiv', 'Content-Type');
          Attributes.Add('content', 'text/html; charset=' + ContentEncoding);
        end;
        with SubElements.AddTag('meta') do begin
          Attributes.Add('name', 'viewport');
          Attributes.Add('content', 'width=device-width, initial-scale=1');
        end;
        for I := 0 to Styles.Count - 1 do
        with SubElements.AddTag('link') do begin
          Attributes.Add('rel', 'stylesheet');
          Attributes.Add('href', Styles[I]);
          Attributes.Add('type', 'text/css');
          Attributes.Add('media', 'all');
        end;
        if FavIcon <> '' then
        with SubElements.AddTag('link') do begin
          Attributes.Add('rel', 'icon');
          Attributes.Add('href', FavIcon);
          Attributes.Add('type', 'image/x-icon');
        end;
        for I := 0 to Scripts.Count - 1 do
        with SubElements.AddTag('script') do begin
          ShringEmpty := False;
          Attributes.Add('type', 'text/javascript');
          Attributes.Add('src', Scripts[I]);
        end;
      end;
      with SubElements.AddTag('body') do begin
        SubElements.Add(Body.AsXmlElement);
      end;
    end;
  end;
end;

{ THtmlBlock }

constructor THtmlBlock.Create;
begin
  inherited;
  SubItems := THtmlElements.Create;
end;

destructor THtmlBlock.Destroy;
begin
  FreeAndNil(SubItems);
  inherited;
end;

function THtmlBlock.GetAsXmlElement: TXmlElement;
var
  I: Integer;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    case BlockType of
      btBlockLevel: Name := 'div';
      btInline: Name := 'span';
      btNoTag: Name := '';
    end;
    for I := 0 to SubItems.Count - 1 do
      SubElements.Add(SubItems[I].AsXmlElement);
   end;
end;

{ THtmlElement }

function THtmlElement.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result).Attributes do begin
    if Name <> '' then Add('name', Name);
    if Style <> '' then Add('style', Style);
    if ClassId <> '' then Add('class', ClassId);
    if Id <> '' then Add('id', Id);
  end;
end;

procedure THtmlElement.Assign(Source: THtmlElement);
begin
  Id := Source.Id;
  Name := Source.Name;
  ClassId := Source.ClassId;
  Style := Source.Style;
end;

{ TURL }

constructor TURL.Create;
begin
  Host := THostAddress.Create;
end;

destructor TURL.Destroy;
begin
  FreeAndNil(Host);
  inherited;
end;

function TURL.GetAsString: string;
begin
  Result := '';
  if Scheme <> '' then Result := Scheme + '://';
  if UserName <> '' then begin
    Result := Result + UserName;
    if UserName <> '' then Result := Result + ':' + Password;
    Result := Result + '@';
  end;
  if Host.AsString <> '' then Result := Result + Host.AsString;
  if Port <> 0 then Result := Result + ':' + IntToStr(Port);
  if Path <> '' then Result := Result + Path;
  if Query <> '' then Result := Result + '?' + Query;
  if Fragment <> '' then Result := Result + '#' + Fragment;
end;

procedure TURL.SetAsString(Value: string);
var
  HostAddr: string;
  HostPort: string;
begin
  LeftCutString(Value, Scheme, '://');
  if LeftCutString(Value, UserName, ':') then LeftCutString(Value, Password, '@')
    else LeftCutString(Value, UserName, '@');
  RightCutString(Value, Fragment, '#');
  RightCutString(Value, Query, '?', '=&');
  if LeftCutString(Value, HostAddr, ':', '.') then begin
    LeftCutString(Value, HostPort, '');
    Port := StrToInt(HostPort);
  end else LeftCutString(Value, HostAddr, '', '.');
  Host.AsString := HostAddr;
  LeftCutString(Value, Path, '', '/.');
end;

{ THtmlLink }

constructor THtmlLink.Create;
begin
  Target := TURL.Create;
end;

destructor THtmlLink.Destroy;
begin
  FreeAndNil(Target);
  inherited;
end;

function THtmlLink.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    Name := 'a';
    Attributes.Add('href', Target.AsString);
    if Assigned(Content) then SubElements.Add(Content.AsXmlElement);
  end;
end;

{ THtmlString }

function THtmlString.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlString.Create;
  TXmlString(Result).Text := Text;
end;

procedure THtmlString.Assign(Source: THtmlElement);
begin
  inherited Assign(Source);
  Text := THtmlString(Source).Text;
end;

{ THtmlImage }

constructor THtmlImage.Create;
begin
  Source := TURL.Create;
end;

destructor THtmlImage.Destroy;
begin
  FreeAndNil(Source);
  inherited;
end;

function THtmlImage.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    Name := 'img';
    Attributes.Add('src', Source.AsString);
    Attributes.Add('width', IntToStr(Size.Width));
    Attributes.Add('height', IntToStr(Size.Height));
    Attributes.Add('alt', AlternateText);
  end;
end;

procedure TQueryString.SetStringServer;
begin
  // SetString($_SERVER['QUERY_STRING']);
end;

procedure TQueryString.SetString(QueryString: string);
begin
  (*
  $this->Data = array();
  $Parts = explode('&', $QueryString);
  foreach($Parts as $Part)
  {
    if($Part != '')
    {
      $Item = explode('=', $Part);
      $this->Data[$Item[0]] = $Item[1];
    end;
  end;*)
end;

function TQueryString.GetString: string;
begin
  (*
  Parts = array();
  foreach($this->Data as $Index => $Item)
  {
    $Parts[] = $Index.'='.$Item;
  }
  return(implode('&', $Parts));*)
end;

constructor TQueryString.Create;
begin
  Data := TStringList.Create;
end;

destructor TQueryString.Destroy;
begin
  FreeAndNil(Data);
  inherited;
end;

end.