* Added new Units "htmwrite" and "xhtml"

2025-04-20 11:09:42 +02:00 · 2000-10-03 20:33:22 +00:00 · 2000-10-03 20:33:22 +00:00 · ccde8b207f
commit ccde8b207f
parent 7d8857e6ef
4 changed files with 517 additions and 3 deletions
--- a/fcl/xml/Makefile
+++ b/fcl/xml/Makefile
@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/10/01]
+# Makefile generated by fpcmake v1.00 [2000/10/02]
 #

 defaultrule: all
@ -176,7 +176,7 @@ endif

 # Targets

-override UNITOBJECTS+=dom htmldoc xmlcfg xmlread xmlstreaming xmlwrite
+override UNITOBJECTS+=dom htmldoc xmlcfg xmlread xmlstreaming xmlwrite xhtml htmwrite

 # Clean

--- a/fcl/xml/Makefile.fpc
+++ b/fcl/xml/Makefile.fpc
@ -3,7 +3,7 @@
 #

 [targets]
-units=dom htmldoc xmlcfg xmlread xmlstreaming xmlwrite
+units=dom htmldoc xmlcfg xmlread xmlstreaming xmlwrite xhtml htmwrite

 [require]
 options=-S2
--- a/fcl/xml/htmwrite.pp
+++ b/fcl/xml/htmwrite.pp
@ -0,0 +1,376 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    HTML writing routines
+    Copyright (c) 2000 by
+      Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
+
+    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 HTMWrite;
+
+{$MODE objfpc}
+{$H+}
+
+interface
+
+uses Classes, DOM;
+
+procedure WriteHTMLFile(doc: TXMLDocument; const AFileName: String);
+procedure WriteHTMLFile(doc: TXMLDocument; var AFile: Text);
+procedure WriteHTMLFile(doc: TXMLDocument; var AStream: TStream);
+
+procedure WriteHTML(Element: TDOMElement; const AFileName: String);
+procedure WriteHTML(Element: TDOMElement; var AFile: Text);
+procedure WriteHTML(Element: TDOMElement; var AStream: TStream);
+
+
+// ===================================================================
+
+implementation
+
+uses SysUtils;
+
+// -------------------------------------------------------------------
+//   Writers for the different node types
+// -------------------------------------------------------------------
+
+procedure WriteElement(node: TDOMNode); forward;
+procedure WriteAttribute(node: TDOMNode); forward;
+procedure WriteText(node: TDOMNode); forward;
+procedure WriteCDATA(node: TDOMNode); forward;
+procedure WriteEntityRef(node: TDOMNode); forward;
+procedure WriteEntity(node: TDOMNode); forward;
+procedure WritePI(node: TDOMNode); forward;
+procedure WriteComment(node: TDOMNode); forward;
+procedure WriteDocument(node: TDOMNode); forward;
+procedure WriteDocumentType(node: TDOMNode); forward;
+procedure WriteDocumentFragment(node: TDOMNode); forward;
+procedure WriteNotation(node: TDOMNode); forward;
+
+
+type
+  TWriteNodeProc = procedure(node: TDOMNode);
+
+const
+  WriteProcs: array[ELEMENT_NODE..NOTATION_NODE] of TWriteNodeProc =
+    (WriteElement, WriteAttribute, WriteText, WriteCDATA, WriteEntityRef,
+     WriteEntity, WritePI, WriteComment, WriteDocument, WriteDocumentType,
+     WriteDocumentFragment, WriteNotation);
+
+procedure WriteNode(node: TDOMNode);
+begin
+  WriteProcs[node.NodeType](node);
+end;
+
+
+// -------------------------------------------------------------------
+//   Text file and TStream support
+// -------------------------------------------------------------------
+
+type
+  TOutputProc = procedure(s: String);
+
+var
+  f: ^Text;
+  stream: TStream;
+  wrt, wrtln: TOutputProc;
+  InsideTextNode: Boolean;
+
+
+procedure Text_Write(s: String);
+begin
+  Write(f^, s);
+end;
+
+procedure Text_WriteLn(s: String);
+begin
+  WriteLn(f^, s);
+end;
+
+procedure Stream_Write(s: String);
+begin
+  if Length(s) > 0 then
+    stream.Write(s[1], Length(s));
+end;
+
+procedure Stream_WriteLn(s: String);
+begin
+  if Length(s) > 0 then
+    stream.Write(s[1], Length(s));
+  stream.WriteByte(10);
+end;
+
+
+// -------------------------------------------------------------------
+//   String conversion
+// -------------------------------------------------------------------
+
+type
+  TCharacters = set of Char;
+  TSpecialCharCallback = procedure(c: Char);
+
+const
+  AttrSpecialChars = ['"', '&'];
+  TextSpecialChars = ['<', '>', '&'];
+
+
+procedure ConvWrite(const s: String; const SpecialChars: TCharacters;
+  const SpecialCharCallback: TSpecialCharCallback);
+var
+  StartPos, EndPos: Integer;
+begin
+  StartPos := 1;
+  EndPos := 1;
+  while EndPos <= Length(s) do
+  begin
+    if s[EndPos] in SpecialChars then
+    begin
+      wrt(Copy(s, StartPos, EndPos - StartPos));
+      SpecialCharCallback(s[EndPos]);
+      StartPos := EndPos + 1;
+    end;
+    Inc(EndPos);
+  end;
+  if EndPos > StartPos then
+    wrt(Copy(s, StartPos, EndPos - StartPos));
+end;
+
+procedure AttrSpecialCharCallback(c: Char);
+begin
+  if c = '"' then
+    wrt('&quot;')
+  else if c = '&' then
+    wrt('&amp;')
+  else
+    wrt(c);
+end;
+
+procedure TextnodeSpecialCharCallback(c: Char);
+begin
+  if c = '<' then
+    wrt('&lt;')
+  else if c = '>' then
+    wrt('&gt;')
+  else if c = '&' then
+    wrt('&amp;')
+  else
+    wrt(c);
+end;
+
+
+// -------------------------------------------------------------------
+//   Node writers implementations
+// -------------------------------------------------------------------
+
+procedure WriteElement(node: TDOMNode);
+var
+  i: Integer;
+  attr, child: TDOMNode;
+  SavedInsideTextNode: Boolean;
+  s: String;
+begin
+  wrt('<' + node.NodeName);
+  for i := 0 to node.Attributes.Length - 1 do
+  begin
+    attr := node.Attributes.Item[i];
+    wrt(' ' + attr.NodeName + '=');
+    s := attr.NodeValue;
+    // !!!: Replace special characters in "s" such as '&', '<', '>'
+    wrt('"');
+    ConvWrite(s, AttrSpecialChars, @AttrSpecialCharCallback);
+    wrt('"');
+  end;
+  Child := node.FirstChild;
+  if Child = nil then
+    if InsideTextNode then
+      wrt(' />')
+    else
+      wrtln(' />')
+  else
+  begin
+    SavedInsideTextNode := InsideTextNode;
+    if InsideTextNode or Child.InheritsFrom(TDOMText) then
+      wrt('>')
+    else
+      wrtln('>');
+    repeat
+      if Child.InheritsFrom(TDOMText) then
+        InsideTextNode := True;
+      WriteNode(Child);
+      Child := Child.NextSibling;
+    until child = nil;
+    InsideTextNode := SavedInsideTextNode;
+    s := '</' + node.NodeName + '>';
+    if InsideTextNode then
+      wrt(s)
+    else
+      wrtln(s);
+  end;
+end;
+
+procedure WriteAttribute(node: TDOMNode);
+begin
+  WriteLn('WriteAttribute');
+end;
+
+procedure WriteText(node: TDOMNode);
+begin
+  ConvWrite(node.NodeValue, TextSpecialChars, @TextnodeSpecialCharCallback);
+end;
+
+procedure WriteCDATA(node: TDOMNode);
+begin
+  if InsideTextNode then
+    wrt('<![CDATA[' + node.NodeValue + ']]>')
+  else
+    wrtln('<![CDATA[' + node.NodeValue + ']]>')
+end;
+
+procedure WriteEntityRef(node: TDOMNode);
+begin
+  wrt('&' + node.NodeName + ';');
+end;
+
+procedure WriteEntity(node: TDOMNode);
+begin
+  WriteLn('WriteEntity');
+end;
+
+procedure WritePI(node: TDOMNode);
+var
+  s: String;
+begin
+  s := '<!' + TDOMProcessingInstruction(node).Target + ' ' +
+    TDOMProcessingInstruction(node).Data + '>';
+  if InsideTextNode then
+    wrt(s)
+  else
+    wrtln( s);
+end;
+
+procedure WriteComment(node: TDOMNode);
+begin
+  if InsideTextNode then
+    wrt('<!--' + node.NodeValue + '-->')
+  else
+    wrtln('<!--' + node.NodeValue + '-->')
+end;
+
+procedure WriteDocument(node: TDOMNode);
+begin
+  WriteLn('WriteDocument');
+end;
+
+procedure WriteDocumentType(node: TDOMNode);
+begin
+  WriteLn('WriteDocumentType');
+end;
+
+procedure WriteDocumentFragment(node: TDOMNode);
+begin
+  WriteLn('WriteDocumentFragment');
+end;
+
+procedure WriteNotation(node: TDOMNode);
+begin
+  WriteLn('WriteNotation');
+end;
+
+
+procedure InitWriter;
+begin
+  InsideTextNode := False;
+end;
+
+procedure RootWriter(doc: TXMLDocument);
+var
+  Child: TDOMNode;
+begin
+  InitWriter;
+  child := doc.FirstChild;
+  while Assigned(Child) do
+  begin
+    WriteNode(Child);
+    Child := Child.NextSibling;
+  end;
+end;
+
+
+// -------------------------------------------------------------------
+//   Interface implementation
+// -------------------------------------------------------------------
+
+procedure WriteHTMLFile(doc: TXMLDocument; const AFileName: String);
+begin
+  Stream := TFileStream.Create(AFileName, fmCreate);
+  wrt := @Stream_Write;
+  wrtln := @Stream_WriteLn;
+  RootWriter(doc);
+  Stream.Free;
+end;
+
+procedure WriteHTMLFile(doc: TXMLDocument; var AFile: Text);
+begin
+  f := @AFile;
+  wrt := @Text_Write;
+  wrtln := @Text_WriteLn;
+  RootWriter(doc);
+end;
+
+procedure WriteHTMLFile(doc: TXMLDocument; var AStream: TStream);
+begin
+  Stream := AStream;
+  wrt := @Stream_Write;
+  wrtln := @Stream_WriteLn;
+  RootWriter(doc);
+end;
+
+
+procedure WriteHTML(Element: TDOMElement; const AFileName: String);
+begin
+  Stream := TFileStream.Create(AFileName, fmCreate);
+  wrt := @Stream_Write;
+  wrtln := @Stream_WriteLn;
+  InitWriter;
+  WriteNode(Element);
+  Stream.Free;
+end;
+
+procedure WriteHTML(Element: TDOMElement; var AFile: Text);
+begin
+  f := @AFile;
+  wrt := @Text_Write;
+  wrtln := @Text_WriteLn;
+  InitWriter;
+  WriteNode(Element);
+end;
+
+procedure WriteHTML(Element: TDOMElement; var AStream: TStream);
+begin
+  stream := AStream;
+  wrt := @Stream_Write;
+  wrtln := @Stream_WriteLn;
+  InitWriter;
+  WriteNode(Element);
+end;
+
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-10-03 20:33:22  sg
+  * Added new Units "htmwrite" and "xhtml"
+
+}
--- a/fcl/xml/xhtml.pp
+++ b/fcl/xml/xhtml.pp
@ -0,0 +1,138 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    XHTML helper classes
+    Copyright (c) 2000 by
+      Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
+
+    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 XHTML;
+
+{$MODE objfpc}
+{$H+}
+
+interface
+
+uses DOM;
+
+type
+
+  TXHTMLTitleElement = class(TDOMElement);
+
+  TXHTMLHeadElement = class(TDOMElement)
+  private
+    function GetTitleElement: TXHTMLTitleElement;
+  public
+    function RequestTitleElement: TXHTMLTitleElement;
+    property TitleElement: TXHTMLTitleElement read GetTitleElement;
+  end;
+
+  TXHTMLBodyElement = class(TDOMElement);
+
+
+  TXHTMLType = (xhtmlStrict, xhtmlTransitional);
+
+  TXHTMLDocument = class(TXMLDocument)
+  private
+    function GetHeadElement: TXHTMLHeadElement;
+    function GetBodyElement: TXHTMLBodyElement;
+  public
+    procedure CreateRoot(XHTMLType: TXHTMLType);
+    function RequestHeadElement: TXHTMLHeadElement;
+    function RequestBodyElement(const Lang: DOMString): TXHTMLBodyElement;
+    property HeadElement: TXHTMLHeadElement read GetHeadElement;
+    property BodyElement: TXHTMLBodyElement read GetBodyElement;
+  end;
+
+
+
+implementation
+
+
+function TXHTMLHeadElement.RequestTitleElement: TXHTMLTitleElement;
+begin
+  Result := TitleElement;
+  if not Assigned(Result) then
+  begin
+    Result := TXHTMLTitleElement(OwnerDocument.CreateElement('title'));
+    AppendChild(Result);
+  end;
+end;
+
+function TXHTMLHeadElement.GetTitleElement: TXHTMLTitleElement;
+begin
+  Result := TXHTMLTitleElement(FindNode('title'));
+end;
+
+
+procedure TXHTMLDocument.CreateRoot(XHTMLType: TXHTMLType);
+var
+  s: DOMString;
+  HtmlEl: TDOMElement;
+begin
+  case XHTMLType of
+    xhtmlStrict:
+      s := 'html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "DTD/xhtml1-strict.dtd"';
+    xhtmlTransitional:
+      s := 'html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "DTD/xhtml1-transitional.dtd"';
+  end;
+  AppendChild(CreateProcessingInstruction('DOCTYPE', s));
+  HtmlEl := CreateElement('html');
+  AppendChild(HtmlEl);
+  HtmlEl['xmlns'] := 'http://www.w3.org/1999/xhtml';
+end;
+
+function TXHTMLDocument.RequestHeadElement: TXHTMLHeadElement;
+begin
+  Result := HeadElement;
+  if not Assigned(Result) then
+  begin
+    Result := TXHTMLHeadElement(CreateElement('head'));
+    DocumentElement.AppendChild(Result);
+  end;
+end;
+
+function TXHTMLDocument.RequestBodyElement(const Lang: DOMString):
+  TXHTMLBodyElement;
+begin
+  Result := BodyElement;
+  if not Assigned(Result) then
+  begin
+    Result := TXHTMLBodyElement(CreateElement('body'));
+    DocumentElement.AppendChild(Result);
+    Result['xmlns'] := 'http://www.w3.org/1999/xhtml';
+    Result['xml:lang'] := Lang;
+    Result['lang'] := Lang;
+  end;
+end;
+
+function TXHTMLDocument.GetHeadElement: TXHTMLHeadElement;
+begin
+  Result := TXHTMLHeadElement(DocumentElement.FindNode('head'));
+end;
+
+function TXHTMLDocument.GetBodyElement: TXHTMLBodyElement;
+begin
+  Result := TXHTMLBodyElement(DocumentElement.FindNode('body'));
+end;
+
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-10-03 20:33:22  sg
+  * Added new Units "htmwrite" and "xhtml"
+
+}