examples: started repair function for fpdoc fragments

git-svn-id: trunk@28412 -

.gitattributes

@@ -3189,6 +3189,10 @@ examples/fontenum/fontenumeration.lpr svneol=native#text/pascal
 examples/fontenum/mainunit.lfm svneol=native#text/plain
 examples/fontenum/mainunit.lrs svneol=native#text/pascal
 examples/fontenum/mainunit.pas svneol=native#text/pascal
+examples/fpdocrepair/RepairFPDoc.lpi svneol=native#text/plain
+examples/fpdocrepair/RepairFPDoc.lpr svneol=native#text/plain
+examples/fpdocrepair/mainunit.lfm svneol=native#text/plain
+examples/fpdocrepair/mainunit.pas svneol=native#text/pascal
 examples/gridexamples/grid_semaphor/TSemaphorDBGrid.xpm -text svneol=native#image/x-xpixmap
 examples/gridexamples/grid_semaphor/example/project1.lpi svneol=native#text/plain
 examples/gridexamples/grid_semaphor/example/project1.lpr svneol=native#text/pascal

examples/fpdocrepair/RepairFPDoc.lpi

@@ -0,0 +1,86 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <SessionStorage Value="InIDEConfig"/>
+      <MainUnit Value="0"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="RepairFPDoc.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="RepairFPDoc"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="mainunit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="MainUnit"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="9"/>
+    <Target>
+      <Filename Value="RepairFPDoc"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerMessages>
+        <UseMsgFile Value="True"/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

examples/fpdocrepair/RepairFPDoc.lpr

@@ -0,0 +1,18 @@
+program RepairFPDoc;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, MainUnit
+  { you can add units after this };
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+

examples/fpdocrepair/mainunit.lfm

@@ -0,0 +1,9 @@
+object Form1: TForm1
+  Left = 275
+  Height = 240
+  Top = 250
+  Width = 320
+  Caption = 'Form1'
+  OnCreate = FormCreate
+  LCLVersion = '0.9.29'
+end

examples/fpdocrepair/mainunit.pas

