From ac0360cf8cc128479b99519056c6411d9070e885 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Sun, 28 Jan 2018 21:46:36 +0000 Subject: [PATCH] systools: Add unit stText and corresponding example project (examples/text) git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6150 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- components/systools/examples/text/EXTEXT.lpi | 85 +++++++ components/systools/examples/text/EXTEXT.lpr | 42 ++++ components/systools/examples/text/ExTextU.lfm | 127 ++++++++++ components/systools/examples/text/ExTextU.pas | 230 ++++++++++++++++++ components/systools/laz_systools.lpk | 6 +- components/systools/laz_systools.pas | 3 +- components/systools/source/run/sttext.pas | 181 ++++++++++++++ 7 files changed, 672 insertions(+), 2 deletions(-) create mode 100644 components/systools/examples/text/EXTEXT.lpi create mode 100644 components/systools/examples/text/EXTEXT.lpr create mode 100644 components/systools/examples/text/ExTextU.lfm create mode 100644 components/systools/examples/text/ExTextU.pas create mode 100644 components/systools/source/run/sttext.pas diff --git a/components/systools/examples/text/EXTEXT.lpi b/components/systools/examples/text/EXTEXT.lpi new file mode 100644 index 000000000..65a37d901 --- /dev/null +++ b/components/systools/examples/text/EXTEXT.lpi @@ -0,0 +1,85 @@ + + + + + + + + + + + + + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="laz_systools"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="EXTEXT.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Extext"/> + </Unit0> + <Unit1> + <Filename Value="ExTextU.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="STDlg"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="EXTEXT"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/systools/examples/text/EXTEXT.lpr b/components/systools/examples/text/EXTEXT.lpr new file mode 100644 index 000000000..34a13af7a --- /dev/null +++ b/components/systools/examples/text/EXTEXT.lpr @@ -0,0 +1,42 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower SysTools + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +program Extext; + +uses + Forms, Interfaces, LclVersion, + ExTextU in 'ExTextU.pas' {STDlg}; + +{$R *.res} + +begin + Application.Scaled := True; + {$IF lcl_fullversion >= 1080000} + Application.Scaled := True; + {$ENDIF} + Application.Initialize; + Application.CreateForm(TSTDlg, STDlg); + Application.Run; +end. diff --git a/components/systools/examples/text/ExTextU.lfm b/components/systools/examples/text/ExTextU.lfm new file mode 100644 index 000000000..f50d5ac1c --- /dev/null +++ b/components/systools/examples/text/ExTextU.lfm @@ -0,0 +1,127 @@ +object STDlg: TSTDlg + Left = 254 + Height = 274 + Top = 164 + Width = 428 + ActiveControl = LoadBtn + Caption = 'StText Example' + ClientHeight = 274 + ClientWidth = 428 + Color = clBtnFace + Font.Color = clBlack + OnClose = FormClose + OnCreate = FormCreate + LCLVersion = '1.9.0.0' + object Label1: TLabel + Left = 6 + Height = 15 + Top = 16 + Width = 32 + Caption = 'Name' + ParentColor = False + end + object Label2: TLabel + Left = 208 + Height = 15 + Top = 16 + Width = 23 + Caption = 'Size:' + ParentColor = False + end + object Label3: TLabel + Left = 320 + Height = 15 + Top = 16 + Width = 44 + Caption = 'Cur. Pos' + ParentColor = False + end + object Memo1: TMemo + Left = 90 + Height = 217 + Top = 48 + Width = 329 + HideSelection = False + OnKeyUp = Memo1KeyUp + OnMouseUp = Memo1MouseUp + ReadOnly = True + ScrollBars = ssVertical + TabOrder = 8 + TabStop = False + end + object LoadBtn: TButton + Left = 8 + Height = 33 + Top = 48 + Width = 75 + Caption = 'Load' + Default = True + OnClick = LoadBtnClick + TabOrder = 0 + end + object SeekBtn: TButton + Left = 8 + Height = 33 + Top = 170 + Width = 75 + Caption = 'Seek' + OnClick = SeekBtnClick + TabOrder = 3 + end + object FlushBtn: TButton + Left = 8 + Height = 33 + Top = 232 + Width = 75 + Caption = 'Flush' + OnClick = FlushBtnClick + TabOrder = 4 + end + object Edit1: TEdit + Left = 40 + Height = 23 + Top = 12 + Width = 159 + ReadOnly = True + TabOrder = 5 + end + object Edit2: TEdit + Left = 236 + Height = 23 + Top = 12 + Width = 53 + ReadOnly = True + TabOrder = 6 + end + object Edit3: TEdit + Left = 366 + Height = 23 + Top = 12 + Width = 53 + ReadOnly = True + TabOrder = 7 + end + object Edit4: TEdit + Left = 14 + Height = 23 + Top = 136 + Width = 65 + TabOrder = 2 + end + object CloseFBtn: TButton + Left = 8 + Height = 33 + Top = 90 + Width = 75 + Caption = 'Close File' + OnClick = CloseFBtnClick + TabOrder = 1 + end + object OD1: TOpenDialog + DefaultExt = '.TXT' + Filter = '*.txt (Text files)|*.txt|*.* (All files)|*.*' + Options = [ofOverwritePrompt] + left = 152 + top = 86 + end +end diff --git a/components/systools/examples/text/ExTextU.pas b/components/systools/examples/text/ExTextU.pas new file mode 100644 index 000000000..49cfd63be --- /dev/null +++ b/components/systools/examples/text/ExTextU.pas @@ -0,0 +1,230 @@ +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower SysTools + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +unit ExTextU; + +{$IFDEF FPC} + {$mode DELPHI} +{$ENDIF} + +interface + +uses + {$IFNDEF FPC} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Graphics, Controls, + Forms, Dialogs, StdCtrls; + +type + TSTDlg = class(TForm) + Memo1: TMemo; + OD1: TOpenDialog; + LoadBtn: TButton; + SeekBtn: TButton; + FlushBtn: TButton; + Label1: TLabel; + Edit1: TEdit; + Label2: TLabel; + Edit2: TEdit; + Label3: TLabel; + Edit3: TEdit; + Edit4: TEdit; + CloseFBtn: TButton; + procedure LoadBtnClick(Sender: TObject); + procedure SeekBtnClick(Sender: TObject); + procedure Memo1KeyUp(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure Memo1MouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure FlushBtnClick(Sender: TObject); + procedure CloseFBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + { Private declarations } + public + { Public declarations } + procedure UpdatePos; + procedure UpdateButtons(FOK : Boolean); + end; + +var + STDlg: TSTDlg; + +implementation + +{$R *.lfm} + +uses + StConst, + StBase, + StText; + + +var + F : TextFile; + AFO : Boolean; + + +procedure TSTDlg.UpdateButtons(FOK : Boolean); +begin + CloseFBtn.Enabled := FOK; + SeekBtn.Enabled := FOK; + FlushBtn.Enabled := FOK; +end; + +procedure TSTDlg.FormCreate(Sender: TObject); +begin + UpdateButtons(False); + AFO := False; +end; + +procedure TSTDlg.LoadBtnClick(Sender: TObject); +var + S : string; +// hC : HCursor; +begin + if (OD1.Execute) then + begin + if (AFO) then + CloseFile(F); + AFO := False; + + AssignFile(F, OD1.FileName); + Reset(F); + + Memo1.Enabled := True; + Memo1.Lines.BeginUpdate; + Screen.Cursor := crHourglass; + try +// Memo1.Perform(WM_SETREDRAW,0,0); +// hC := SetCursor(LoadCursor(0,IDC_WAIT)); + + while NOT EOF(F) do + begin + Readln(F,S); + Memo1.Lines.Add(S); + end; + + finally + Screen.Cursor := crDefault; + Memo1.Lines.EndUpdate; + end; +// Memo1.Perform(WM_SETREDRAW,1,0); +// Memo1.Update; + Memo1.SelStart := 0; + Memo1.SelLength := 0; + + Reset(F); + + Edit1.Text := OD1.FileName; + Edit2.Text := IntToStr(TextFileSize(F)); + Edit3.Text := IntToStr(TextPos(F)); + +// SetCursor(hC); + Memo1.SetFocus; + AFO := True; + end; + UpdateButtons(AFO); +end; + +procedure TSTDlg.CloseFBtnClick(Sender: TObject); +begin + CloseFile(F); + Memo1.Clear; + AFO := False; + UpdateButtons(False); +end; + + +procedure TSTDlg.SeekBtnClick(Sender: TObject); +var + NP : LongInt; +begin + NP := StrToInt(Edit4.Text); + Memo1.SetFocus; + if (NP < 0) OR (NP >= TextFileSize(F)) then + begin + ShowMessage('Value out of range'); + Exit; + end; + + if TextSeek(F,NP) then + begin + NP := TextPos(F); + Memo1.SelStart := NP; + Memo1.SelLength := 0; + Edit3.Text := IntToStr(NP); + end else + begin + ShowMessage('Unable to seek to position'); + Memo1.SetFocus; + end; +end; + +procedure TSTDlg.Memo1KeyUp(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + UpdatePos; +end; + +procedure TSTDlg.Memo1MouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + UpdatePos; +end; + + +procedure TSTDlg.UpdatePos; +var + CP : LongInt; +begin + CP := Memo1.SelStart; + + if NOT TextSeek(F,CP) then + begin + ShowMessage('Unable to update file pointer'); + Exit; + end; + + Edit3.Text := IntToStr(TextPos(F)); +end; + +procedure TSTDlg.FlushBtnClick(Sender: TObject); +begin + if NOT (TextFlush(F)) then + begin + ShowMessage('Unable to flush file'); + end; + Memo1.SetFocus; +end; + +procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction); +begin + if AFO then CloseFile(F); +end; + +end. diff --git a/components/systools/laz_systools.lpk b/components/systools/laz_systools.lpk index de9982599..fed87e6a9 100644 --- a/components/systools/laz_systools.lpk +++ b/components/systools/laz_systools.lpk @@ -16,7 +16,7 @@ <Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/> <License Value="MPL 1.1"/> <Version Major="4" Release="4"/> - <Files Count="59"> + <Files Count="60"> <Item1> <Filename Value="source\run\stbarc.pas"/> <UnitName Value="StBarC"/> @@ -253,6 +253,10 @@ <Filename Value="source\run\sttxtdat.pas"/> <UnitName Value="StTxtDat"/> </Item59> + <Item60> + <Filename Value="source\run\sttext.pas"/> + <UnitName Value="StText"/> + </Item60> </Files> <RequiredPkgs Count="2"> <Item1> diff --git a/components/systools/laz_systools.pas b/components/systools/laz_systools.pas index 5039f861f..c9ae9afea 100644 --- a/components/systools/laz_systools.pas +++ b/components/systools/laz_systools.pas @@ -14,7 +14,8 @@ uses StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup, StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue, StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict, - StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol, StPtrns, StMerge, StTxtDat; + StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol, StPtrns, StMerge, StTxtDat, + StText; implementation diff --git a/components/systools/source/run/sttext.pas b/components/systools/source/run/sttext.pas new file mode 100644 index 000000000..d0c355cc3 --- /dev/null +++ b/components/systools/source/run/sttext.pas @@ -0,0 +1,181 @@ +// Upgraded to Delphi 2009: Sebastian Zierer + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The contents of this file are subject to the Mozilla Public License Version + * 1.1 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is TurboPower SysTools + * + * The Initial Developer of the Original Code is + * TurboPower Software + * + * Portions created by the Initial Developer are Copyright (C) 1996-2002 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): + * + * ***** END LICENSE BLOCK ***** *) + +{ adapts changes by Tom Lisjac + Tom Lisjac <vlx@users.sourceforge.net> http://theseus.sf.net } + +{*********************************************************} +{* SysTools: StText.pas 4.04 *} +{*********************************************************} +{* SysTools: Routines for manipulating Delphi Text files *} +{*********************************************************} + +{$I StDefine.inc} + +unit StText; + +interface + +uses +// Windows, + SysUtils, STConst, StBase; //, StSystem; + +function TextSeek(var F : TextFile; Target : LongInt) : Boolean; + {-Seek to the specified position in a text file opened for input} + +function TextFileSize(var F : TextFile) : LongInt; + {-Return the size of a text file} + +function TextPos(var F : TextFile) : LongInt; + {-Return the current position of the logical file pointer (that is, + the position of the physical file pointer, adjusted to account for + buffering)} + +function TextFlush(var F : TextFile) : Boolean; + {-Flush the buffer(s) for a text file} + + +implementation + +const + FILE_BEGIN = 0; + FILE_CURRENT = 1; + FILE_END = 2; + +function TextSeek(var F : TextFile; Target : LongInt) : Boolean; + {-Do a Seek for a text file opened for input. Returns False in case of I/O + error.} +var + Pos : LongInt; +begin + with TTextRec(F) do begin + {assume failure} + Result := False; + {check for file opened for input} + if Mode <> fmInput then Exit; + Pos := FileSeek(Handle, 0, FILE_CURRENT); + if Pos = -1 then Exit; + Dec(Pos, BufEnd); + {see if the Target is within the buffer} + Pos := Target-Pos; + if (Pos >= 0) and (Pos < LongInt(BufEnd)) then + {it is--just move the buffer pointer} + BufPos := Pos + else begin + if FileSeek(Handle, Target, FILE_BEGIN) = -1 then Exit; + {tell Delphi its buffer is empty} + BufEnd := 0; + BufPos := 0; + end; + end; + {if we get to here we succeeded} + Result := True; +end; + +function TextFileSize(var F : TextFile) : LongInt; + {-Return the size of text file F. Returns -1 in case of I/O error.} +var + Old : LongInt; + Res : LongInt; +begin + Result := -1; + with TTextRec(F) do begin + {check for open file} + if Mode = fmClosed then Exit; + {get/save current pos of the file pointer} + Old := FileSeek(Handle, 0, FILE_CURRENT); + if Old = -1 then Exit; + {have OS move to end-of-file} + Res := FileSeek(Handle, 0, FILE_END); + if Res = -1 then Exit; + {reset the old position of the file pointer} + if FileSeek(Handle, Old, FILE_BEGIN) = - 1 then Exit; + end; + Result := Res; +end; + +function TextPos(var F : TextFile) : LongInt; + {-Return the current position of the logical file pointer (that is, + the position of the physical file pointer, adjusted to account for + buffering). Returns -1 in case of I/O error.} +var + Position : LongInt; +begin + Result := -1; + with TTextRec(F) do begin + {check for open file} + if Mode = fmClosed then Exit; + Position := FileSeek(Handle, 0, FILE_CURRENT); + if Position = -1 then Exit; + end; + with TTextRec(F) do + if Mode = fmOutput then {writing} + Inc(Position, BufPos) + else if BufEnd <> 0 then {reading} + Dec(Position, BufEnd-BufPos); + {return the calculated position} + Result := Position; +end; + +function TextFlush(var F : TextFile) : Boolean; + {-Flush the buffer(s) for a text file. Returns False in case of I/O error.} +var + Position : LongInt; + Code : Integer; +begin + Result := False; + with TTextRec(F) do begin + {check for open file} + if Mode = fmClosed then Exit; + {see if file is opened for reading or writing} + if Mode = fmInput then begin + {get current position of the logical file pointer} + Position := TextPos(F); + {exit in case of I/O error} + if Position = -1 then Exit; + if FileSeek(Handle, Position, FILE_BEGIN) = - 1 then Exit; + end + else begin + {write the current contents of the buffer, if any} + if BufPos <> 0 then begin + Code := FileWrite(Handle, BufPtr^, BufPos); + if Code = -1 {<> 0} then Exit; + end; + {flush OS's buffers} + //if not FlushOsBuffers(Handle) then Exit; + System.Flush(F); + end; + {tell Delphi its buffer is empty} + BufEnd := 0; + BufPos := 0; + end; + {if we get to here we succeeded} + Result := True; +end; + + +end.