You've already forked lazarus-ccr
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
This commit is contained in:
wp_xxyyzz
85
components/systools/examples/text/EXTEXT.lpi
Normal file
85
components/systools/examples/text/EXTEXT.lpi
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<PathDelim Value="\"/>
|
||||||
|
<General>
|
||||||
|
<Flags>
|
||||||
|
<UseDefaultCompilerOptions Value="True"/>
|
||||||
|
</Flags>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<MainUnit Value="0"/>
|
||||||
|
<Title Value="EXTEXT"/>
|
||||||
|
<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>
|
||||||
42
components/systools/examples/text/EXTEXT.lpr
Normal file
42
components/systools/examples/text/EXTEXT.lpr
Normal file
@ -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.
|
||||||
127
components/systools/examples/text/ExTextU.lfm
Normal file
127
components/systools/examples/text/ExTextU.lfm
Normal file
@ -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
|
||||||
230
components/systools/examples/text/ExTextU.pas
Normal file
230
components/systools/examples/text/ExTextU.pas
Normal file
@ -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.
|
||||||
@ -16,7 +16,7 @@
|
|||||||
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/>
|
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/>
|
||||||
<License Value="MPL 1.1"/>
|
<License Value="MPL 1.1"/>
|
||||||
<Version Major="4" Release="4"/>
|
<Version Major="4" Release="4"/>
|
||||||
<Files Count="59">
|
<Files Count="60">
|
||||||
<Item1>
|
<Item1>
|
||||||
<Filename Value="source\run\stbarc.pas"/>
|
<Filename Value="source\run\stbarc.pas"/>
|
||||||
<UnitName Value="StBarC"/>
|
<UnitName Value="StBarC"/>
|
||||||
@ -253,6 +253,10 @@
|
|||||||
<Filename Value="source\run\sttxtdat.pas"/>
|
<Filename Value="source\run\sttxtdat.pas"/>
|
||||||
<UnitName Value="StTxtDat"/>
|
<UnitName Value="StTxtDat"/>
|
||||||
</Item59>
|
</Item59>
|
||||||
|
<Item60>
|
||||||
|
<Filename Value="source\run\sttext.pas"/>
|
||||||
|
<UnitName Value="StText"/>
|
||||||
|
</Item60>
|
||||||
</Files>
|
</Files>
|
||||||
<RequiredPkgs Count="2">
|
<RequiredPkgs Count="2">
|
||||||
<Item1>
|
<Item1>
|
||||||
|
|||||||
@ -14,7 +14,8 @@ uses
|
|||||||
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
|
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
|
||||||
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
|
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
|
||||||
StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict,
|
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
|
implementation
|
||||||
|
|
||||||
|
|||||||
181
components/systools/source/run/sttext.pas
Normal file
181
components/systools/source/run/sttext.pas
Normal file
@ -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.
|
||||||
Reference in New Issue
Block a user