+ writeidx program added

git-svn-id: trunk@1725 -

.gitattributes

@@ -1193,9 +1193,11 @@ installer/Makefile.fpc svneol=native#text/plain
 installer/install.dat -text
 installer/install.def -text
 installer/install.pas svneol=native#text/plain
+installer/insthelp.pas svneol=native#text/plain
 installer/makelink.pas svneol=native#text/plain
 installer/scroll.pas svneol=native#text/plain
 installer/winshell.pas svneol=native#text/plain
+installer/writeidx.pas svneol=native#text/plain
 packages/Makefile svneol=native#text/plain
 packages/Makefile.fpc svneol=native#text/plain
 packages/base/Makefile svneol=native#text/plain

installer/install.pas

@@ -90,7 +90,7 @@ program install;
      unzipdll,
 {$ENDIF}
      app,dialogs,views,menus,msgbox,colortxt,tabs,scroll,
-     WHTMLScn;
+     WHTMLScn,insthelp;
 
   const
      installerversion='1.0.8';
@@ -450,63 +450,6 @@ program install;
        GetProgDir := D;
     end;
 
-  function RTrim(const S: string): string;
-  var
-    i : longint;
-  begin
-    i:=length(s);
-    while (i>0) and (s[i]=' ') do
-     dec(i);
-    RTrim:=Copy(s,1,i);
-  end;
-
-  function LTrim(const S: string): string;
-  var
-    i : longint;
-  begin
-    i:=1;
-    while (i<length(s)) and (s[i]=' ') do
-     inc(i);
-    LTrim:=Copy(s,i,255);
-  end;
-
-  function Trim(const S: string): string;
-  begin
-    Trim:=RTrim(LTrim(S));
-  end;
-
-  function CompareText(S1, S2: string): integer;
-  var R: integer;
-  begin
-    S1:=Upcase(S1);
-    S2:=Upcase(S2);
-    if S1<S2 then R:=-1 else
-    if S1>S2 then R:= 1 else
-    R:=0;
-    CompareText:=R;
-  end;
-
-  function ExtOf(const S: string): string;
-  var D: DirStr; E: ExtStr; N: NameStr;
-  begin
-    FSplit(S,D,N,E);
-    ExtOf:=E;
-  end;
-
-  function DirAndNameOf(const S: string): string;
-  var D: DirStr; E: ExtStr; N: NameStr;
-  begin
-    FSplit(S,D,N,E);
-    DirAndNameOf:=D+N;
-  end;
-
-  function DirOf(const S: string): string;
-  var D: DirStr; E: ExtStr; N: NameStr;
-  begin
-    FSplit(S,D,N,E);
-    DirOf:=D;
-  end;
-
   function GetZipErrorInfo(error : longint) : string;
   var
     ErrorStr : string;

installer/insthelp.pas

