pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

systools: Add unit stText and corresponding example project (examples/text)

Browse Source 
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
2018-01-28 21:46:36 +00:00
parent 606cac7767
commit ac0360cf8c
7 changed files with 672 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
components/systools/examples/text/EXTEXT.lpi Normal file
View 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
View 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
View 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
View 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.

6
components/systools/laz_systools.lpk
View File

@ -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>

3
components/systools/laz_systools.pas
View File

@ -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

181
components/systools/source/run/sttext.pas Normal file
View 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.