Context Navigation

-              r19
+              r26
 unit UHtmlClasses;
-{$mode delphi}{$H+}
 interface
 uses
   UXmlClasses, Classes, SysUtils, SpecializedList;
+  UXmlClasses, Classes, SysUtils, Generics.Collections, UGenerics, UIpAddress;
 type
+  { TDomainAddress }
+  TDomainAddress = class(TPersistent)
+  private
+    function GetAsString: string;
+    procedure SetAsString(const Value: string);
+  public
+    Levels: TListString;
+    constructor Create;
+    destructor Destroy; override;
+    property AsString: string read GetAsString write SetAsString;
+  end;
+  TAddrClass = (acA, acB, acC, acD, acE);
+  { TIpAddress }
+  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;
+    function IsAddressString(Value: string): Boolean;
+    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 }
   TURL = class(TPersistent)
 …
   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 = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   THtmlLineBreak = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   public
     BlockType: TBlockType;
+    SubItems: TListObject; // TListObject<THtmlElement>;
+    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;
 …
   THtmlLink = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   THtmlImage = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   THtmlInput = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   THtmlCell = class(THtmlElement)
   private
+  protected
     function GetAsXmlElement: TXmlElement; override;
   public
 …
   end;
+  { THtmlCells }
+  THtmlCells = class(TObjectList<THtmlCell>)
+    function AddCell: THtmlCell;
+  end;
   { THtmlRow }
   THtmlRow = class(THtmlElement)
+  private
+    function GetAsXmlElement: TXmlElement; override;
+  public
+    Cells: TListObject; // TListObject<THtmlCell>
+    constructor Create;
+    destructor Destroy; override;
+  protected
+    function GetAsXmlElement: TXmlElement; override;
+  public
+    Cells: THtmlCells;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+  { THtmlRows }
+  THtmlRows = class(TObjectList<THtmlRow>)
+    function AddRow: THtmlRow;
   end;
 …
     function GetAsXmlElement: TXmlElement; override;
   public
     Rows: TListObject; // TListObject<THtmlRow>
+    Rows: THtmlRows;
     constructor Create;
     destructor Destroy; override;
 …
   end;
 implementation
-resourcestring
-  SStringToIPConversionError = 'String to IP address conversion error';
 function LeftCutString(var Source, Output: string; Delimiter: string; Allowed: string = ''): Boolean;
 …
   I := 1;
   Matched := True;
   while (I <= Length(Source)) and Matched do begin
+  while (I < Length(Source)) and Matched do begin
     Matched := False;
     if (Source[I] >= 'A') and (Source[I] <= 'Z') then Matched := True
     else if (Source[I] >= 'a') and (Source[I] <= 'z') then Matched := True
     else if (Source[I] >= '0') and (Source[I] <= '9') then Matched := True
     else for J := 1 to Length(Allowed) do
+    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);
+    Output := Copy(Source, 1, I-1);
     Delete(Source, 1, Length(Output) + Length(Delimiter));
     Result := True;
 …
 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 }
 …
 destructor THtmlCell.Destroy;
 begin
   Value.Free;
   inherited Destroy;
+  FreeAndNil(Value);
+  inherited;
 end;
 …
   TXmlTag(Result).Name := 'tr';
   for Column := 0 to Cells.Count - 1 do
     TXmlTag(Result).SubElements.AddNew(THtmlCell(Cells[Column]).AsXmlElement);
+    TXmlTag(Result).SubElements.Add(Cells[Column].AsXmlElement);
 end;
 constructor THtmlRow.Create;
 begin
   Cells := TListObject.Create;
+  Cells := THtmlCells.Create;
 end;
 destructor THtmlRow.Destroy;
 begin
   Cells.Free;
   inherited Destroy;
+  FreeAndNil(Cells);
+  inherited;
 end;
 …
 function THtmlTable.GetAsXmlElement: TXmlElement;
 var
   Row, Column: Integer;
+  Row: Integer;
 begin
   Result := inherited;
 …
     Name := 'table';
     for Row := 0 to Rows.Count - 1 do
       SubElements.AddNew(THtmlRow(Rows[Row]).AsXmlElement);
+      SubElements.Add(Rows[Row].AsXmlElement);
   end;
 end;
 …
 constructor THtmlTable.Create;
 begin
   Rows := TListObject.Create;
+  Rows := THtmlRows.Create;
 end;
 destructor THtmlTable.Destroy;
 begin
   Rows.Free;
   inherited Destroy;
+  FreeAndNil(Rows);
+  inherited;
 end;
 …
 constructor THtmlInput.Create;
 begin
 end;
 destructor THtmlInput.Destroy;
 begin
   inherited Destroy;
+  inherited;
 end;
 …
 destructor THtmlForm.Destroy;
 begin
   Action.Free;
   inherited Destroy;
+  FreeAndNil(Action);
+  inherited;
 end;
 …
 destructor THtmlDocument.Destroy;
 begin
   Body.Free;
   Styles.Free;
   Scripts.Free;
+  FreeAndNil(Body);
+  FreeAndNil(Styles);
+  FreeAndNil(Scripts);
   inherited;
 end;
 …
 function THtmlDocument.GetAsXmlDocument: TXmlDocument;
 var