@@ -0,0 +1,91 @@
+{
+    Helper routines for installer
+
+    This file is part of the Free Pascal installer.
+
+    Copyright (c) 1993-2005 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    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 insthelp;
+
+  interface
+
+    function RTrim(const S: string): string;
+    function LTrim(const S: string): string;
+    function Trim(const S: string): string;
+    function CompareText(S1, S2: string): integer;
+    function ExtOf(const S: string): string;
+    function DirAndNameOf(const S: string): string;
+    function DirOf(const S: string): string;
+
+  implementation
+
+    uses
+      dos;
+
+    function RTrim(const S: string): string;
+      var
+        i : longint;
+      begin
+        i:=length(s);
+        while (i>0) and (s[i]=' ') do
+         dec(i);
+        RTrim:=Copy(s,1,i);
+      end;
+
+    function LTrim(const S: string): string;
+      var
+        i : longint;
+      begin
+        i:=1;
+        while (i<length(s)) and (s[i]=' ') do
+         inc(i);
+        LTrim:=Copy(s,i,255);
+      end;
+
+    function Trim(const S: string): string;
+      begin
+        Trim:=RTrim(LTrim(S));
+      end;
+
+    function CompareText(S1, S2: string): integer;
+      var R: integer;
+      begin
+        S1:=Upcase(S1);
+        S2:=Upcase(S2);
+        if S1<S2 then R:=-1 else
+        if S1>S2 then R:= 1 else
+        R:=0;
+        CompareText:=R;
+      end;
+
+    function ExtOf(const S: string): string;
+      var D: DirStr; E: ExtStr; N: NameStr;
+      begin
+        FSplit(S,D,N,E);
+        ExtOf:=E;
+      end;
+
+    function DirAndNameOf(const S: string): string;
+      var D: DirStr; E: ExtStr; N: NameStr;
+      begin
+        FSplit(S,D,N,E);
+        DirAndNameOf:=D+N;
+      end;
+
+    function DirOf(const S: string): string;
+      var D: DirStr; E: ExtStr; N: NameStr;
+      begin
+        FSplit(S,D,N,E);
+        DirOf:=D;
+      end;
+
+  end.

installer/writeidx.pas

@@ -0,0 +1,112 @@
+{
+    Help program to generate html help index
+
+    This file is part of Free Pascal.
+    Copyright (c) 1993-2005 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+{$mode objfpc}
+  uses
+    insthelp,sysutils,dos,objects,WHTMLScn;
+
+  type
+    PFPHTMLFileLinkScanner = ^TFPHTMLFileLinkScanner;
+    TFPHTMLFileLinkScanner = object(THTMLFileLinkScanner)
+      function    CheckURL(const URL: string): boolean; virtual;
+      function    CheckText(const Text: string): boolean; virtual;
+      procedure   ProcessDoc(Doc: PHTMLLinkScanFile); virtual;
+    end;
+
+
+  const
+    HTMLIndexExt = '.htx';
+
+
+  procedure TFPHTMLFileLinkScanner.ProcessDoc(Doc: PHTMLLinkScanFile);
+    begin
+    end;
+
+
+  function TFPHTMLFileLinkScanner.CheckURL(const URL: string): boolean;
+    var OK: boolean;
+    const HTTPPrefix = 'http:';
+          FTPPrefix  = 'ftp:';
+    begin
+      OK:=inherited CheckURL(URL);
+      if OK then OK:=DirAndNameOf(URL)<>'';
+      if OK then OK:=CompareText(copy(ExtOf(URL),1,4),'.HTM')=0;
+      if OK then OK:=CompareText(copy(URL,1,length(HTTPPrefix)),HTTPPrefix)<>0;
+      if OK then OK:=CompareText(copy(URL,1,length(FTPPrefix)),FTPPrefix)<>0;
+      CheckURL:=OK;
+    end;
+
+
+  function TFPHTMLFileLinkScanner.CheckText(const Text: string): boolean;
+    var OK: boolean;
+      S: string;
+    begin
+      S:=Trim(Text);
+      OK:=(S<>'') and (copy(S,1,1)<>'[');
+      CheckText:=OK;
+    end;
+
+
+  procedure doerror(const s : ansistring);
+    begin
+      writeln(s);
+      writeln;
+      writeln('Press ENTER to continue');
+      readln;
+    end;
+
+
+  procedure writehlpindex(filename : ansistring);
+
+    var
+      LS : PFPHTMLFileLinkScanner;
+      BS : PBufStream;
+      Re : Word;
+      params : array[0..0] of pointer;
+      dir    : searchrec;
+
+    begin
+      writeln('Creating HTML index file, please wait ...');
+      New(LS, Init(DirOf(FileName)));
+      LS^.ProcessDocument(FileName,[soSubDocsOnly]);
+      if LS^.GetDocumentCount=0 then
+        doerror(format('Problem creating help index %1, aborting',[filename]))
+      else
+        begin
+          FileName:=DirAndNameOf(FileName)+HTMLIndexExt;
+          begin
+            New(BS, Init(FileName, stCreate, 4096));
+            if not(Assigned(BS)) then
+              doerror(format('Error while writing help index! '+
+                'No help index is created',[filename]))
+            else
+              begin
+                LS^.StoreDocuments(BS^);
+                if BS^.Status<>stOK then
+                  doerror(format('Error while writing help index! '+
+                    'No help index is created',[filename]));
+                Dispose(BS, Done);
+              end;
+          end;
+        end;
+      Dispose(LS, Done);
+    end;
+
+  begin
+    if paramcount<>1 then
+      writeln('Usage: writeidx <index name>')
+    else
+      writehlpindex(paramstr(1));
+  end.