source: branches/DirectWeb/UHTMLClasses.pas

unit UHTMLClasses;

{$mode Delphi}{$H+}

interface

uses
  UXmlClasses, Classes, SysUtils;

type
  TStringArray = array of string;

  TDomainAddress = class(TPersistent)
  private
    function GetAsString: string;
    procedure SetAsString(const Value: string);
  public
    Levels: array of string;
    property AsString: string read GetAsString write SetAsString;
  end;

  TAddrClass = (acA, acB, acC, acD, acE);

  TIpAddress = class(TPersistent)
  private
    function GetAddrClass: TAddrClass;
    function GetAsCardinal: Cardinal;
    function GetAsString: string;
    function GetBroadcast: Boolean;
    procedure SetBroadcast(const Value: Boolean);
    procedure SetAsCardinal(const Value: Cardinal);
    procedure SetAsString(const Value: string);
  public
    Octets: array[0..3] of Byte;
    procedure Assign(Source: TPersistent); override;
    property AsCardinal: Cardinal read GetAsCardinal write SetAsCardinal;
    property AsString: string read GetAsString write SetAsString;
    property AddrClass: TAddrClass read GetAddrClass;
    property Broadcast: Boolean read GetBroadcast write SetBroadcast;
  end;

  THostAddressState = (asDomainName, asIpAddress);
  THostAddress = class(TPersistent)
  private
    function GetAsString: string;
    procedure SetAsString(const Value: string);
  public
    State: THostAddressState;
    DomainName: TDomainAddress;
    IpAddress: TIpAddress;
    constructor Create;
    destructor Destroy; override;
    property AsString: string read GetAsString write SetAsString;
  end;

  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 = class
  private
    function GetAsXmlElement: TXmlElement; virtual;
  public
    Id: string;
    Name: string;
    ClassId: string;
    Style: string;
    property AsXmlElement: TXmlElement read GetAsXmlElement;
  end;

  TBlockType = (btNoTag, btBlockLevel, btInline);

  THtmlString = class(THtmlElement)
  private
    function GetAsXmlElement: TXmlElement; override;
  public
    Text: string;
  end;

  THtmlBlock = class(THtmlElement)
  private
    function GetAsXmlElement: TXmlElement; override;
  public
    BlockType: TBlockType;
    SubItems: TList; // of THtmlElement;
    constructor Create;
    destructor Destroy; override;
  end;

  THtmlLink = class(THtmlElement)
  private
    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)
  private
    function GetAsXmlElement: TXmlElement; override;
  public
    Size: THtmlSize;
    Source: TURL;
    AlternateText: string;
    constructor Create;
    destructor Destroy; override;
  end;

  THtmlPage = class
  private
    function GetAsXmlDocument: TXmlDocument;
  public
    Title: string;
    Charset: string;
    Body: THtmlBlock;
    property AsXmlDocument: TXmlDocument read GetAsXmlDocument;
    constructor Create;
    destructor Destroy; override;
  end;

function Explode(Separator: Char; Source: string): TStringArray;

implementation

function Explode(Separator: Char; Source: string): TStringArray;
begin
  SetLength(Result, 0);
  while Pos(Separator, Source) > 0 do begin
    SetLength(Result, Length(Result) + 1);
    Result[High(Result)] := Copy(Source, 1, Pos(Separator, Source) - 1);
    Delete(Source, 1, Length(Result[High(Result)]) + 1);
  end;
  SetLength(Result, Length(Result) + 1);
  Result[High(Result)] := Source;
end;

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;

{ THtmlPage }

constructor THtmlPage.Create;
begin
  Body := THtmlBlock.Create;
end;

destructor THtmlPage.Destroy;
begin
  Body.Free;
  inherited;
end;

function THtmlPage.GetAsXmlDocument: TXmlDocument;
begin
  Result := TXmlDocument.Create;
  with Result, Content do begin
    Formated := True;
    TagName := 'html';
    with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
      TagName := 'head';
      with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
        TagName := 'title';
        with TXmlString(SubElements[SubElements.Add(TXmlString.Create)]) do begin
          Text := Title;
        end;
      end;
      with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
        TagName := 'meta';
        Attributes.AddNameValue('http-equiv', 'Content-Language');
        Attributes.AddNameValue('content', 'cs');
      end;
      with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
        TagName := 'meta';
        Attributes.AddNameValue('http-equiv', 'Content-Type');
        Attributes.AddNameValue('content', 'text/html; charset=' + Charset);
      end;
    end;
    with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
      TagName := 'body';
      SubElements.Add(Body.AsXmlElement);


    end;
  end;