@@ -0,0 +1,388 @@
+unit MainUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, LCLProc,
+  contnrs;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    procedure FormCreate(Sender: TObject);
+  private
+  public
+    procedure TestComment;
+    procedure TestInvalidCharacters;
+    function Test(Title, Fragment, FixedFragment: string): boolean;
+  end;
+
+var
+  Form1: TForm1; 
+
+procedure FixFPDocFragment(var Fragment: string; Fix: boolean;
+  out ErrorList: TObjectList);
+
+implementation
+
+{$R *.lfm}
+
+type
+  TFPDocFragmentError = class
+  public
+    ErrorPos: integer;
+    Msg: string;
+  end;
+
+procedure FixFPDocFragment(var Fragment: string; Fix: boolean;
+  out ErrorList: TObjectList);
+{ - Fix all tags to lowercase to reduce svn commits
+  - remove unneeded spaces
+     < b   =>  <b
+     b >   =>  b>
+     a  b  =>  a b
+  - auto close comments
+  - remove #0 from comments
+  - auto close unclosed tags
+  - fix & without ;
+  - convert special characters to &x;
+  - fix unclosed attribute values
+}
+type
+  TStackItemTyp = (
+    sitTag,
+    sitComment
+    );
+  TStackItem = record
+    Typ: TStackItemTyp;
+    StartPos: integer;
+    NameStartPos: integer;
+    NameEndPos: integer;
+    EndPos: integer;
+  end;
+  PStackItem = ^TStackItem;
+var
+  Stack: PStackItem;
+  Capacity: integer;
+  Top: integer;
+  TopItem: PStackItem;
+  p: PChar;
+
+  function Rel(pt: PChar): integer;
+  begin
+    Result:=pt-PChar(Fragment)+1;
+  end;
+
+  function LineCol(pt: integer): string;
+  var
+    Line: Integer;
+    Col: Integer;
+    i: Integer;
+  begin
+    Line:=1;
+    Col:=1;
+    if pt>length(Fragment) then pt:=length(Fragment)+1;
+    i:=1;
+    while i<pt do begin
+      case Fragment[i] of
+      #10,#13:
+        begin
+          inc(Line);
+          inc(i);
+          if (i<=length(Fragment)) and (Fragment[i] in [#10,#13])
+            and (Fragment[i-1]<>Fragment[i])
+          then
+            inc(i);
+          Col:=1;
+        end;
+      else
+        inc(Col);
+      end;
+      inc(i);
+    end;
+    Result:=IntToStr(Line)+','+IntToStr(Col);
+  end;
+
+  procedure Error(ErrorPos: PChar; ErrorMsg: string);
+  var
+    NewError: TFPDocFragmentError;
+  begin
+    debugln(['Error ',ErrorMsg]);
+    if ErrorList=nil then
+      ErrorList:=TObjectList.Create(true);
+    NewError:=TFPDocFragmentError.Create;
+    NewError.ErrorPos:=Rel(ErrorPos);
+    NewError.Msg:=ErrorMsg;
+    ErrorList.Add(NewError);
+  end;
+
+  procedure Replace(StartPos, Len: integer; const NewTxt: string);
+  var
+    i: Integer;
+    Item: PStackItem;
+    Diff: Integer;
+    OldP: integer;
+  begin
+    OldP:=Rel(p);
+    Fragment:=copy(Fragment,1,StartPos-1)+NewTxt
+                                  +copy(Fragment,StartPos+Len,length(Fragment));
+    Diff:=length(NewTxt)-Len;
+    if Diff<>0 then begin
+      // adjust positions
+      if OldP>StartPos then
+        inc(OldP,Diff);
+      for i:=0 to Top do begin
+        Item:=@Stack[i];
+        if Item^.StartPos>StartPos then inc(Item^.StartPos,Diff);
+        if Item^.EndPos>StartPos then inc(Item^.EndPos,Diff);
+        if Item^.NameStartPos>StartPos then inc(Item^.NameStartPos,Diff);
+        if Item^.NameEndPos>StartPos then inc(Item^.NameEndPos,Diff);
+      end;
+    end;
+    p:=PChar(Fragment)+OldP-1;
+    debugln(['Replace ',dbgstr(copy(Fragment,1,Rel(p)-1)),'|',dbgstr(copy(Fragment,Rel(p),length(Fragment)))]);
+  end;
+
+  procedure HandleSpecialChar;
+  var
+    c: Integer;
+  begin
+    c:=ord(p^);
+    if Fix then begin
+      case p^ of
+      #0..#31,#127:
+        // delete
+        Replace(Rel(p),1,'');
+      '<': Replace(Rel(p),1,'&lt;');
+      '>': Replace(Rel(p),1,'&gt;');
+      '&': Replace(Rel(p),1,'&amp;');
+      '''': Replace(Rel(p),1,'&apos;');
+      '"': Replace(Rel(p),1,'&quot;');
+      else
+        // convert
+        Replace(Rel(p),1,'&'+IntToStr(c)+';');
+      end;
+    end
+    else begin
+      // skip
+      Error(p,'invalid character #'+IntToStr(c));
+      inc(p);
+    end;
+  end;
+
+  procedure Push(Typ: TStackItemTyp);
+  begin
+    inc(Top);
+    if Top=Capacity then begin
+      inc(Capacity);
+      ReAllocMem(Stack,SizeOf(TStackItem)*Capacity);
+    end;
+    TopItem:=@Stack[Top];
+    FillByte(TopItem^,SizeOf(TStackItem),0);
+    TopItem^.Typ:=Typ;
+    TopItem^.StartPos:=p-PChar(Fragment);
+  end;
+
+  procedure Pop;
+  begin
+    if Top<0 then raise Exception.Create('bug');
+    dec(Top);
+  end;
+
+  procedure ParseComment;
+  begin
+    // comment
+    Push(sitComment);
+    inc(p,4);
+    // parse comment
+    repeat
+      if p^ in [#0..#8,#11,#12,#14..#31,#127] then begin
+        // invalid character in comment => delete
+        if (p^=#0) and (p-PChar(Fragment)=length(Fragment)) then
+        begin
+          // reached end of fragment => close comment
+          if Fix then begin
+            Replace(Rel(p),0,'-->');
+            inc(p,3);
+          end else
+            Error(p,'comment end not found, start at '+LineCol(TopItem^.StartPos));
+          break;
+        end else begin
+          // invalid #0 character in comment => delete
+          if Fix then
+            Replace(Rel(p),1,'')
+          else begin
+            Error(p,'invalid character');
+            inc(p);
+          end;
+        end;
+      end else if (p^='-') and (p[1]='-') and (p[2]='>') then
+      begin
+        // comment end found
+        inc(p,3);
+        break;
+      end else
+        inc(p);
+    until false;
+    Pop;
+  end;
+
+  procedure ParseAmpersand;
+  var
+    AmpPos: PChar;
+    i: Integer;
+    NeedLowercase: PChar;
+    len: integer;
+  begin
+    AmpPos:=p;
+    // &amp; or &name; or &decimal;
+    case p[1] of
+    '0'..'9':
+      begin
+        // decimal number
+        inc(p);
+        i:=ord(p^)-ord('0');
+        while p^ in ['0'..'9'] do
+        begin
+          i:=i+10+ord(p^)-ord('0');
+          if i>$10FFFF then
+            break;
+          inc(p);
+        end;
+        if p^=';' then
+        begin
+          // ok
+          inc(p);
+          exit;
+        end;
+      end;
+    'a'..'z','A'..'Z':
+      begin
+        // name
+        inc(p);
+        NeedLowercase:=nil;
+        while p^ in ['a'..'z','A'..'Z'] do begin
+          if (NeedLowercase=nil) and (p^ in ['A'..'Z']) then
+            NeedLowercase:=p;
+          inc(p);
+        end;
+        if p^=';' then begin
+          if NeedLowercase<>nil then begin
+            if Fix then begin
+              len:=(p-AmpPos)-1;
+              Replace(Rel(AmpPos)+1,len,lowercase(copy(Fragment,Rel(AmpPos)+1,len)));
+            end else begin
+              Error(NeedLowercase,'special character name is not lower case');
+              inc(p);
+            end;
+          end else begin
+            // ok
+            inc(p);
+          end;
+          exit;
+        end;
+      end;
+    end;
+    p:=AmpPos;
+    // invalid character => convert or skip
+    HandleSpecialChar;
+  end;
+
+begin
+  ErrorList:=nil;
+  if Fragment='' then exit;
+  Top:=-1;
+  Capacity:=0;
+  Stack:=nil;
+  try
+    p:=PChar(Fragment);
+    repeat
+      case p^ of
+      #0..#8,#11,#12,#14..#31,#127:
+        begin
+          if (p^=#0) and (p-PChar(Fragment)=length(Fragment)) then
+          begin
+            // reached end of fragment
+            break;
+          end else begin
+            // invalid character => convert or skip
+            HandleSpecialChar;
+          end;
+        end;
+      '<':
+        begin
+          // comment, tag or 'lower than'
+          if (p[1]='!') and (p[2]='-') and (p[3]='-') then
+            // comment
+            ParseComment
+          else begin
+            // invalid character => convert or skip
+            HandleSpecialChar;
+          end;
+        end;
+      '>':
+        // invalid character => convert or skip
+        HandleSpecialChar;
+      '&':
+        ParseAmpersand;
+      else
+        inc(p);
+      end;
+    until false;
+    if Top>=0 then begin
+      // ToDo: fix unclosed tags
+      debugln(['FixFPDocFragment ToDo: fix unclosed tags']);
+    end;
+  finally
+    ReAllocMem(Stack,0);
+  end;
+end;
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  TestComment;
+  TestInvalidCharacters;
+end;
+
+procedure TForm1.TestComment;
+begin
+  Test('close comment','<!--','<!---->');
+  Test('close comment and delete invalid char','<!--null'#0#1#2'comment','<!--nullcomment-->');
+end;
+
+procedure TForm1.TestInvalidCharacters;
+begin
+  Test('delete special characters','A'#0'B'#1#127,'AB');
+  Test('replace tag characters','LT<GT>AMP&','LT&lt;GT&gt;AMP&amp;');
+  Test('lower case special characters','&LT;','&lt;');
+end;
+
+function TForm1.Test(Title, Fragment, FixedFragment: string): boolean;
+var
+  s: String;
+  ErrorList: TObjectList;
+begin
+  Result:=true;
+  try
+    s:=Fragment;
+    FixFPDocFragment(s,true,ErrorList);
+    if s<>FixedFragment then begin
+      Result:=false;
+      debugln(['failed: ',Title]);
+      debugln(['  fragment: '+DbgStr(Fragment)]);
+      debugln(['  should:   '+DbgStr(FixedFragment)]);
+      debugln(['  result:   '+DbgStr(s)]);
+    end;
+  finally
+    ErrorList.Free;
+  end;
+end;
+
+end.
+