{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Angus Robertson, Magenta Systems Ltd Description: TIcsHTMLParser is an HTMP parser. Creation: 1996 Updated: Aug 2023 Version: V9.0 EMail: francois.piette@overbyte.be http://www.overbyte.be Support: https://en.delphipraxis.net/forum/37-ics-internet-component-suite/ Legal issues: CTIcsHTMLParser v1.17 (w) 1996-2023 D.Spreen (dennis@spreendigital.de) his unit is freeware. Just drop me a line if this unit is useful for you. This software is provided 'as-is', without any express or implied warranty. In no event will the author be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented, you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. 4. You must register this software by sending a picture postcard to the author. Use a nice stamp and mention your name, street address, EMail address and any comment you like to say. revision history 1.00-1.04 added several optimaizations 1.05 fixed a memory leak in TIcsHTMLParser.destroy 1.06 changed layout in prof.component 1.07 added ' as a valid parameter key bracket 1.08 fixed and //--> comments 1.09 added reverse entity support - HTMLText.ELine (on request by Eirkur Haraldsson) 1.10 fixed quotes in comment tags 1.11 fixed javascript operators bug in comment tags with new "live comment detector" 1.12 fixed closing tag before quotes 1.13 fixed key values with spaces around the equal sign (done by Frdric Leneuf-Magaud) fixed problem with mixed quotes (done by Frdric Leneuf-Magaud) 1.14 fixed quotes in comments, optimized entity support (thanks to Oleg Zarichniy) 1.15 fixed #255 line marker (thanks to Oleg Zarichniy) 1.16 fixed unix crlf #10 1.17 added Clear(), Feed(s: string) and FeedStop() - see sample.dpr 2.0 Angus added M+ TYPEINFO ON to stop D2007 warning 4 Mar 2019 - V8.60 - Adapted for main ICS packages and FMX support. THTMLParser to TIcsHTMLParser Types have Ics added. Aug 08, 2023 V9.0 Updated version to major release 9. You may find new versions of TIcsHTMLParser and other delphi components at http://www.spreendigital.de/delphi/ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} unit OverbyteIcsHtmlPars; {$I Include\OverbyteIcsDefs.inc} {$M+} interface uses {$Ifdef Rtl_Namespaces}System.Classes{$Else}Classes{$Endif}, {$Ifdef Rtl_Namespaces}System.Sysutils{$Else}Sysutils{$Endif}; const // Western Latin-1 entities HTML3.2 EntitiesTable:array [1..100,1..2] of string=( ('"', '"'), ('&', '&'), ('<', '<'), ('>', '>'), (' ', ' '), ('¡', '¡'), ('¢', '¢'), ('£', '£'), ('¤','¤'), ('¥', '¥'), ('¦','¦'), ('§', '§'), ('¨', '¨'), ('©', '©'), ('ª', 'ª'), ('«', '«'), ('¬', '¬'), ('­', '­'), ('®', '®'), ('¯', '¯'), ('°', '°'), ('±','±'), ('²', '²'), ('³', '³'), ('´', '´'), ('µ', 'µ'), ('¶', '¶'), ('·','·'), ('¸', '¸'), ('¹', '¹'), ('º', 'º'), ('»', '»'), ('¼','¼'), ('½','½'), ('¾','¾'), ('¿','¿'), ('À','À'), ('Á','Á'), ('Â', 'Â'), ('Ã','Ã'), ('Ä', 'Ä'), ('Å', 'Å'), ('Æ', 'Æ'), ('Ç','Ç'), ('È','È'), ('É','É'), ('Ê', 'Ê'), ('Ë', 'Ë'), ('Ì','Ì'), ('Í','Í'), ('Î', 'Î'), ('Ï', 'Ï'), ('Ð', 'Ð'), ('Ñ','Ñ'), ('Ò','Ò'), ('Ó','Ó'), ('Ô', 'Ô'), ('Õ','Õ'), ('Ö', 'Ö'), ('×', '×'), ('Ø','Ø'), ('Ù','Ù'), ('Ú','Ú'), ('Û', 'Û'), ('Ü', 'Ü'), ('Ý','Ý'), ('Þ', 'Þ'), ('ß', 'ß'), ('à','à'), ('á','á'), ('â', 'â'), ('ã','ã'), ('ä', 'ä'), ('å', 'å'), ('æ', 'æ'), ('ç','ç'), ('è','è'), ('é','é'), ('ê', 'ê'), ('ë', 'ë'), ('ì','ì'), ('í','í'), ('î', 'î'), ('ï', 'ï'), ('ð', 'ð'), ('ñ','ñ'), ('ò','ò'), ('ó','ó'), ('ô', 'ô'), ('õ','õ'), ('ö', 'ö'), ('÷','÷'), ('ø','ø'), ('ù','ù'), ('ú','ú'), ('û', 'û'), ('ü', 'ü'), ('ý','ý'), ('þ', 'þ'), ('ÿ', 'ÿ')); // charset with iso-8559-1 (Western Latin-1) const Iso85591CharSetTable:array [0..255] of char=( ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '!', '"', '#', '$', '%', '&', '''', '(', ')', '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|', '}', '~', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', // charset iso-8559-1 (Western Latin-1) ' ', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', ''); type TIcsHTMLParam = class private fRaw: string; fKey: string; fValue: string; procedure SetKey(Key: string); public constructor Create; destructor Destroy; override; published property Key: string read fKey write SetKey; property Value: string read fValue; property Raw: string read fRaw; end; type TIcsHTMLTag = class private fName: string; fRaw: string; procedure SetName(Name: string); public Params: TList; constructor Create; destructor Destroy; override; published property Name: string read fName write SetName; // uppercased TAG (without <>) property Raw: string read fRaw; // raw TAG (parameters included) as read from input file (without<>) end; type TIcsHTMLText = class private fLine: string; fRawLine: string; procedure SetLine(Line: string); function GetLine: string; // v1.09 public constructor Create; destructor Destroy; override; published property Line: string read fLine write SetLine; // HTML3.2 Entities and Western Latin-1 Font converted Text property Raw: string read fRawLine; // raw text line as read from input file property ELine: string read GetLine; // v1.09 end; type TIcsHTMLParser = class(TObject) private Text: string; Tag: string; isTag: boolean; isComment: boolean; // v1.11 FirstQuoteChar: char; isQuote: boolean; fClearOnExecute: boolean; // v1.17 procedure AddText; procedure AddTag; procedure FeedStart; // v1.17 public parsed: TList; Lines: TStringList; constructor Create; destructor Destroy; override; procedure Execute; procedure Feed(s: string); // v1.17 procedure FeedStop; // v1.17 procedure Clear; // v1.17 published property ClearOnExecute: boolean read fClearOnExecute write fClearOnExecute; // v1.17 end; implementation constructor TIcsHTMLParser.Create; begin inherited Create; Lines := TStringList.Create; Parsed := TList.Create; FeedStart; fClearOnExecute := True; end; procedure TIcsHTMLParser.Clear; // v1.17 var i: integer; obj: TObject; begin if Parsed.Count = 0 then exit ; // angus // memory leak fixed in v1.05 for i := Parsed.Count downto 1 do begin obj := parsed[i - 1]; if obj.classtype = TIcsHTMLTag then TIcsHTMLTag(obj).Free else if obj.classtype = TIcsHTMLText then TIcsHTMLText(obj).Free else obj.Free; Parsed.Delete(i - 1); end; end; destructor TIcsHTMLParser.Destroy; begin Lines.Free; Clear; Parsed.Free; inherited Destroy; end; procedure TIcsHTMLParser.AddText; var HTMLText: TIcsHTMLText; begin if not isTag then if Text <> '' then begin HTMLText := TIcsHTMLText.Create; HTMLText.Line := Text; Text := ''; parsed.Add(HTMLText); end; end; procedure TIcsHTMLParser.AddTag; var HTMLTag: TIcsHTMLTag; begin isTag := False; isComment := False; HTMLTag := TIcsHTMLTag.Create; HTMLTag.Name := Tag; Tag := ''; parsed.Add(HTMLTag); end; procedure TIcsHTMLParser.FeedStart; // v1.17 begin Text := ''; Tag := ''; isTag := False; isQuote := False; // v1.10 FirstQuoteChar := ' '; // v1.10 isComment := False; //v1.11 end; procedure TIcsHTMLParser.Feed(s: string); // v1.17 var i: integer; begin for i := 1 to length(s) do begin if isTag then //v1.12 if (s[i] = '"') or (s[i] = '''') then // v1.10 begin if not isComment then // v1.14 if not isQuote then begin isQuote := True; FirstQuoteChar := s[i]; end else if s[i] = FirstQuoteChar then isQuote := False; end; if (s[i] = '<') and (not isQuote) then begin AddText; isTag := True; end //v1.12 else if (s[i] = '>') and (not isQuote) and (isTag) and //v1.14 ((not (isComment)) or //v1.11 ((isComment) and (length(Tag) > 1) and (copy(tag, length(tag) - 1,2) = '--')) //v1.11 ) then AddTag else if isTag then begin Tag := Tag + s[i]; if tag = '!--' then isComment := True; //v1.11 end else Text := Text + s[i]; end; end; procedure TIcsHTMLParser.FeedStop; // v1.17 begin if (isTag) and (Tag <> '') then AddTag; if (not isTag) and (Text <> '') then AddText; FeedStart; end; procedure TIcsHTMLParser.Execute; // changed v1.17 var i: integer; begin if fClearOnExecute then Clear; FeedStart; for i := 1 to Lines.Count do begin if i <> 1 then if isTag then Tag := Tag + #$0d#$0a else Text := Text + #$0d#$0a; Feed(Lines[i - 1]); end; FeedStop; end; constructor TIcsHTMLTag.Create; begin inherited Create; Params := TList.Create; end; destructor TIcsHTMLTag.Destroy; var i: integer; begin for i := Params.Count downto 1 do begin TIcsHTMLParam(Params[i - 1]).Free; Params.Delete(i - 1); end; Params.Free; inherited Destroy; end; procedure TIcsHTMLTag.SetName(Name: string); var Tag: string; param: string; HTMLParam: TIcsHTMLParam; isQuote: char; hasSpace, // v1.13 hasEqual, // v1.13 isValue: boolean; // v1.13 p: integer; begin fRaw := Name; Params.Clear; //v1.10 - replace new lines with space while pos(#$0d#$0a, Name) <> 0 do begin p := pos(#$0d#$0a, Name); Delete(Name, p, 1); Name[p] := ' '; end; { //v1.08 change "