end;

{ THtmlBlock }

constructor THtmlBlock.Create;
begin
  SubItems := TList.Create;
end;

destructor THtmlBlock.Destroy;
var
  I: Integer;
begin
  for I := 0 to SubItems.Count - 1 do THtmlElement(SubItems[I]).Free;
  SubItems.Free;
  inherited;
end;

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

{ THtmlElement }

function THtmlElement.GetAsXmlElement: TXmlElement;
begin

end;

{ TIpAddress }

procedure TIpAddress.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Assigned(Source) then begin
    if Source is TIpAddress then begin
      for I := 0 to High(Octets) do
        Octets[I] := TIpAddress(Source).Octets[I];
    end else inherited;
  end else inherited;
end;

function TIpAddress.GetAddrClass: TAddrClass;
begin
  if (Octets[3] and $80) = 0 then Result := acA
  else begin
    if (Octets[3] and $40) = 0 then Result := acB
    else begin
      if (Octets[3] and $20) = 0 then Result := acC
      else begin
        if (Octets[3] and $10) = 0 then Result := acD
        else Result := acE;
      end;
    end;
  end;
end;

function TIpAddress.GetAsCardinal: Cardinal;
begin
  Result := Octets[0] or (Octets[1] shl 8) or (Octets[2] shl 16) or (Octets[3] shl 24);
end;

function TIpAddress.GetAsString: string;
begin
  Result := IntToStr(Octets[3]) + '.' + IntToStr(Octets[2]) + '.' +
    IntToStr(Octets[1]) + '.' + IntToStr(Octets[0]);
end;

function TIpAddress.GetBroadcast: Boolean;
begin
  Result := AsCardinal = High(Cardinal);
end;

procedure TIpAddress.SetAsCardinal(const Value: Cardinal);
begin
  Octets[0] := Byte(Value);
  Octets[1] := Byte(Value shr 8);
  Octets[2] := Byte(Value shr 16);
  Octets[3] := Byte(Value shr 24);
end;

procedure TIpAddress.SetAsString(const Value: string);
var
  Parts: TStringArray;
begin
  Parts := Explode('.', Value);
  try
//    if Length(Parts) = 4 then begin
    Octets[0] := StrToInt(Parts[3]);
    Octets[1] := StrToInt(Parts[2]);
    Octets[2] := StrToInt(Parts[1]);
    Octets[3] := StrToInt(Parts[0]);
//    end else raise EConvertError.Create('String to IP address conversion error');
  except
    raise EConvertError.Create('String to IP address conversion error');
  end;
end;

procedure TIpAddress.SetBroadcast(const Value: Boolean);
begin
  AsCardinal := High(Cardinal);
end;

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

destructor TURL.Destroy;
begin
  Host.Free;
  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;


{ TDomainAddress }

function TDomainAddress.GetAsString: string;
var
  I: Integer;
begin
  Result := '';
  for I := High(Levels) downto 0 do Result := Result + '.' + Levels[I];
  Delete(Result, 1, 1);
end;

procedure TDomainAddress.SetAsString(const Value: string);
var
  StrArray: TStringArray;
  I: Integer;
begin
  StrArray := Explode('.', Value);
  SetLength(Levels, Length(StrArray));
  for I := 0 to High(StrArray) do Levels[High(StrArray) - I] := StrArray[I];
end;

{ THtmlLink }

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

destructor THtmlLink.Destroy;
begin
  Target.Free;
  inherited;
end;

function THtmlLink.GetAsXmlElement: TXmlElement;
begin
  Result := TXmlTag.Create;
  with TXmlTag(Result) do begin
    TagName := '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;

{ THostAddress }

constructor THostAddress.Create;
begin
  DomainName := TDomainAddress.Create;
  IpAddress := TIpAddress.Create;
  State := asDomainName;
  DomainName.AsString := 'localhost';
end;

destructor THostAddress.Destroy;
begin
  DomainName.Free;
  IpAddress.Free;
  inherited;
end;

function THostAddress.GetAsString: string;
begin
  case State of
    asDomainName: Result := DomainName.AsString;
    asIpAddress: Result := IpAddress.AsString;
  end;
end;

procedure THostAddress.SetAsString(const Value: string);
begin
  State := asIpAddress;
  try
    IpAddress.AsString := Value;
  except
    on EConvertError do State := asDomainName;
  end;
  if State = asDomainName then DomainName.AsString := Value;
end;

{ THtmlImage }

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

destructor THtmlImage.Destroy;
begin
  Source.Free;
  inherited;
end;

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

end.