program update_lcl_docs; { Runs the FPC fpdoc document generator to generate LCL and LazUtils documentation in CHM or HTML format } {$mode objfpc}{$H+} {$IFDEF MSWINDOWS} {$APPTYPE console} {$ENDIF} uses Classes, Sysutils, GetOpts, LazFileUtils, FileUtil, UTF8Process, LazStringUtils, Process; var DefaultFPDocExe: string = 'fpdoc'; DefaultCSSFile: string = 'fpdoc.css'; WarningsCount: Integer; Verbosity: integer; ShowCmd: Boolean; EnvParams: String; DefaultXCTDir: String; DefaultFPDocParams: string = ''; DefaultOutFormat: string = 'html'; DefaultFooterFilename: string = ''; // default is no footer(s) type TFPDocRunStep = ( frsCreated, frsVarsInitialized, frsFilesGathered, frsOutDirCreated, frsFPDocExecuted, frsCopiedToXCTDir, frsComplete ); TFPDocRunOption = ( foCopyToXCTDir // copy the created chm and xct file to the xct directory ); TFPDocRunOptions = set of TFPDocRunOption; const DefaultFPDocRunOptions = [foCopyToXCTDir]; type { TFPDocRun } TFPDocRun = class private FCSSFile: String; FFooterFilename: String; FFPDocExe: String; FIncludePath: string; FInputFile: string; FOptions: TFPDocRunOptions; FOutDir: string; FOutFormat: String; FPackageName: string; FPasSrcDir: string; FStep: TFPDocRunStep; FUsedPkgs: TStringList; FXCTDir: string; FXCTFile: string; FXMLSrcDir: string; FExtraOptions : String; procedure SetCSSFile(AValue: String); procedure SetFooterFilename(AValue: String); procedure SetIncludePath(AValue: string); procedure SetInputFile(AValue: string); procedure SetOutDir(AValue: string); procedure SetPasSrcDir(AValue: string); procedure SetXCTDir(AValue: string); procedure SetXMLSrcDir(AValue: string); public Params: TStringList; ParseParams: string; constructor Create(aPackageName: string); destructor Destroy; override; procedure InitVars; procedure AddFilesToList(Dir: String; List: TStrings); procedure FindSourceFiles; procedure CreateOutputDir; procedure RunFPDoc; procedure CopyToXCTDir; procedure Execute; property Options: TFPDocRunOptions read FOptions write FOptions default DefaultFPDocRunOptions; property CSSFile: String read FCSSFile write SetCSSFile; property FooterFilename: String read FFooterFilename write SetFooterFilename; property FPDocExe: String read FFPDocExe write FFPDocExe; property IncludePath: string read FIncludePath write SetIncludePath;// semicolon separated search path property InputFile: string read FInputFile write SetInputFile; // relative to OutDir, automatically created property OutDir: string read FOutDir write SetOutDir; property OutFormat: String read FOutFormat write FOutFormat; property PackageName: string read FPackageName; property PasSrcDir: string read FPasSrcDir write SetPasSrcDir; property Step: TFPDocRunStep read FStep; property UsedPkgs: TStringList read FUsedPkgs; // e.g. 'rtl','fcl', 'lcl', 'lazutils' property XCTDir: string read FXCTDir write SetXCTDir; property XMLSrcDir: string read FXMLSrcDir write SetXMLSrcDir; property XCTFile: string read FXCTFile; property ExtraOptions : string read FExtraOptions write FExtraOptions; end; procedure GetEnvDef(var S: String; DefaultValue: String; EnvName: String); begin S := GetEnvironmentVariable(EnvName); if S = '' then S := DefaultValue; end; function FileInEnvPATH(FileName: String): Boolean; var FullFilename: String; begin FullFilename:=FindDefaultExecutablePath(Filename); Result:=(FullFilename<>'') and not DirectoryExistsUTF8(FullFilename); end; procedure PrintHelp; begin WriteLn('Usage for '+ ExtractFileName(ParamStr(0)), ':'); WriteLn; Writeln(' --css-file (CHM format only) CSS file to be used by fpdoc'); Writeln(' for the layout of the help pages. Default is "',DefaultCSSFile,'"'); WriteLn(' --fpdoc The full path to fpdoc to use. Default is "',DefaultFPDocExe,'"'); WriteLn(' --fpcdocs The directory that contains the required .xct files.'); WriteLn(' Use this to make help that contains links to rtl and fcl'); WriteLn(' --footer Filename of a file to use a footer used in the generated pages.'); WriteLn(' Default is "'+DefaultFooterFilename+'"'); WriteLn(' --help Show this message'); WriteLn(' --arg Passes value to fpdoc as an arg. Use this option as'); WriteLn(' many times as needed.'); WriteLn(' --outfmt html|chm Use value as the format fpdoc will use. Default is "'+DefaultOutFormat+'"'); WriteLn(' --showcmd Print the command that would be run instead if running it.'); WriteLn(' --warnings Show warnings while working.'); WriteLn(' --verbose be more verbose'); WriteLn; WriteLn('The following are environment variables that will override the above params if set:'); WriteLn(' FPDOCFORMAT, FPDOCPARAMS, FPDOC, FPDOCFOOTER, FPCDOCS, RTLLINKPREFIX, FCLLINKPREFIX, LINKPREFIX, ...'); WriteLn; Halt(0); end; procedure ReadOptions; var c: char; Options: array of TOption; OptIndex: Longint; begin ShowCmd := False; WarningsCount:=-1; SetLength(Options, 10); Options[0].Name:='help'; Options[1].Name:='arg'; Options[1].Has_arg:=1; Options[2].Name:='fpdoc'; Options[2].Has_arg:=1; Options[3].Name:='outfmt'; Options[3].Has_arg:=1; Options[4].Name:='showcmd'; Options[5].Name:='fpcdocs'; Options[5].Has_arg:=1; Options[6].Name:='footer'; Options[6].Has_arg:=1; Options[7].Name:='warnings'; Options[8].Name:='css-file'; Options[8].Has_arg:=1; Options[9].Name:='verbose'; OptIndex:=0; repeat c := GetLongOpts('help arg: fpdoc: outfmt: showcmd fpcdocs: footer: warnings css-file verbose', @Options[0], OptIndex); case c of #0: begin //WriteLn(Options[OptIndex-1].Name, ' = ', OptArg); case OptIndex-1 of 0: PrintHelp; 1: DefaultFPDocParams := DefaultFPDocParams + ' ' + OptArg; 2: DefaultFPDocExe := OptArg; 3: DefaultOutFormat := OptArg; 4: ShowCmd := True; 5: DefaultXCTDir := OptArg; 6: DefaultFooterFilename := OptArg; 7: WarningsCount:=0; 8: DefaultCssFile := OptArg; 9: inc(Verbosity); else WriteLn('Unknown Value: ', OptIndex); end; end; '?': PrintHelp; EndOfOptions: Break; else WriteLn('Unknown option -',c,' ',OptArg); PrintHelp; end; until c = EndOfOptions; GetEnvDef(DefaultOutFormat, DefaultOutFormat, 'FPDOCFORMAT'); GetEnvDef(EnvParams, '', 'FPDOCPARAMS'); GetEnvDef(DefaultFPDocExe, DefaultFPDocExe, 'FPDOC'); GetEnvDef(DefaultFooterFilename, DefaultFooterFilename, 'FPDOCFOOTER'); GetEnvDef(DefaultXCTDir, DefaultXCTDir, 'FPCDOCS'); if DefaultOutFormat = '' then begin writeln('Error: Parameter outfmt is missing'); PrintHelp; end; end; { TFPDocRun } procedure TFPDocRun.SetInputFile(AValue: string); begin AValue:=TrimFilename(AValue); if FInputFile=AValue then Exit; FInputFile:=AValue; end; procedure TFPDocRun.SetOutDir(AValue: string); begin AValue:=TrimAndExpandFilename(AValue); if FOutDir=AValue then Exit; FOutDir:=AValue; end; procedure TFPDocRun.SetIncludePath(AValue: string); begin if FIncludePath=AValue then Exit; FIncludePath:=AValue; end; procedure TFPDocRun.SetCSSFile(AValue: String); begin AValue:=TrimAndExpandFilename(AValue); if FCSSFile=AValue then Exit; FCSSFile:=AValue; end; { Handles fpdoc 3.3.1 changed usage of the --footer argument. It can be either a string with the content for the footer, or a file name when prefixed with @. Handles both old and new syntax. @ cannot be included in the call to TrimAndExpandFilename. All file name validation occurs here. } procedure TFPDocRun.SetFooterFilename(AValue: String); var vFilename: String; begin vFileName := ''; if (AValue <> '') then begin // check for fpdoc 3.3.1 file name with @ prefix if (AValue[1] = '@') then begin vFilename := TrimAndExpandFilename(Copy(AValue, 2, Length(AValue)-1)); if not FileExistsUTF8(vFileName) then AValue := '"Footer file not found: @' + vFileName + '"' else AValue := '@' + vFilename; end // wrap anything with spaces in Quote characters when needed else if (Pos(' ', AValue) <> 0) and (aValue[1] <> '"') then begin AValue :='"' + AValue + '"'; end // expand and validate file name without the @ prefix else begin vFilename := TrimAndExpandFilename(AValue); if FileExistsUTF8(vFileName) then AValue := vFilename; end; end; if FFooterFilename = AValue then Exit; FFooterFilename := AValue; end; procedure TFPDocRun.SetPasSrcDir(AValue: string); begin AValue:=TrimAndExpandFilename(AValue); if FPasSrcDir=AValue then Exit; FPasSrcDir:=AValue; end; procedure TFPDocRun.SetXCTDir(AValue: string); begin AValue:=TrimAndExpandFilename(AValue); if FXCTDir=AValue then Exit; FXCTDir:=AValue; end; procedure TFPDocRun.SetXMLSrcDir(AValue: string); begin AValue:=TrimAndExpandFilename(AValue); if FXMLSrcDir=AValue then Exit; FXMLSrcDir:=AValue; end; constructor TFPDocRun.Create(aPackageName: string); begin FPackageName:=aPackageName; FOptions:=DefaultFPDocRunOptions; fUsedPkgs:=TStringList.Create; InputFile := 'inputfile.txt'; OutDir:=PackageName; FPDocExe:=TrimFilename(DefaultFPDocExe); CSSFile:=DefaultCSSFile; Params:=TStringList.Create; SplitCmdLineParams(DefaultFPDocParams,Params); OutFormat:=DefaultOutFormat; FooterFilename:=DefaultFooterFilename; XCTDir:=DefaultXCTDir; FStep:=frsCreated; end; destructor TFPDocRun.Destroy; begin FreeAndNil(fUsedPkgs); inherited Destroy; end; procedure TFPDocRun.InitVars; var Pkg, Prefix, IncludeDir, Param: String; p: Integer; begin if ord(Step)>=ord(frsVarsInitialized) then raise Exception.Create('TFPDocRun.InitVars not again'); // add IncludePath to ParseParams p:=1; while p<=length(IncludePath) do begin IncludeDir:=GetNextDelimitedItem(IncludePath,';',p); if IncludeDir='' then continue; IncludeDir:=TrimAndExpandFilename(ChompPathDelim(IncludeDir)); ParseParams+=' -Fi'+CreateRelativePath(IncludeDir,OutDir); end; FXCTFile:=AppendPathDelim(OutDir)+PackageName+'.xct'; Params.Add('--content='+CreateRelativePath(XCTFile,OutDir)); Params.Add('--package='+PackageName); Params.Add('--descr='+CreateRelativePath(AppendPathDelim(XMLSrcDir)+PackageName+'.xml',OutDir)); Params.Add('--format='+OutFormat); if FilenameIsAbsolute(InputFile) then Params.Add('--input=@'+CreateRelativePath(InputFile,OutDir)) else Params.Add('--input=@'+InputFile); if XCTDir <> '' then begin for Pkg in UsedPkgs do begin Prefix:=''; if OutFormat = 'html' then Prefix:='../'+Lowercase(Pkg)+'/' else if OutFormat = 'chm' then Prefix:='ms-its:'+LowerCase(Pkg)+'.chm::/' else Prefix:=''; GetEnvDef(Prefix, Prefix, UpperCase(Pkg)+'LINKPREFIX'); Param:='--import='+CreateRelativePath(AppendPathDelim(XCTDir)+LowerCase(Pkg)+'.xct',OutDir); if Prefix<>'' then Param+=','+Prefix; Params.Add(Param); end; end; if OutFormat='chm' then begin Params.Add('--output='+ ChangeFileExt(PackageName, '.chm')); Params.Add('--auto-toc'); Params.Add('--auto-index'); Params.Add('--make-searchable'); // set an explicit title used in the LHelp TOC navigation tree if (LowerCase(PackageName) = 'lcl') then Params.Add('--chm-title=(LCL) Lazarus Component Library') else Params.Add('--chm-title=(LazUtils) Lazarus Utilities'); if CSSFile<>'' then Params.Add('--css-file='+ExtractFileName(CSSFile)); // the css file is copied to the OutDir end; { In fpdoc 3.3.1 footerfilename is no longer just a file name. It can be the footer text or a file name when prefixed with @. Validation and quoting handled in the property setter. } if (FooterFilename<>'') then // and FileExistsUTF8(FooterFilename) then Params.Add('--footer='+FooterFilename); if EnvParams<>'' then SplitCmdLineParams(EnvParams,Params); if Verbosity>0 then begin writeln('Verbose Params: ------------------'); writeln('FPDocExe=',FPDocExe); writeln('OutFormat=',OutFormat); writeln('CSSFile=',CSSFile); writeln('FooterFilename=',FooterFilename); writeln('InputFile=',InputFile); writeln('OutDir=',OutDir); writeln('ParseParams='); writeln(ParseParams); writeln('FPDocParams='); writeln(Params.Text); writeln('----------------------------------'); end; FStep:=frsVarsInitialized; end; procedure TFPDocRun.AddFilesToList(Dir: String; List: TStrings); var FRec: TSearchRec; begin Dir:=AppendPathDelim(TrimFilename(Dir)); if FindFirstUTF8(Dir+AllFilesMask, faAnyFile, FRec)=0 then repeat //WriteLn('Checking file ' +FRec.Name); if (FRec.Name='') or (FRec.Name='.') or (FRec.Name='..') then continue; if (FRec.Name='fpmake.pp') then continue; if ((FRec.Attr and faDirectory) <> 0) then begin AddFilesToList(Dir+FRec.Name, List); //WriteLn('Checking Subfolder ',Dir+ FRec.Name); end else if FilenameHasPascalExt(FRec.Name) then begin List.Add(Dir+FRec.Name); end; until FindNextUTF8(FRec)<>0; FindCloseUTF8(FRec); end; procedure TFPDocRun.FindSourceFiles; var FileList: TStringList; InputList: TStringList; I: Integer; XMLFile, Filename: String; begin if ord(Step)>=ord(frsFilesGathered) then raise Exception.Create('TFPDocRun.FindSourceFiles already called'); if ord(Step)0 then writeln('PasSrcDir="',PasSrcDir,'"'); FileList := TStringList.Create; InputList := TStringList.Create; AddFilesToList(PasSrcDir, FileList); FileList.Sort; for I := 0 to FileList.Count-1 do begin XMLFile := AppendPathDelim(XMLSrcDir)+ExtractFileNameOnly(FileList[I])+'.xml'; if FileExistsUTF8(XMLFile) then begin InputList.Add(CreateRelativePath(FileList[I],OutDir) + ParseParams); Params.Add('--descr='+CreateRelativePath(XMLFile,OutDir)); end else begin if WarningsCount >= 0 then WriteLn('Warning! No corresponding xml file for unit ' + FileList[I]) else Dec(WarningsCount); end; end; FileList.Free; Filename:=InputFile; if not FilenameIsAbsolute(Filename) then Filename:=TrimFilename(AppendPathDelim(OutDir)+Filename); if ExtraOptions<>'' then for i:=0 to InputList.count-1 do InputList[i]:=ExtraOptions+' '+InputList[i]; InputList.SaveToFile(Filename); InputList.Free; FStep:=frsFilesGathered; end; procedure TFPDocRun.CreateOutputDir; var TargetCSSFile: String; begin if ord(Step)>=ord(frsOutDirCreated) then raise Exception.Create('TFPDocRun.CreateOutputDir already called'); if Not DirectoryExistsUTF8(OutDir) then begin writeln('Creating directory "',OutDir,'"'); if not CreateDirUTF8(OutDir) then raise Exception.Create('Unable to create directory "'+OutDir+'"'); end; if ord(Step)'') then begin TargetCSSFile:=AppendPathDelim(OutDir)+ExtractFileName(CSSFile); if CompareFilenames(TargetCSSFile,CSSFile)<>0 then begin if not CopyFile(CSSFile,TargetCSSFile) then raise Exception.Create('Unable to copy css file: CSSfile="'+CSSFile+'" to "'+TargetCSSFile+'"'); end; end; FStep:=frsOutDirCreated; end; procedure TFPDocRun.RunFPDoc; var Process: TProcess; CmdLine: String; begin if ord(Step)>=ord(frsFPDocExecuted) then raise Exception.Create('TFPDocRun.Run already called'); if ord(Step)0 then writeln('CmdLine: ',CmdLine); try Process.Execute; if Process.ExitCode<>0 then raise Exception.Create('fpdoc failed with code '+IntToStr(Process.ExitCode)); except if WarningsCount >= 0 then begin WriteLn('Error running fpdoc, command line: '+CmdLine) end else Dec(WarningsCount); end; if WarningsCount < -1 then WriteLn(abs(WarningsCount+1), ' Warnings hidden. Use --warnings to see them all.'); if not FileExistsUTF8(XCTFile) then raise Exception.Create('File not found: '+XCTFile); finally Process.Free; end; FStep:=frsFPDocExecuted; end; procedure TFPDocRun.CopyToXCTDir; var TargetXCTFile, SrcCHMFile, TargetCHMFile: String; begin if ord(Step)>=ord(frsCopiedToXCTDir) then raise Exception.Create('TFPDocRun.CopyToXCTDir already called'); if ord(Step)0) then begin TargetXCTFile:=AppendPathDelim(XCTDir)+ExtractFileName(XCTFile); if ShowCmd then writeln('cp ',XCTFile,' ',TargetXCTFile) else if not CopyFile(XCTFile,TargetXCTFile) then raise Exception.Create('Unable to copy xct file: "'+XCTFile+'" to "'+TargetXCTFile+'"'); writeln('Created ',TargetXCTFile); if OutFormat='chm' then begin SrcCHMFile:=AppendPathDelim(OutDir)+PackageName+'.chm'; TargetCHMFile:=AppendPathDelim(XCTDir)+PackageName+'.chm'; if ShowCmd then writeln('cp ',SrcCHMFile,' ',TargetCHMFile) else if not CopyFile(SrcCHMFile,TargetCHMFile) then raise Exception.Create('Unable to copy chm file: "'+SrcCHMFile+'" to "'+TargetCHMFile+'"'); writeln('Created ',TargetCHMFile); end; end; FStep:=frsCopiedToXCTDir; end; procedure TFPDocRun.Execute; begin writeln('==================================================================='); if ord(Step)>=ord(frsComplete) then raise Exception.Create('TFPDocRun.Execute already called'); if ord(Step)