lazutils: added StrToXMLValue

git-svn-id: trunk@35468 -

.gitattributes

@@ -6227,6 +6227,7 @@ test/hello.ahk svneol=native#text/plain
 test/lazutils/TestLazLogger.lpr svneol=native#text/pascal
 test/lazutils/testlazloggercase.pas svneol=native#text/pascal
 test/lazutils/testlazutf8.pas svneol=native#text/plain
+test/lazutils/testlazxml.pas svneol=native#text/plain
 test/lazutils/testpaswstring.lpi svneol=native#text/plain
 test/lazutils/testpaswstring.pas svneol=native#text/plain
 test/lazutils/testunicode.lpi svneol=native#text/plain

components/lazutils/laz2_dom.pas

@@ -850,13 +850,75 @@ const
   stduri_xml: DOMString = 'http://www.w3.org/XML/1998/namespace';
   stduri_xmlns: DOMString = 'http://www.w3.org/2000/xmlns/';
 
-
+function StrToXMLValue(const s: string): string;
 
 // =======================================================
 // =======================================================
 
 implementation
 
+function StrToXMLValue(const s: string): string;
+
+  function Convert(Dst: PChar; out NewLen: PtrUInt): boolean;
+  var
+    h: PChar;
+    l: Integer;
+    NewLength: Integer;
+    Src: PChar;
+    i: Integer;
+  begin
+    Result:=false;
+    NewLength:=0;
+    Src:=PChar(s);
+    repeat
+      case Src^ of
+      #0:
+        if Src-PChar(s)=length(s) then
+          break
+        else begin
+          h:=''; l:=0;
+        end;
+      '&': begin h:='&'; l:=5; end;
+      '<': begin h:='&lt;'#0; l:=4; end;
+      '>': begin h:='&gt;'#0; l:=4; end;
+      '"': begin h:='&quot;'#0; l:=6; end;
+      '''': begin h:='&apos;'#0; l:=6; end;
+      else
+        if Dst<>nil then begin
+          Dst^:=Src^;
+          inc(Dst);
+        end else
+          inc(NewLength);
+        inc(Src);
+        continue;
+      end;
+      Result:=true;
+      if l>0 then begin
+        if Dst<>nil then begin
+          for i:=1 to l do begin
+            Dst^:=h^;
+            inc(Dst);
+            inc(h);
+          end;
+        end else
+          inc(NewLength,l);
+      end;
+      inc(Src);
+    until false;
+    NewLen:=NewLength;
+  end;
+
+var
+  NewLen: PtrUInt;
+begin
+  Result:=s;
+  if Result='' then exit;
+  if not Convert(nil,NewLen) then exit;
+  SetLength(Result,NewLen);
+  if NewLen=0 then exit;
+  Convert(PChar(Result),NewLen);
+end;
+
 { a namespace-enabled NamedNodeMap }
 type
   TAttributeMap = class(TDOMNamedNodeMap)

test/lazutils/testlazxml.pas

@@ -0,0 +1,49 @@
+{
+ Test all with:
+     ./runtests --format=plain --suite=TTestLazXML
+
+ Test specific with:
+     ./runtests --format=plain --suite=TestStrToXMLValue
+}
+unit TestLazXML;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testglobals, laz2_DOM;
+
+type
+
+  { TTestLazXML }
+
+  TTestLazXML = class(TTestCase)
+  public
+  published
+    procedure TestStrToXMLValue;
+  end;
+
+implementation
+
+{ TTestLazXML }
+
+procedure TTestLazXML.TestStrToXMLValue;
+begin
+  AssertEquals('Empty string','',StrToXMLValue(''));
+  AssertEquals('Short string','a',StrToXMLValue('a'));
+  AssertEquals('String with #0','',StrToXMLValue(#0));
+  AssertEquals('String with &','&',StrToXMLValue('&'));
+  AssertEquals('String with <','&lt;',StrToXMLValue('<'));
+  AssertEquals('String with >','&gt;',StrToXMLValue('>'));
+  AssertEquals('String with ''','&apos;',StrToXMLValue(''''));
+  AssertEquals('String with "','&quot;',StrToXMLValue('"'));
+  AssertEquals('String mix 1','&lt;a&gt;&quot;',StrToXMLValue('<a>'#0'"'));
+  AssertEquals('String mix 1','abc',StrToXMLValue('abc'));
+end;
+
+initialization
+  AddToLazUtilsTestSuite(TTestLazXML);
+
+end.
+

test/runtests.lpi

@@ -39,7 +39,7 @@
         <PackageName Value="LCL"/>
       </Item4>
     </RequiredPackages>
-    <Units Count="13">
+    <Units Count="14">
       <Unit0>
         <Filename Value="runtests.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -105,6 +105,11 @@
         <IsPartOfProject Value="True"/>
         <UnitName Value="TestStdCodetools"/>
       </Unit12>
+      <Unit13>
+        <Filename Value="lazutils\testlazxml.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="TestLazXML"/>
+      </Unit13>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

test/runtests.lpr

@@ -24,7 +24,7 @@ uses
   Classes, consoletestrunner,
   testglobals, testunits, dom,
   {Unit needed to set the LCL version and widget set name}
-  LCLVersion, InterfaceBase, Interfaces;
+  LCLVersion, InterfaceBase, Interfaces, testlazxml;
   
 type