-  DocType: TXMLTag;
-  HTMLTag: TXMLTag;
   I: Integer;
 begin
   Result := TXmlDocument.Create;
   with Result, Content do begin
+    DocType := TXMlTag.Create;
+    DocType.Name := '!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"';
+    Doctype.EndTagSymbol := '';
+    SubElements.Add(DocType);
+    HTMLTag := TXMLTag.Create;
+    with HTMLTag do begin
+      Name := 'html';
+      with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+        Name := 'head';
+        with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+          Name := 'title';
+          with TXmlString(SubElements[SubElements.Add(TXmlString.Create)]) do begin
+            Text := Title;
+          end;
+    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 TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+          Name := 'meta';
+        with SubElements.AddTag('meta') do begin
           Attributes.Add('http-equiv', 'Content-Language');
           Attributes.Add('content', ContentLanguage);
         end;
+        with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+          Name := 'meta';
+        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 TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+          Name := 'link';
+        with SubElements.AddTag('link') do begin
           Attributes.Add('rel', 'stylesheet');
           Attributes.Add('href', Styles[I]);
 …
         end;
         for I := 0 to Scripts.Count - 1 do
+        with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+          Name := 'script';
+        with SubElements.AddTag('script') do begin
           ShringEmpty := False;
           Attributes.Add('type', 'text/javascript');
 …
         end;
       end;
+      with TXmlTag(SubElements[SubElements.Add(TXmlTag.Create)]) do begin
+        Name := 'body';
+      with SubElements.AddTag('body') do begin
         SubElements.Add(Body.AsXmlElement);
       end;
     end;
-    SubElements.Add(HTMLTag);
   end;
 end;
 …
 begin
   inherited;
   SubItems := TListObject.Create;
+  SubItems := THtmlElements.Create;
 end;
 destructor THtmlBlock.Destroy;
 begin
   SubItems.Free;
+  FreeAndNil(SubItems);
   inherited;
 end;
 …
     end;
     for I := 0 to SubItems.Count - 1 do
       SubElements.Add(THtmlElement(SubItems[I]).AsXmlElement);
+      SubElements.Add(SubItems[I].AsXmlElement);
    end;
 end;
 …
 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.IsAddressString(Value: string): Boolean;
+var
+  Parts: TListString;
+begin
+  Result := True;
+  try
+    Parts := TListString.Create;
+    Parts.Explode(Value, '.', StrToStr);
+    if Parts.Count = 4 then begin
+      if (StrToInt(Parts[3]) < 0) or (StrToInt(Parts[3]) > 255) then Result := False;
+      if (StrToInt(Parts[2]) < 0) or (StrToInt(Parts[2]) > 255) then Result := False;
+      if (StrToInt(Parts[1]) < 0) or (StrToInt(Parts[1]) > 255) then Result := False;
+      if (StrToInt(Parts[0]) < 0) or (StrToInt(Parts[0]) > 255) then Result := False;
+    end else Result := False;
+  finally
+    Parts.Free;
+  end;
+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: TListString;
+begin
+  try
+    Parts := TListString.Create;
+    Parts.Explode(Value, '.', StrToStr);
+    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(SStringToIPConversionError);
+    end;
+  finally
+    Parts.Free;
+  end;
+end;
+procedure TIpAddress.SetBroadcast(const Value: Boolean);
+begin
+  AsCardinal := High(Cardinal);
+end;
+{ TURL }
 constructor TURL.Create;
 …
 destructor TURL.Destroy;
 begin
   Host.Free;
+  FreeAndNil(Host);
   inherited;
 end;
 …
   end else LeftCutString(Value, HostAddr, '', '.');
   Host.AsString := HostAddr;
+  LeftCutString(Value, Path, '', '/._');
+end;
+{ TDomainAddress }
+function TDomainAddress.GetAsString: string;
+begin
+  try
+    Levels.Reverse;
+    Result := Levels.Implode('.', StrToStr);
+  finally
+    Levels.Reverse;
+  end;
+end;
+procedure TDomainAddress.SetAsString(const Value: string);
+begin
+  Levels.Explode(Value, '.', StrToStr);
+  Levels.Reverse;
+end;
+constructor TDomainAddress.Create;
+begin
+  Levels := TListString.Create;
+end;
+destructor TDomainAddress.Destroy;
+begin
+  Levels.Free;
+  inherited Destroy;
+  LeftCutString(Value, Path, '', '/.');
 end;
 …
 destructor THtmlLink.Destroy;
 begin
   Target.Free;
+  FreeAndNil(Target);
   inherited;
 end;
 …
 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
-  if IpAddress.IsAddressString(Value) then begin
-    State := asIpAddress;
-    IpAddress.AsString := Value;
-  end else begin
-    State := asDomainName;
-    DomainName.AsString := Value;
-  end;
-end;
 { THtmlImage }
 …
 destructor THtmlImage.Destroy;
 begin
   Source.Free;
+  FreeAndNil(Source);
   inherited;
 end;
 …
 destructor TQueryString.Destroy;
 begin
   Data.Free;
   inherited Destroy;
+  FreeAndNil(Data);
+  inherited;
 end;

Note: See TracChangeset for help on using the changeset viewer.

Context Navigation

Changeset 26 for trunk/UHtmlClasses.pas

Legend:

trunk

trunk/UHtmlClasses.pas

Download in other formats: