From 9077a895caec93011e9b4299ada17b61dbb30263 Mon Sep 17 00:00:00 2001
From: macpgmr
') = 0 then {Found footnotes?}
+ begin
+ while not Eof(OldFileVar) do
+ begin
+ ReadLn(OldFileVar, InStr);
+ if Pos('MsoFootnoteText', InStr) > 0 then {Found a footnote?}
+ begin
+ FnStr := InStr;
+ repeat
+ ReadLn(OldFileVar, InStr);
+ if InStr <> '' then
+ FnStr := FnStr + ' ' + InStr;
+ until InStr = '';
+ TopicStr := Copy(FnStr, Pos('', FnStr) + 5, MaxInt);
+ TopicStr := Copy(TopicStr, 1, Length(TopicStr)-4);
+ if Pos('_', TopicStr) > 0 then
+ begin
+ FnPos := Pos('name=', FnStr) + 6;
+ FnRef := '';
+ repeat
+ FnRef := FnRef + FnStr[FnPos];
+ Inc(FnPos);
+ until FnStr[FnPos] = '"';
+ Footnotes.Add(FnRef + '=' + TopicStr);
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ Reset(OldFileVar);
+ {Process input file}
+ while not Eof(OldFileVar) do
+ begin
+ ReadLn(OldFileVar, InStr);
+ if CompareText(Copy(InStr, 1, 7), '
') = 0 then {Found footnotes?}
+ begin
+ repeat {Skip over footnotes}
+ ReadLn(OldFileVar, InStr);
+ until CompareText(InStr, '
+ +
+ + MacPgmr (at) fastermac (dot) net
+ +Note: You can also post to the Lazarus forum if you want your bug reports +and suggestions to be seen by the entire Lazarus community.
+ +The XDev Toolkit source code is here: http://web.fastermac.net/~MacPgmr/XDev/downloads
+ +All source code included in the XDev Toolkit is released under the Modified LGPL license. + +
+
+ +fpc -Sd DfmToLfm.pas + +
+ +dfmtolfm + +
+ +Once you've converted a Delphi app to Lazarus you can continue to +develop the app with Delphi on Windows and use Lazarus to compile +the app on other platforms. This type of app can provide the best of both +worlds: taking advantage of the Windows-specific features of Delphi while +utilizing Free Pascal and Lazarus to add cross-platform capability to the app. + +
+
+
+
+
+
+cvthelp myapp.htm myapp.html +
+
+Application.HelpFile := ChangeFileExt(ParamStr(0), '.html');
+HelpManager := THelpUtilManager.Create; +
+HelpManager.Free; +
+Application.HelpContext(1); +
+ +
+ +chmod +x create_app_mac.sh
+ +
+ +./create_app_mac.sh myapp "My Application"
+
+ +
+ +TRichEdit is a handy control for creating or displaying simple reports, +but if you try to use it for more than that you will be quickly disappointed +because TRichEdit has serious limitations. For one thing, Borland never added +support to TRichEdit for newer versions of the Rich Edit library (RICHED20.DLL). +And although it's possible to hack the Delphi ComCtrls unit to add support +for RICHED20.DLL, Microsoft never fixed some of the bugs in this library +or supported more than just a subset of RTF.
+ +Since Lazarus is a cross-platform tool, it doesn't provide a TRichEdit control. +And even if it did, this type of control might not meet your needs. After all, +TRichEdit is trying to be a word processor, something the creators of Word +and OpenOffice.org have spent many years developing. Wouldn't it make more +sense just to use an actual word processor to create and display reports? + +
+ +Fortunately Free Pascal includes a unit named RtfPars that includes the +TRtfParser class. While this class was designed to parse and proof existing +RTF documents, you can also run it "backwards" to create RTF documents as well.
+ +To simplify use of the TRtfParser class, the XDev Toolkit includes unit RtfDoc, +which introduces a TRtfParser descendant, TRtfDoc, which can be used +to create RTF files without knowing how TRtfParser works. For information +on how to use it, look at the RtfDoc.pas file and TestRtfDoc.pas example +program. You'll also want to look at the Free Pascal rtfdata.inc file for +a list of constants that you'll need to use with TRtfDoc.
+ +For more information on the RTF specification, refer to Microsoft's documentation.
+ +
+ +Why would you need to clean up after launching the word processor? Usually +this step is necessary because the report document will be a temporary file +that you'll want to delete. You probably shouldn't require your users to name +each report document that your program creates. This will quickly annoy them; +it also forces your users to clean up the clutter of saved report documents. +Instead, you should use the GetTempFilename function (in the Lazarus FileUtil +unit) to get a file name to use for your temporary file, then delete this file +yourself at some point after launching the word processor. (Don't use the same +file name for all reports since this will restrict your users to viewing only +one report at a time.)
+ +But how can you delete a file if it's open in another program? Remember, your +word processor is running externally to your program and locks the file as +long as it's open. The file and the word processor won't be closed until the +user decides to close them. And even if the file has already been closed, +are you sure you want to delete it? What if your user made changes to the +report and saved it?
+ +The solution that ViewDocument uses is to start the word processor with +a switch that tells it to create a new document based on the report file +(that is, using it as a template). ViewDocument can also add the report file +to a list of temporary files to be deleted when your program shuts down. Even +though your program still can't delete the temporary file as long as the new +document based on it is open in the word processor, this does mean that if +the user saves the new document, it won't be with the report file's name.
+ +To delete the temporary files created by your program, call the DeleteViewedDocs +function in your main form's FormCloseQuery handler. If DeleteViewedDocs +returns False, you can remind your user to save or close any reports still +open in the word processor. DeleteViewedDocs is also called by the ViewDoc +unit's finalization code to clean up whatever it can when the program finally +does shut down.
+ +One final note: With OS X, the normal way to start a program from a terminal +command line or when shelling is to use the Open command. Unfortunately, the +only parameter that Open passes along to the program is the name of the file +to open, so there's no way to pass any switches to Word or NeoOffice. With OS X, +ViewDocument instead sets the temporary report file to read-only, thus forcing +the user to use a different name when saving the report. A disadvantage of this +approach is that the word processor shows the name of the temporary file in +the title bar (for example, rpt1.tmp) rather than Document1 or Untitled1 as it +normally does with a new document. ViewDocument also uses this approach with +AbiWord, which doesn't appear to support a command line template switch. + +
+
+ +http://wiki.lazarus.freepascal.org/Multiplatform_Programming_Guide
+ +http://wiki.lazarus.freepascal.org/OS_X_Programming_Tips
+ +http://wiki.lazarus.freepascal.org/Deploying_Your_Application
+
+
+ +
') = 0; + WriteLn(NewFileVar, InStr); + end + + else {Found normal line} + begin {See if it contains link to topic} + LinkPos := Pos('', InStr); + if LinkPos > 0 then {Line contains link?} + begin + PrevInStr := InStr; + ReadLn(OldFileVar, InStr); {Get next line too} + InStr := PrevInStr + ' ' + InStr; {Combine} + for FootIdx := 0 to Footnotes.Count -1 do + begin + TopicStr := Footnotes.ValueFromIndex[FootIdx]; + if Pos(TopicStr, InStr) > 0 then + begin + UnlinkPos := Pos('', InStr); + Write(NewFileVar, Copy(InStr, 1, LinkPos-1), + '', + Copy(InStr, LinkPos+3, UnlinkPos-LinkPos-3), '', + Copy(InStr, UnlinkPos+4, MaxInt)); + end; + end; + end + else + WriteLn(NewFileVar, InStr); + end; + end; + + MapSection.Free; + Footnotes.Free; + CloseFile(OldFileVar); + CloseFile(NewFileVar); + +end. + diff --git a/components/xdev_toolkit/DfmToLfm.ini b/components/xdev_toolkit/DfmToLfm.ini new file mode 100644 index 000000000..efecaaaef --- /dev/null +++ b/components/xdev_toolkit/DfmToLfm.ini @@ -0,0 +1,107 @@ + +; DfmToLfm program configuration file. +; Be sure to add "=" after each key you add. The key's value can be omitted +; as it has no meaning to DfmToLfm. + +; DfmToLfm deletes these .dfm properties when creating .lfm file. +; Note: If no class is specified, deletes that property from all classes. + +[DeleteProps] +IsControl= +;NumGlyphs= +OldCreateOrder= +WantReturns= +Ctl3D= +ParentCtl3D= +OnClickCheck= +Flat= +IntegralHeight= +DesignSize= +AutoSelect= +BiDiMode= +ParentBiDiMode= +HideSelection= +ImeMode= +ImeName= +OEMConvert= +TRadioGroup.TabOrder= +TBitBtn.ParentFont= +TCheckBox.Font.Charset= +TCheckBox.Font.Color= +TCheckBox.Font.Height= +TCheckBox.Font.Name= +TCheckBox.Font.Style= +TCheckBox.ParentFont= +TCheckGroup.Font.Charset= +TCheckGroup.Font.Color= +TCheckGroup.Font.Height= +TCheckGroup.Font.Name= +TCheckGroup.Font.Style= +TCheckGroup.ParentFont= +TCheckListBox.Font.Charset= +TCheckListBox.Font.Color= +TCheckListBox.Font.Height= +TCheckListBox.Font.Name= +TCheckListBox.Font.Style= +TCheckListBox.ParentFont= +TRadioButton.Font.Charset= +TRadioButton.Font.Color= +TRadioButton.Font.Height= +TRadioButton.Font.Name= +TRadioButton.Font.Style= +TRadioButton.ParentFont= +TRadioGroup.Font.Charset= +TRadioGroup.Font.Color= +TRadioGroup.Font.Height= +TRadioGroup.Font.Name= +TRadioGroup.Font.Style= +TRadioGroup.ParentFont= +TBevel.Font.Charset= +TBevel.Font.Color= +TBevel.Font.Height= +TBevel.Font.Name= +TBevel.Font.Style= +TTabSheet.Font.Charset= +TTabSheet.Font.Color= +TTabSheet.Font.Height= +TTabSheet.Font.Name= +TTabSheet.Font.Style= +TNotebook.Font.Charset= +TNotebook.Font.Color= +TNotebook.Font.Height= +TNotebook.Font.Name= +TNotebook.Font.Style= +TNotebook.ParentFont= +TLabeledEdit.Font.Charset= +TLabeledEdit.Font.Color= +TLabeledEdit.Font.Height= +TLabeledEdit.Font.Name= +TLabeledEdit.Font.Style= + + +; When -p switch is used with DfmToLfm, don't try to add parent's font +; properties to these classes since they don't have font in LCL. + +[NoFont] +TMainMenu= +TMenuItem= +TScrollBar= +TImage= +TTabSheet= +TCheckBox= +TCheckGroup= +TCheckListBox= +TRadioButton= +TRadioGroup= +TActionList= +TShape= +TBevel= +TNotebook= +TLabeledEdit= +TSplitter= +TOvcController= +TOvcSpinner= +TOvcTCCheckBox= +TOvcTCBitmap= +TOvcTCGlyphs= +TOvcTCIcon= diff --git a/components/xdev_toolkit/DfmToLfm.pas b/components/xdev_toolkit/DfmToLfm.pas new file mode 100644 index 000000000..8ae514ca4 --- /dev/null +++ b/components/xdev_toolkit/DfmToLfm.pas @@ -0,0 +1,318 @@ +program DfmToLfm; + +{ + Converts Delphi form design file to a Lazarus form file by + deleting properties that are not supported by LCL and + optionally making changes to font properties. The resulting + Lazarus form file can then be converted to a Lazarus resource + file with LazRes. + Note that the Delphi form file must be a text file. + List of properties to delete and other configuration settings + are read from DfmToLfm.ini. + This utility (and Lazarus LazRes) can be used whenever design + changes are made to the form in Delphi. + Note: Use MakePasX to make the form's code file cross-platform + (a one-time conversion). + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. +} + +uses + SysUtils, + IniFiles; + +const + ProgramName = 'DfmToLfm'; + ProgramVersion = '0.01'; + + DfmFileExt = '.dfm'; {Delphi form file extension} + LfmFileExt = '.lfm'; {Lazarus form file extension} + CfgFileExt = '.ini'; {Extension for file with same name as program + containing configuration settings} + + NoFontChanges = 0; {No font switch on command line} + UseParentFont = 1; {-p font switch on command line} + DeleteFontName = 2; {-d font switch on command line} + + MaxNestedObjs = 20; {Maximum depth of nested controls on form} + MaxFontProps = 5; {Maximum font properties that can be saved} + +type + TStackRec = record {Info about form objects} + ClassName : string; + FontPropCnt : Integer; + FontAdded : Boolean; + FontProps : array [1..MaxFontProps] of string; + end; + +var + CfgFileName : string; +{$IFNDEF FPC} + MatchFound : TFilenameCaseMatch; +{$ENDIF} + FontSwitch : Integer; + CfgFileObj : TMemIniFile; + DfmFileName : string; + LfmFileName : string; + DfmFileVar : TextFile; + LfmFileVar : TextFile; + StackLevel : Integer; + StackRec : array [1..MaxNestedObjs] of TStackRec; + DeleteLine : Boolean; + InStr : string; + StripStr : string; + SkipStr : string; + ParentLevel : Integer; + FontPropNum : Integer; + +begin + + {Base configuration file name on program file location and program name} + CfgFileName := ExtractFilePath(ParamStr(0)) + ProgramName + CfgFileExt; +{$IFNDEF FPC} + CfgFileName := ExpandFileNameCase(CfgFileName, MatchFound); +{$ENDIF} + + if ParamCount = 0 then {List program syntax and exit?} + begin + WriteLn(ProgramName, ', version ', ProgramVersion, + ' - converts a Delphi form file to a Lazarus form file.'); + WriteLn('Usage: ', ProgramName, ' filename', DfmFileExt, ' [-p|-d]'); + WriteLn('Switches:'); + WriteLn(' -p Add parent''s font to controls with no font ', + '(useful with Windows).'); + WriteLn(' -d Delete font name from controls ', + '(useful with OS X and Linux).'); + WriteLn('Looks for configuration data in file ', CfgFileName); + Halt; + end; + + {Check for command line switches} + FontSwitch := NoFontChanges; + if FindCmdLineSwitch('p', ['-'], True) then + FontSwitch := UseParentFont + else if FindCmdLineSwitch('d', ['-'], True) then + FontSwitch := DeleteFontName; + + {Load configuration file} + if not FileExists(CfgFileName) then + begin + WriteLn('Can''t load program configuration file ', CfgFileName); + Halt; + end; + CfgFileObj := TMemIniFile.Create(CfgFileName); + + {Get name of Delphi form file from command line} + DfmFileName := ParamStr(1); + if ExtractFileExt(DfmFileName) = '' then + DfmFileName := DfmFileName + DfmFileExt; +{$IFNDEF FPC} + DfmFileName := ExpandFileNameCase(DfmFileName, MatchFound); +{$ELSE} + DfmFileName := ExpandFileName(DfmFileName); +{$ENDIF} + + {Base Lazarus form file name on Delphi form file name} + LfmFileName := ChangeFileExt(DfmFileName, LfmFileExt); + + {Open Delphi form file} + AssignFile(DfmFileVar, DfmFileName); + try + Reset(DfmFileVar); + except + on EInOutError do + begin + WriteLn('Can''t open Delphi form file ', DfmFileName); + Halt; + end; + end; + + {Create Lazarus form file} + AssignFile(LfmFileVar, LfmFileName); + try + Rewrite(LfmFileVar); + except + on EInOutError do + begin + WriteLn('Can''t create Lazarus form file ', LfmFileName); + Halt; + end; + end; + + StackLevel := 0; + while not Eof(DfmFileVar) do {Read and process Delphi form file} + begin + DeleteLine := False; + ReadLn(DfmFileVar, InStr); {Read property from form file} + StripStr := StringReplace(InStr, ' ', '', [rfReplaceAll]); {Strip spaces} + + if ((CompareText('object ', Copy(Trim(InStr), 1, 7)) = 0) or + (CompareText('end', StripStr) = 0)) and {End of object's props reached?} + (StackLevel > 1) and {Object is nested?} + (not CfgFileObj.ValueExists( + 'NoFont', StackRec[StackLevel].ClassName)) and {Class has font?} + (StackRec[StackLevel].FontPropCnt = 0) and {Object has no font?} + (FontSwitch = UseParentFont) and {Okay to insert parent font in object?} + (not StackRec[StackLevel].FontAdded) then {Font not inserted yet?} + begin + ParentLevel := StackLevel; + repeat + Dec(ParentLevel); + until (ParentLevel = 0) or + (StackRec[ParentLevel].FontPropCnt > 0); + if ParentLevel > 0 then {A parent has font?} + begin {Add font properties to current object} + for FontPropNum := 1 to StackRec[ParentLevel].FontPropCnt do + begin + WriteLn(LfmFileVar, StringOfChar(' ', (StackLevel-ParentLevel)*2), + StackRec[ParentLevel].FontProps[FontPropNum]); + end; + end; + StackRec[StackLevel].FontAdded := True; + end; + + if CompareText('object ', Copy(Trim(InStr), 1, 7)) = 0 then + begin {Push object's class name on stack} + Inc(StackLevel); + if Pos(': ', InStr) > 0 then {Named control?} + StackRec[StackLevel].ClassName := + Trim(Copy(InStr, Pos(': ', InStr)+2, MaxInt)) + else {Unnamed control} + StackRec[StackLevel].ClassName := Trim(Copy(Trim(InStr), 7, MaxInt)); + StackRec[StackLevel].FontPropCnt := 0; + StackRec[StackLevel].FontAdded := False; + end + + else if CompareText('end', StripStr) = 0 then + begin {Pop current class from stack} + Dec(StackLevel); + end + + else if CompareText('font.', Copy(Trim(InStr), 1, 5)) = 0 then + begin {Font property} + if FontSwitch <> NoFontChanges then + begin + if FontSwitch = UseParentFont then + begin {Save font property in case need it for child objects} + if StackRec[StackLevel].FontPropCnt < MaxFontProps then + begin + Inc(StackRec[StackLevel].FontPropCnt); + StackRec[StackLevel].FontProps[StackRec[StackLevel].FontPropCnt] := + InStr; + end; + end + else {FontSwitch = DeleteFontName} + begin + if CompareText('font.name', Copy(Trim(InStr), 1, 9)) = 0 then + DeleteLine := True; + end; + end; + {Check if font property should be deleted from current object} + if CfgFileObj.ValueExists('DeleteProps', + StackRec[StackLevel].ClassName + '.' + + Copy(StripStr, 1, Pos('=', StripStr)-1)) then + DeleteLine := True; + end + + else {Other property} + begin {Check if property should be deleted from current object} + if CfgFileObj.ValueExists('DeleteProps', + Copy(StripStr, 1, Pos('=', StripStr)-1)) or + CfgFileObj.ValueExists('DeleteProps', + StackRec[StackLevel].ClassName + '.' + + Copy(StripStr, 1, Pos('=', StripStr)-1)) then + begin {Property or class.property in list of props to delete?} + DeleteLine := True; + if Copy(StripStr, Length(StripStr), 1) = '(' then {Delete > 1 line?} + begin + repeat + ReadLn(DfmFileVar, SkipStr); + SkipStr := Trim(SkipStr); + until Copy(SkipStr, Length(SkipStr), 1) = ')'; + end; + end; + end; + + if not DeleteLine then {Include line in Lazarus form file?} + begin + try + {If Delphi form file does have Height and Width, reduce + to size of its ClientHeight or ClientWidth.} + if ((StackLevel = 1) and + (CompareText('Height=', Copy(StripStr, 1, 7)) = 0)) then + WriteLn(LfmFileVar, + ' Height = ', + IntToStr(StrToInt(Copy(StripStr, 8, MaxInt)) - 34)) + else if ((StackLevel = 1) and + (CompareText('Width=', Copy(StripStr, 1, 6)) = 0)) then + WriteLn(LfmFileVar, + ' Width = ', + IntToStr(StrToInt(Copy(StripStr, 7, MaxInt)) - 8)) + + {LCL TGroupBox child controls' Top measures from a lower position + within group box than with VCL, so reduce Top value} + else if (StackLevel > 1) and + (CompareText('Top=', Copy(StripStr, 1, 4)) = 0) and + (CompareText('TGroupBox', + StackRec[Pred(StackLevel)].ClassName) = 0) then + WriteLn(LfmFileVar, + Copy(InStr, 1, Succ(Pos('=', InStr))), + IntToStr(StrToInt(Copy(StripStr, 5, MaxInt)) - 16)) + + {Lazarus IDE appears to swap Top and Left properties for non-visual + controls, so swap them for Orpheus table cell controls.} + else if ((CompareText('Top=', Copy(StripStr, 1, 4)) = 0) or + (CompareText('Left=', Copy(StripStr, 1, 5)) = 0)) and + ((CompareText('TOvcTC', + Copy(StackRec[StackLevel].ClassName, 1, 6)) = 0) or + (CompareText('TO32TC', + Copy(StackRec[StackLevel].ClassName, 1, 6)) = 0) or + (CompareText('TOvcController', + StackRec[StackLevel].ClassName) = 0)) then + begin + if CompareText('Top=', Copy(StripStr, 1, 4)) = 0 then + WriteLn(LfmFileVar, + StringReplace(InStr, 'Top', 'Left', [rfIgnoreCase])) + else + WriteLn(LfmFileVar, + StringReplace(InStr, 'Left', 'Top', [rfIgnoreCase])); + end + + else {No change to property} + WriteLn(LfmFileVar, InStr); + + {Delphi form files don't always include Height or Width properties, + which are required by Lazarus, so add them based on ClientHeight + and ClientWidth properties, which apparently act the same as + Height and Width in Lazarus (unlike Delphi).} + if (CompareText('ClientHeight=', Copy(StripStr, 1, 13)) = 0) or + (CompareText('ClientWidth=', Copy(StripStr, 1, 12)) = 0) then + WriteLn(LfmFileVar, + StringReplace(InStr, 'Client', '', [rfIgnoreCase])); + except + on EInOutError do + begin + WriteLn('Can''t write to Lazarus form file ', LfmFileName); + Halt; + end; + end; + end; + end; {while not Eof} + + CloseFile(DfmFileVar); + try + CloseFile(LfmFileVar); + except + on EInOutError do + begin + WriteLn('Can''t close Lazarus form file ', LfmFileName); + Halt; + end; + end; + CfgFileObj.Free; + WriteLn(LfmFileName, ' successfully created'); + +end. + diff --git a/components/xdev_toolkit/HelpUtil.pas b/components/xdev_toolkit/HelpUtil.pas new file mode 100644 index 000000000..65ed840d8 --- /dev/null +++ b/components/xdev_toolkit/HelpUtil.pas @@ -0,0 +1,154 @@ +unit HelpUtil; + +{ + + Isolates platform-specific help access for Lazarus LCL. + + Assumes Application.HelpFile is set. + + Create THelpUtilManager object in main form's FormCreate handler and + call its Free method in main form's FormDestroy handler. + + Display help topic by calling Application.HelpContext. + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. This means you can link your code to this + compiled unit (statically in a standalone executable or + dynamically in a library) without releasing your code. Only + changes to this unit need to be made publicly available. + +} + +interface + +uses + SysUtils, +{$IFDEF MSWINDOWS} + Windows, +{$ELSE} + Unix, +{$ENDIF} +{$IFDEF LINUX} + FileUtil, +{$ENDIF} + Forms, + Dialogs, + HelpIntfs; + +type + THelpUtilManager = class(THelpManager) + destructor Destroy; override; + procedure ShowError( ShowResult : TShowHelpResult; + const ErrMsg : string); override; + function ShowHelpForQuery( Query : THelpQuery; + AutoFreeQuery : Boolean; + var ErrMsg : string): TShowHelpResult; override; + end; + + +implementation + + +const + HELP_CONTEXT = 1; + HELP_QUIT = 2; + +function DoHelpCommand(Command : Word; + Data : LongInt) : Boolean; +begin +{$IFDEF MSWINDOWS} {LCL doesn't have TApplication.HelpCommand, so call Win API} + Result := WinHelp(Application.MainForm.Handle, + PChar(Application.HelpFile), + Command, Data); +{$ENDIF} +end; {DoHelpCommand} + + + {THelpUtilManager} + +destructor THelpUtilManager.Destroy; +begin +{$IFDEF MSWINDOWS} + DoHelpCommand(HELP_QUIT, 0); + {Shut down help application if running and not in use + by another instance of program} +{$ENDIF} + inherited Destroy; +end; + +procedure THelpUtilManager.ShowError( ShowResult : TShowHelpResult; + const ErrMsg : string); +begin + if ShowResult = shrHelpNotFound then + MessageDlg('Help not implemented.', mtError, [mbOK], 0) + else if ShowResult = shrViewerNotFound then + MessageDlg('Help viewer not found.', mtError, [mbOK], 0) + else if ShowResult = shrViewerError then + MessageDlg('Unable to start help viewer.', mtError, [mbOK], 0) + else if ShowResult <> shrSuccess then + MessageDlg(ErrMsg, mtError, [mbOK], 0); +end; + +function THelpUtilManager.ShowHelpForQuery( Query : THelpQuery; + AutoFreeQuery : Boolean; + var ErrMsg : string): TShowHelpResult; +{$IFDEF LINUX} + function SearchForBrowser(const BrowserFileName : string) : string; + begin + Result := + SearchFileInPath(BrowserFileName, '', GetEnvironmentVariable('PATH'), + PathSeparator, [sffDontSearchInBasePath]); + end; + + function GetBrowserPath : string; + begin + Result := SearchForBrowser('firefox'); + if Result = '' then + Result := SearchForBrowser('konqueror'); {KDE browser} + if Result = '' then + Result := SearchForBrowser('epiphany'); {GNOME browser} + if Result = '' then + Result := SearchForBrowser('mozilla'); + if Result = '' then + Result := SearchForBrowser('opera'); + end; +{$ENDIF} + +begin + if Query is THelpQueryContext then {Is a help context request?} + begin + {$IFDEF MSWINDOWS} + DoHelpCommand(HELP_CONTEXT, THelpQueryContext(Query).Context); + Result := shrSuccess; + {$ELSE} + {$IFDEF DARWIN} + if Shell('Open -a "Help Viewer" "' + Application.HelpFile + '"') = 127 then +// Note: With OS X earlier than 10.4 (Tiger), if connected to network +// but not connected to Internet, takes Help Viewer 1-2 minutes to +// recover and turn off rotating ball! Can comment out previous Shell +// and uncomment next line to use default browser instead. +// if Shell('Open "' + Application.HelpFile + '"') = 127 then + Result := shrViewerError + else + Result := shrSuccess; + {$ELSE} {For now, shell to first browser found, passing help file name} + if GetBrowserPath <> '' then {Found a browser?} + begin + if Shell(GetBrowserPath + ' ' + Application.HelpFile) = 127 then + Result := shrViewerError + else + Result := shrSuccess; + end + else + Result := shrViewerNotFound; + {$ENDIF} + {$ENDIF} + end + else {Not a help context request?} + Result := inherited ShowHelpForQuery(Query, AutoFreeQuery, ErrMsg); +end; {THelpUtilManager.ShowHelpForQuery} + + +end. + diff --git a/components/xdev_toolkit/MakePasX.pas b/components/xdev_toolkit/MakePasX.pas new file mode 100644 index 000000000..ab5c8e1cc --- /dev/null +++ b/components/xdev_toolkit/MakePasX.pas @@ -0,0 +1,220 @@ +program MakePasX; + +{ + Makes Delphi form code file or project file cross-platform + so it can be compiled by both Delphi and Lazarus/FPC. + Note that this is a one-time conversion. + Note: Use DfmToLfm to convert form's design file to LCL + whenever changes are made to form in Delphi. + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. +} + +uses + SysUtils; + +const + ProgramName = 'MakePasX'; + ProgramVersion = '0.01'; + + PasFileExt = '.pas'; {Pascal code file extension} + DelProjFileExt = '.dpr'; {Delphi project file extension} + TmpFileExt = '.tmp'; {Create converted file with this extension} + BakFileExt = '.bak'; {Rename original file with this extension} + +var + OldFileName : string; + NewFileName : string; + OldFileVar : TextFile; + NewFileVar : TextFile; +{$IFNDEF FPC} + MatchFound : TFilenameCaseMatch; +{$ENDIF} + IsProject : Boolean; + InStr : string; + FoundUses : Boolean; + Done : Boolean; + UnitPos : Integer; + HasAppInit : Boolean; + HasForm : Boolean; + +begin + + if ParamCount = 0 then {List program useage?} + begin + WriteLn(ProgramName, ', version ', ProgramVersion, + ' - makes Delphi code file cross-platform.'); + WriteLn('Usage: ', ProgramName, ' filename[', PasFileExt, '|', + DelProjFileExt, ']'); + Halt; + end; + + {Get name of Pascal code file to convert from command line} + OldFileName := ParamStr(1); + if ExtractFileExt(OldFileName) = '' then {No extension?} + OldFileName := OldFileName + PasFileExt; {Assume it's not a project file} +{$IFNDEF FPC} + OldFileName := ExpandFileNameCase(OldFileName, MatchFound); +{$ELSE} + OldFileName := ExpandFileName(OldFileName); +{$ENDIF} + + IsProject := CompareText(ExtractFileExt(OldFileName), DelProjFileExt) = 0; + + NewFileName := ChangeFileExt(OldFileName, TmpFileExt); + + {Open code file} + AssignFile(OldFileVar, OldFileName); + try + Reset(OldFileVar); + except + on EInOutError do + begin + WriteLn('Can''t open Pascal code file ', OldFileName); + Halt; + end; + end; + + {Create new code file} + AssignFile(NewFileVar, NewFileName); + try + Rewrite(NewFileVar); + except + on EInOutError do + begin + WriteLn('Can''t create new code file ', NewFileName); + Halt; + end; + end; + + FoundUses := False; + HasAppInit := False; + HasForm := False; + while not Eof(OldFileVar) do {Read and convert Pascal code file} + begin + ReadLn(OldFileVar, InStr); {Read line of code} + + if not IsProject then {Form code file?} + begin + if (CompareText(InStr, 'uses') = 0) and {Found uses section?} + (not FoundUses) then {And in interface section?} + begin {Note assumes "uses" appears on separate line from list of units} + FoundUses := True; + WriteLn(NewFileVar, InStr); + WriteLn(NewFileVar, + ' {$IFNDEF LCL} Windows, Messages, ', + '{$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF}'); + ReadLn(OldFileVar, InStr); + repeat + UnitPos := Pos('WINDOWS,', UpperCase(InStr)); + if UnitPos > 0 then + Delete(InStr, UnitPos, 8); + if Copy(InStr, UnitPos, 1) = ' ' then + Delete(InStr, UnitPos, 1); + UnitPos := Pos('MESSAGES,', UpperCase(InStr)); + if UnitPos > 0 then + Delete(InStr, UnitPos, 9); + if Copy(InStr, UnitPos, 1) = ' ' then + Delete(InStr, UnitPos, 1); + UnitPos := Pos('WINTYPES,', UpperCase(InStr)); {Synonym for Windows} + if UnitPos > 0 then + Delete(InStr, UnitPos, 9); + if Copy(InStr, UnitPos, 1) = ' ' then + Delete(InStr, UnitPos, 1); + UnitPos := Pos('WINPROCS,', UpperCase(InStr)); {Synonym for Windows} + if UnitPos > 0 then + Delete(InStr, UnitPos, 9); + if Copy(InStr, UnitPos, 1) = ' ' then + Delete(InStr, UnitPos, 1); + WriteLn(NewFileVar, InStr); + Done := Pos(';', InStr) > 0; + if not Done then + ReadLn(OldFileVar, InStr); + until Done; + end {uses section} + + else if CompareText(Copy(Trim(InStr), 1, 10), + '{$R *.dfm}') = 0 then {Form's resource file?} + begin + WriteLn(NewFileVar, '{$IFNDEF LCL}'); + WriteLn(NewFileVar, InStr); + WriteLn(NewFileVar, '{$ENDIF}'); + HasForm := True; + end + + else if (CompareText(InStr, 'end.') = 0) and HasForm then {End of unit?} + begin + {Note: Make sure IFDEF goes after initialization since Delphi + inserts new event handlers immediately before initialization line.} + WriteLn(NewFileVar, 'initialization'); + WriteLn(NewFileVar, '{$IFDEF LCL}'); + WriteLn(NewFileVar, '{$I ', ChangeFileExt(ExtractFileName(OldFileName), + '.lrs} {Include form''s resource file}')); + WriteLn(NewFileVar, '{$ENDIF}'); + WriteLn(NewFileVar); + WriteLn(NewFileVar, InStr); + end + + else {Nothing to change with this line} + WriteLn(NewFileVar, InStr); + end + + else {Delphi project file} + begin + if (CompareText(InStr, 'uses') = 0) and {Found uses section?} + (not FoundUses) then {And in interface section?} + begin {Note assumes "uses" appears on separate line from list of units} + FoundUses := True; + WriteLn(NewFileVar, InStr); + WriteLn(NewFileVar, '{$IFDEF LCL}'); + WriteLn(NewFileVar, ' Interfaces,'); + WriteLn(NewFileVar, '{$ENDIF}'); + end + else if (CompareText(Copy(Trim(InStr), 1, 10), '{$R *.res}') = 0) or + (CompareText(Copy(Trim(InStr), 1, 10), '{$R *.r32}') = 0) or + (CompareText(Copy(Trim(InStr), 1, 10), '{$R *.r16}') = 0) then + begin {Program's resource file} + WriteLn(NewFileVar, '{$IFDEF MSWINDOWS}'); + WriteLn(NewFileVar, InStr); + WriteLn(NewFileVar, '{$ENDIF}'); + end + else if CompareText(Copy(Trim(InStr), 1, 3), '{$R') = 0 then + begin {Might be a type library or XP manifest resource file} + WriteLn(NewFileVar, '{$IFNDEF FPC}'); + WriteLn(NewFileVar, InStr); + WriteLn(NewFileVar, '{$ENDIF}'); + end + else if Pos('APPLICATION.INITIALIZE', UpperCase(InStr)) > 0 then + begin + HasAppInit := True; + WriteLn(NewFileVar, InStr); + end + else + begin + if (not HasAppInit) and + ((Pos('APPLICATION.CREATEFORM', UpperCase(InStr)) > 0) or + (Pos('APPLICATION.RUN', UpperCase(InStr)) > 0)) then + begin + WriteLn(NewFileVar, ' Application.Initialize;'); {Laz needs this} + HasAppInit := True; + end; + WriteLn(NewFileVar, InStr); + end; + end; + + end; {while not Eof} + + DeleteFile(ChangeFileExt(OldFileName, BakFileExt)); + CloseFile(OldFileVar); + RenameFile(OldFileName, ChangeFileExt(OldFileName, BakFileExt)); + CloseFile(NewFileVar); + if not IsProject then + RenameFile(NewFileName, ChangeFileExt(NewFileName, PasFileExt)) + else + RenameFile(NewFileName, ChangeFileExt(NewFileName, DelProjFileExt)); + WriteLn(OldFileName, ' successfully converted.'); + +end. + diff --git a/components/xdev_toolkit/MakeVer.pas b/components/xdev_toolkit/MakeVer.pas new file mode 100644 index 000000000..f3ca7f7d8 --- /dev/null +++ b/components/xdev_toolkit/MakeVer.pas @@ -0,0 +1,79 @@ +program MakeVer; + +{ + Makes INI-style version file from Delphi .dof file. + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. +} + +uses + SysUtils, + Classes, + IniFiles; + +const + ProgramName = 'MakeVer'; + ProgramVersion = '0.01'; + + DofFileExt = '.dof'; {Delphi project options file extension} + VerFileExt = '.version'; {Linux/Mac version info file extension} + + VersionSection = 'Version Info Keys'; + +var + DofFileName : string; + VerFileName : string; + DofIniFile : TIniFile; + VerIniFile : TIniFile; + VerStrList : TStringList; +{$IFNDEF FPC} + MatchFound : TFilenameCaseMatch; +{$ENDIF} + ItemNum : Integer; + +begin + + if ParamCount = 0 then {List program useage?} + begin + WriteLn(ProgramName, ', version ', ProgramVersion, + ' - makes INI-style version file from Delphi .dof file.'); + WriteLn('Usage: ', ProgramName, ' filename', DofFileExt); + Halt; + end; + + {Get name of Delphi project options file from command line} + DofFileName := ParamStr(1); + if ExtractFileExt(DofFileName) = '' then + DofFileName := DofFileName + DofFileExt; +{$IFNDEF FPC} + DofFileName := ExpandFileNameCase(DofFileName, MatchFound); +{$ELSE} + DofFileName := ExpandFileName(DofFileName); +{$ENDIF} + + VerFileName := ChangeFileExt(DofFileName, VerFileExt); + + if not FileExists(DofFileName) then + begin + WriteLn(DofFileName, ' does not exist'); + Halt; + end; + + DofIniFile := TIniFile.Create(DofFileName); + VerStrList := TStringList.Create; + DofIniFile.ReadSectionValues(VersionSection, VerStrList); {Load vers strings} + VerIniFile := TIniFile.Create(VerFileName); + for ItemNum := 0 to Pred(VerStrList.Count) do {Write to version file} + begin + VerIniFile.WriteString(VersionSection, VerStrList.Names[ItemNum], + VerStrList.Values[VerStrList.Names[ItemNum]]); + end; + VerIniFile.UpdateFile; {Save to file} + VerIniFile.Free; + DofIniFile.Free; + WriteLn(VerFileName, ' successfully created'); + +end. + diff --git a/components/xdev_toolkit/ReadMe.txt b/components/xdev_toolkit/ReadMe.txt new file mode 100644 index 000000000..29a162218 --- /dev/null +++ b/components/xdev_toolkit/ReadMe.txt @@ -0,0 +1,5 @@ + +This is the XDev Toolkit. + +See XDevStatus.html for more information. + diff --git a/components/xdev_toolkit/RtfDoc.pas b/components/xdev_toolkit/RtfDoc.pas new file mode 100644 index 000000000..09c5010fc --- /dev/null +++ b/components/xdev_toolkit/RtfDoc.pas @@ -0,0 +1,256 @@ +unit RtfDoc; + +{ + Class for creating RTF document. + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. This means you can link your code to this + compiled unit (statically in a standalone executable or + dynamically in a library) without releasing your code. Only + changes to this unit need to be made publicly available. +} + +interface + +uses + SysUtils, + RtfPars; + +type + TRtfDoc = class(TObject) + private + FParser : TRTFParser; + procedure DoGroup; + procedure DoCtrl; + procedure DoText; +{$IFDEF FPC} + procedure HandleError(s : ShortString); +{$ELSE} {Delphi} + procedure HandleError(s : string); +{$ENDIF} + protected + FFileName : string; + FFileVar : TextFile; + public + constructor Create; + destructor Destroy; override; + property Parser : TRTFParser read FParser; + property FileName : string read FFileName; + procedure Start(const FileName : string); virtual; + procedure Done; virtual; + procedure OutDefaultFontTable(DefFont : Integer); virtual; + procedure OutToken( AClass : Integer; + Major : Integer; + Minor : Integer; + Param : Integer; + const Text : string); virtual; + procedure OutCtrl(Major : Integer; + Minor : Integer; + Param : Integer); virtual; + procedure OutText(const Text : string); virtual; + end; + + +implementation + +constructor TRtfDoc.Create; +begin + inherited Create; + FParser := TRTFParser.Create(nil); +end; + + +destructor TRtfDoc.Destroy; +begin + Parser.Free; + inherited Destroy; +end; + + +procedure TRtfDoc.Start(const FileName : string); +var + CurYear : Word; + CurMonth : Word; + CurDay : Word; + CurHour : Word; + CurMinute : Word; + CurSecond : Word; + CurSec100 : Word; +begin + FFileName := FileName; + AssignFile(FFileVar, FFileName); + Rewrite(FFileVar); + + Parser.ResetParser; + + Parser.ClassCallbacks[rtfGroup] := DoGroup; + Parser.ClassCallbacks[rtfText] := DoText; + Parser.ClassCallbacks[rtfControl] := DoCtrl; + Parser.DestinationCallbacks[rtfFontTbl] := nil; + Parser.DestinationCallbacks[rtfColorTbl] := nil; + Parser.DestinationCallbacks[rtfInfo] := nil; + Parser.OnRTFError := HandleError; + + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfVersion, -1, 1); + OutCtrl(rtfCharSet, rtfAnsiCharSet, rtfNoParam); + + {Output document creation date and time} + DecodeDate(Now, CurYear, CurMonth, CurDay); + DecodeTime(Now, CurHour, CurMinute, CurSecond, CurSec100); + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfDestination, rtfInfo, rtfNoParam); + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfSpecialChar, rtfICreateTime, rtfNoParam); + OutCtrl(rtfSpecialChar, rtfIYear, CurYear); + OutCtrl(rtfSpecialChar, rtfIMonth, CurMonth); + OutCtrl(rtfSpecialChar, rtfIDay, CurDay); + OutCtrl(rtfSpecialChar, rtfIHour, CurHour); + OutCtrl(rtfSpecialChar, rtfIMinute, CurMinute); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + WriteLn(FFileVar); + +end; {TRtfDoc.Start} + + +procedure TRtfDoc.OutDefaultFontTable(DefFont : Integer); +begin + {Output default font number} + OutCtrl(rtfDefFont, -1, DefFont); + {Output font table} + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfDestination, rtfFontTbl, rtfNoParam); + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfCharAttr, rtfFontNum, 0); + OutToken(rtfControl, rtfFontFamily, rtfFFModern, rtfNoParam, + 'Courier New;'); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfCharAttr, rtfFontNum, 1); + OutToken(rtfControl, rtfFontFamily, rtfFFRoman, rtfNoParam, + 'Times New Roman;'); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + OutToken(rtfGroup, rtfBeginGroup, -1, rtfNoParam, ''); + OutCtrl(rtfCharAttr, rtfFontNum, 2); + OutToken(rtfControl, rtfFontFamily, rtfFFSwiss, rtfNoParam, + 'Arial;'); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + WriteLn(FFileVar); +end; {TRtfDoc.OutDefaultFontTable} + + +procedure TRtfDoc.Done; +begin + WriteLn(FFileVar); + OutToken(rtfGroup, rtfEndGroup, -1, rtfNoParam, ''); + CloseFile(FFileVar); +end; + + +procedure TRtfDoc.OutToken( AClass : Integer; + Major : Integer; + Minor : Integer; + Param : Integer; + const Text : string); +begin + Parser.SetToken(AClass, Major, Minor, Param, Text); + Parser.RouteToken; + if Text <> '' then + Write(FFileVar, Text); +end; + + +procedure TRtfDoc.OutCtrl(Major : Integer; + Minor : Integer; + Param : Integer); +begin + OutToken(rtfControl, Major, Minor, Param, ''); +end; + + +procedure TRtfDoc.OutText(const Text : string); +var + CharNum : Integer; +begin + for CharNum := 1 to Length(Text) do + OutToken(rtfText, Ord(Text[CharNum]), 0, rtfNoParam, ''); +end; + + +procedure TRtfDoc.DoGroup; +begin + if Parser.rtfMajor = rtfBeginGroup then + Write(FFileVar, '{') + else + Write(FFileVar, '}'); +end; + + +procedure TRtfDoc.DoCtrl; +var + RtfIdx : Integer; +begin + if (Parser.rtfMajor = rtfSpecialChar) and + (Parser.rtfMinor = rtfPar) then + WriteLn(FFileVar); {Make RTF file more human readable} + RtfIdx := 0; + while rtfKey[RtfIdx].rtfKStr <> '' do + begin + if (Parser.rtfMajor = rtfKey[RtfIdx].rtfKMajor) and + (Parser.rtfMinor = rtfKey[RtfIdx].rtfKMinor) then + begin + Write(FFileVar, '\'); + Write(FFileVar, rtfKey[RtfIdx].rtfKStr); + if Parser.rtfParam <> rtfNoParam then + Write(FFileVar, IntToStr(Parser.rtfParam)); + if rtfKey[RtfIdx].rtfKStr <> '*' then + Write(FFileVar, ' '); + Exit; + end; + Inc(RtfIdx); + end; +end; {TRtfDoc.DoCtrl} + + +procedure TRtfDoc.DoText; +var + AChar : Char; +begin + {rtfMajor contains the character ASCII code, + so just output it for now, preceded by \ + if special char.} + AChar := Chr(Parser.rtfMajor); + case AChar of + '\' : Write(FFileVar, '\\'); + '{' : Write(FFileVar, '\{'); + '}' : Write(FFileVar, '\}'); + else + begin + if AChar > #127 then {8-bit ANSI character?} + Write(FFileVar, '\''' + IntToHex(Ord(AChar), 2)) {Encode using 7-bit chars} + else {7-bit ANSI character} + Write(FFileVar, AChar); + end; + end; +end; {TRtfDoc.DoText} + + +{$IFDEF FPC} +procedure TRtfDoc.HandleError(s : ShortString); +begin + WriteLn(StdErr, s); +end; +{$ELSE} {Delphi} +procedure TRtfDoc.HandleError(s : string); +begin + WriteLn(ErrOutput, S); +end; +{$ENDIF} + + + +end. + diff --git a/components/xdev_toolkit/TestRtfDoc.pas b/components/xdev_toolkit/TestRtfDoc.pas new file mode 100644 index 000000000..4cf68d74c --- /dev/null +++ b/components/xdev_toolkit/TestRtfDoc.pas @@ -0,0 +1,45 @@ +program TestRtfDoc; + +{ + Test program for RtfDoc unit. +} + +uses + SysUtils, + RtfPars, {Free Pascal unit with TRtfParser class and rtf constants} + RtfDoc; {Descendant class used in this program} + +begin + + with TRtfDoc.Create do {Create TRtfDoc object} + begin + try + + try + Start('test.rtf'); {Create RTF file} + except + on EInOutError do {File read-only or some other I/O error} + begin + WriteLn('Can''t create file'); + Exit; + end; + end; + + OutDefaultFontTable(2); {Select font 2 (Arial) as default} + + OutCtrl(rtfParAttr, rtfQuadCenter, rtfNoParam); {Center line} + OutCtrl(rtfCharAttr, rtfBold, 1); {Turn on bolding} + OutText('Hello'); {Output some text} + OutCtrl(rtfCharAttr, rtfBold, 0); {Turn off bolding} + OutText(' there!'); {Output some more text} + OutCtrl(rtfSpecialChar, rtfPar, rtfNoParam); {End of paragraph} + + Done; {Close RTF file} + + finally + Free; {Free TRtfDoc object} + end; + end; + +end. + diff --git a/components/xdev_toolkit/ViewDoc.pas b/components/xdev_toolkit/ViewDoc.pas new file mode 100644 index 000000000..12f63894d --- /dev/null +++ b/components/xdev_toolkit/ViewDoc.pas @@ -0,0 +1,391 @@ +unit ViewDoc; + +{ + + Unit of functions for viewing documents with a word processor. + + Author: Phil Hess. + Copyright: Copyright (C) 2007 Phil Hess. All rights reserved. + License: Modified LGPL. This means you can link your code to this + compiled unit (statically in a standalone executable or + dynamically in a library) without releasing your code. Only + changes to this unit need to be made publicly available. + +} + +interface + +uses + SysUtils, + Classes, +{$IFDEF MSWINDOWS} + Windows, + Registry, + ShellApi; +{$ENDIF} +{$IFDEF DARWIN} {OS X} + BaseUnix, + Unix; +{$ENDIF} +{$IFDEF LINUX} + FileUtil, + Unix; +{$ENDIF} + +type + TViewerOptions = set of (ovwUseAsTemplate, ovwAddToDeleteList); + +function GetViewerCount : Integer; + +function GetViewerName(Viewer : Integer) : string; + +function ViewDocument(const FileName : string; + Viewer : Integer; + Options : TViewerOptions; + var ErrorMsg : string) : Boolean; + +function DeleteViewedDocs : Boolean; + + +implementation + +const +{$IFDEF MSWINDOWS} + MaxViewers = 3; {Number of supported word processors} + + {Names of word processors} + ViewerName : array [1..MaxViewers] of string = + ('Microsoft Word', + 'OpenOffice', + 'AbiWord'); + + {Executable files} + ViewerExe : array [1..MaxViewers] of string = + ('WINWORD.EXE', + 'SOFFICE.EXE', + 'AbiWord.exe'); + + {Command line startup switches. + If non-blank, start word processor with a new document + based on the specified template. If blank, open document + read-only to force user to save under different name.} + ViewerSwitch : array [1..MaxViewers] of string = + ('/t', + '-n ', + ''); + + ViewerRegKey : array [1..MaxViewers] of string = + ('', + '', + 'SOFTWARE\Classes\AbiSuite.AbiWord\shell\open\command'); +{$ENDIF} + +{$IFDEF DARWIN} {OS X} + MaxViewers = 4; + + ViewerName : array [1..MaxViewers] of string = + ('Microsoft Word', + 'Pages', + 'NeoOffice', + 'AbiWord'); + + {OS X Open command doesn't support passing switches to app} + ViewerSwitch : array [1..MaxViewers] of string = + ('', + '', + '', + ''); + + MaxViewerFolders = 7; + + ViewerFolders : array [1..MaxViewerFolders] of string = + ('Microsoft Word', + 'Microsoft Office 2004/Microsoft Word', + 'Microsoft Office X/Microsoft Word', + 'Pages.app', + 'iWork ''06/Pages.app', + 'NeoOffice.app', + 'AbiWord.app'); +{$ENDIF} + +{$IFDEF LINUX} + MaxViewers = 2; + + ViewerName : array [1..MaxViewers] of string = + ('OpenOffice', + 'AbiWord'); + + ViewerExe : array [1..MaxViewers] of string = + ('soffice.bin', + 'abiword'); + + ViewerSwitch : array [1..MaxViewers] of string = + ('-n ', + ''); +{$ENDIF} + + +var + DeleteList : TStringList; {List of files to delete when program exits; + object is created and destroyed in unit's + initialization and finalization sections} + + +function GetViewerCount : Integer; + {Return number of viewers defined.} +begin + Result := MaxViewers; +end; + + +function GetViewerName(Viewer : Integer) : string; + {Return viewer's name.} +begin + Result := ViewerName[Viewer]; +end; + + +function LocateViewer(Viewer : Integer) : string; + {Return path to viewer's executable file, + or blank string if can't locate viewer.} +{$IFDEF MSWINDOWS} +var + Reg : TRegistry; +begin + Result := ''; + {With Windows, installed programs usually have Registry entries + under the App Paths section, including complete path to program.} + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + if ViewerRegKey[Viewer] = '' then + begin + if Reg.OpenKeyReadOnly( + '\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\' + + ViewerExe[Viewer]) then + begin {Found key, so assume program is installed} + try + if Reg.ReadString('') <> '' then {Key has (Default) registry entry?} + Result := Reg.ReadString(''); + except {Trap exception if registry entry does not contain a string} + end; + end; + end + else {Non-standard registry key} + begin + if Reg.OpenKeyReadOnly(ViewerRegKey[Viewer]) then + begin {Found key, so assume program is installed} + try + if Reg.ReadString('') <> '' then {Key as (Default) registry entry?} + begin + Result := Reg.ReadString(''); + if Copy(Result, 1, 1) = '"' then {Strip first quoted item?} + Result := Copy(Result, 2, Pos('"', Copy(Result, 2, MaxInt))-1); + end; + except + end; + end; + end; + finally + Reg.Free; + end; +{$ENDIF} + +{$IFDEF DARWIN} //TODO: Search for app like OS X LaunchServices does. +var + FolderIdx : Integer; + LocIdx : Integer; + PathPrefix : string; +begin + Result := ''; + FolderIdx := 0; + while (FolderIdx < MaxViewerFolders) and (Result = '') do + begin + Inc(FolderIdx); + if Pos(LowerCase(ViewerName[Viewer]), + LowerCase(ViewerFolders[FolderIdx])) > 0 then + begin + LocIdx := 0; + while (LocIdx < 4) and (Result = '') do + begin + Inc(LocIdx); + case LocIdx of + 1 : PathPrefix := '/Applications/'; + 2 : PathPrefix := '~/Applications/'; + 3 : PathPrefix := '~/Desktop/'; + 4 : PathPrefix := '~/' + end; + if FileExists(PathPrefix + ViewerFolders[FolderIdx]) then + Result := PathPrefix + ViewerFolders[FolderIdx]; + end; + end; + end; +{$ENDIF} + +{$IFDEF LINUX} +begin + {Search path for specified file name, returning its + expanded file name that includes path to it.} + Result := SearchFileInPath( + ViewerExe[Viewer], '', GetEnvironmentVariable('PATH'), + PathSeparator, [sffDontSearchInBasePath]); +{$ENDIF} +end; {LocateViewer} + + +function LaunchViewer(const ProgPath : string; + const Params : string; + const DefaultDir : string) : Integer; + {Start viewer program with specified command line parameters + by shelling to it, returning shell's code.} +{$IFDEF MSWINDOWS} +var + ProgPathBuf : array [0..MAX_PATH] of Char; + ParamsBuf : array [0..MAX_PATH] of Char; + DefaultDirBuf : array [0..MAX_PATH] of Char; +begin + StrPCopy(ProgPathBuf, ProgPath); + StrPCopy(ParamsBuf, Params); + StrPCopy(DefaultDirBuf, DefaultDir); + Result := ShellExecute(0, nil, ProgPathBuf, ParamsBuf, DefaultDirBuf, + SW_SHOWNORMAL); +{$ENDIF} + +{$IFDEF DARWIN} +begin + Result := Shell('Open -a ' + ProgPath + ' ' + Params); +{$ENDIF} + +{$IFDEF LINUX} +begin + Result := Shell(ProgPath + ' ' + Params); +{$ENDIF} +end; {LaunchViewer} + + +function ViewDocument(const FileName : string; + Viewer : Integer; + Options : TViewerOptions; + var ErrorMsg : string) : Boolean; + {View FileName with Viewer. If successful, return True; if + error, return False and error message in ErrorMsg.} +var + ProgPath : string; + Switches : string; + ShellStatus : Integer; +{$IFDEF DARWIN} + FileInfo : Stat; +{$ENDIF} +begin + Result := False; + ErrorMsg := 'Unexpected error'; + + if not FileExists(FileName) then + begin + ErrorMsg := 'File does not exist.'; + Exit; + end; + + if ovwAddToDeleteList in Options then + DeleteList.Add(FileName); + + if Viewer = 0 then {Use first word processor found?} + begin + ProgPath := ''; + while (Viewer < MaxViewers) and (ProgPath = '') do + begin + Inc(Viewer); + ProgPath := LocateViewer(Viewer); + end; + if ProgPath = '' then + begin + ErrorMsg := 'Unable to locate a word processor.'; + Exit; + end; + end + else {Use specified word processor} + begin + ProgPath := LocateViewer(Viewer); + if ProgPath = '' then + begin + ErrorMsg := ViewerName[Viewer] + ' does not appear to be installed.'; + Exit; + end; + end; + + Switches := ''; + if ovwUseAsTemplate in Options then + begin + Switches := ViewerSwitch[Viewer]; + if Switches = '' then {No "template" switch to pass?} + {Set file read-only so user has to save under different name} +{$IFDEF MSWINDOWS} + FileSetAttr(FileName, faReadOnly); +{$ELSE} {OS X and Linux} + begin + FpStat(FileName, FileInfo); + FpChmod(FileName, FileInfo.st_mode and ($FFFF XOR S_IWUSR)); + end; +{$ENDIF} + end; + + ShellStatus := LaunchViewer('"' + ProgPath + '"', + Switches + '"' + FileName + '"', ''); +{$IFDEF MSWINDOWS} + if ShellStatus <= 32 then {Windows shell error?} +{$ELSE} + if ShellStatus = 127 then {Unix shell error?} +{$ENDIF} + begin + ErrorMsg := 'Shell error ' + IntToStr(ShellStatus) + + ' attempting to start ' + ViewerName[Viewer] + '.'; + Exit; + end; + + ErrorMsg := ''; + Result := True; +end; {ViewDocument} + + +function DeleteViewedDocs : Boolean; + {Attempt to delete documents in deletion list, returning + True if all documents deleted or False if unable to + delete all documents.} +var + DocNum : Integer; +{$IFDEF DARWIN} + FileInfo : Stat; +{$ENDIF} +begin + Result := True; + for DocNum := DeleteList.Count - 1 downto 0 do + begin + if FileExists(DeleteList.Strings[DocNum]) then + begin +{$IFDEF MSWINDOWS} + if (FileGetAttr(DeleteList.Strings[DocNum]) and faReadOnly) <> 0 then + FileSetAttr(DeleteList.Strings[DocNum], + FileGetAttr(DeleteList.Strings[DocNum]) - faReadOnly); +{$ELSE} {OS X and Linux} + FpStat(DeleteList.Strings[DocNum], FileInfo); + if (FileInfo.st_Mode or S_IWUSR) = 0 then {File read-only?} + FpChmod(DeleteList.Strings[DocNum], FileInfo.st_Mode or S_IWUSR); +{$ENDIF} + if SysUtils.DeleteFile(DeleteList.Strings[DocNum]) then + DeleteList.Delete(DocNum) + else + Result := False; {At least one doc not deleted} + end; + end; {for DocNum} +end; {DeleteViewedDocs} + + +initialization + DeleteList := TStringList.Create; + +finalization + DeleteViewedDocs; + DeleteList.Free; + +end. + diff --git a/components/xdev_toolkit/ViewWith.pas b/components/xdev_toolkit/ViewWith.pas new file mode 100644 index 000000000..16589dea8 --- /dev/null +++ b/components/xdev_toolkit/ViewWith.pas @@ -0,0 +1,66 @@ +program ViewWith; + +{ + Test program for ViewDoc unit. +} + +uses + SysUtils, + ViewDoc; + +var + VwrIdx : Integer; + Viewer : Integer; + Options : TViewerOptions; + InStr : string; + ErrorMsg : string; + Done : Boolean; + +begin + + if ParamCount < 2 then + begin + WriteLn('Usage: ViewWith viewername docfilename [-t] [-d]'); + Exit; + end; + + Viewer := 0; + for VwrIdx := 1 to GetViewerCount do + begin + if SameText(ParamStr(1), GetViewerName(VwrIdx)) then + Viewer := VwrIdx; + end; + if Viewer = 0 then + WriteLn('Specified viewer not supported - using first viewer found'); + + Options := []; + if FindCmdLineSwitch('t', ['-'], True) then {Treat file as template?} + Options := Options + [ovwUseAsTemplate]; + + if FindCmdLineSwitch('d', ['-'], True) then {Delete file before exiting?} + begin + Options := Options + [ovwAddToDeleteList]; + Write('File will be deleted when done viewing - is this okay (Y/N)? '); + ReadLn(InStr); + if CompareText(InStr, 'y') <> 0 then + Exit; + end; + + if not ViewDocument(ParamStr(2), Viewer, Options, ErrorMsg) then + begin + WriteLn(ErrorMsg); + Exit; + end; + + if FindCmdLineSwitch('d', ['-'], True) and FileExists(ParamStr(2)) then + begin + repeat + Write('Press Enter when ready to delete file (or Ctrl+C to exit): '); + ReadLn(InStr); + Done := DeleteViewedDocs; + if not Done then + WriteLn(' Unable to delete file - may still be open in viewer'); + until Done; + end; +end. + \ No newline at end of file diff --git a/components/xdev_toolkit/XDevStatus.html b/components/xdev_toolkit/XDevStatus.html new file mode 100644 index 000000000..1644ccf30 --- /dev/null +++ b/components/xdev_toolkit/XDevStatus.html @@ -0,0 +1,286 @@ + + + + +
+ +
+ + + + +
+ +