You've already forked lazarus-ccr
systools: Initial commit of Lazarus port of TurboPower SysTools (incomplete).
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6140 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
1520
components/systools/source/run/StBase.pas
Normal file
1520
components/systools/source/run/StBase.pas
Normal file
File diff suppressed because it is too large
Load Diff
5254
components/systools/source/run/st2dbarc.pas
Normal file
5254
components/systools/source/run/st2dbarc.pas
Normal file
File diff suppressed because it is too large
Load Diff
2471
components/systools/source/run/stbarc.pas
Normal file
2471
components/systools/source/run/stbarc.pas
Normal file
File diff suppressed because it is too large
Load Diff
649
components/systools/source/run/stbarpn.pas
Normal file
649
components/systools/source/run/stbarpn.pas
Normal file
@@ -0,0 +1,649 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StBarPN.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: PostNet Bar Code component *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
unit StBarPN;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
Classes, ClipBrd, Controls, Graphics, SysUtils,
|
||||
StBase, StConst, StStrL;
|
||||
|
||||
type
|
||||
TStPNBarCodeDims = packed record
|
||||
PixPerBar : Longint;
|
||||
PixPerSpace : Longint;
|
||||
ShortBarHeight : Longint;
|
||||
TallBarHeight : Longint;
|
||||
Width : Longint;
|
||||
Height : Longint;
|
||||
end;
|
||||
|
||||
TStPNBarCodeRes = packed record
|
||||
XRes : Longint;
|
||||
YRes : Longint;
|
||||
end;
|
||||
|
||||
TStPNBarCode = class(TGraphicControl)
|
||||
protected {private}
|
||||
{property variables}
|
||||
FPostalCode : string;
|
||||
FCheckNumber : Integer;
|
||||
|
||||
|
||||
{internal variables}
|
||||
pnbcDisplayDims : TStPNBarCodeDims;
|
||||
pnbcDefRes : TStPNBarCodeRes;
|
||||
|
||||
{property methods}
|
||||
function GetVersion : string;
|
||||
procedure SetPostalCode(Value : String);
|
||||
procedure SetVersion (const v : string);
|
||||
|
||||
{internal methods}
|
||||
function DrawTallBar(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
XPos : Integer;
|
||||
AddSpace : Boolean) : Longint;
|
||||
function DrawShortBar(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
XPos : Integer;
|
||||
AddSpace : Boolean) : Longint;
|
||||
function DrawNumber(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
Value : Integer;
|
||||
XPos : Longint;
|
||||
FrontGuard : Boolean;
|
||||
EndGuard : Boolean) : Longint;
|
||||
procedure DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
|
||||
procedure SetCheckNumber;
|
||||
|
||||
(*
|
||||
procedure CMTextChanged(var Msg : TMessage);
|
||||
message CM_TEXTCHANGED;
|
||||
*)
|
||||
|
||||
protected
|
||||
procedure Loaded; override;
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner : TComponent); override;
|
||||
|
||||
procedure ComputeSizes(C : TCanvas;
|
||||
Res : TStPNBarCodeRes;
|
||||
var Dims : TStPNBarCodeDims);
|
||||
procedure CopyToClipboard;
|
||||
procedure PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
|
||||
procedure PaintToDC(DC : hDC; Position : TPoint);
|
||||
procedure PaintToPrinterCanvas(ACanvas : TCanvas; Position : TPoint);
|
||||
procedure PaintToPrinterDC(DC : hDC; Position : TPoint);
|
||||
procedure SaveToFile(ACanvas : TCanvas; const FileName : string);
|
||||
procedure SaveToFileRes(Res : TStPNBarCodeRes; const FileName : string);
|
||||
|
||||
published
|
||||
{properties}
|
||||
property Cursor;
|
||||
property Enabled;
|
||||
property Hint;
|
||||
property ParentShowHint;
|
||||
property ShowHint;
|
||||
property Visible;
|
||||
|
||||
property PostalCode : string read FPostalCode write SetPostalCode;
|
||||
|
||||
property Version : string read GetVersion write SetVersion stored False;
|
||||
|
||||
{events}
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
uses
|
||||
Dialogs;
|
||||
{$ENDIF}
|
||||
|
||||
{*** TStPNBarCode ***}
|
||||
|
||||
function TStPNBarCode.GetVersion : string;
|
||||
begin
|
||||
Result := StVersionStr;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.SetVersion(const v : string);
|
||||
begin
|
||||
end;
|
||||
|
||||
constructor TStPNBarCode.Create(AOwner : TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
{defaults}
|
||||
pnbcDefRes.XRes := 0;
|
||||
pnbcDefRes.YRes := 0;
|
||||
{set arbitrary values for height/width so that component automatically resizes}
|
||||
Height := 10;
|
||||
Width := 10;
|
||||
PostalCode := '12345';
|
||||
SetCheckNumber;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.Paint;
|
||||
begin
|
||||
ComputeSizes(Canvas, pnbcDefRes, pnbcDisplayDims);
|
||||
Height := pnbcDisplayDims.Height;
|
||||
Width := pnbcDisplayDims.Width;
|
||||
DrawBarCode(Canvas, pnbcDisplayDims);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.SetCheckNumber;
|
||||
var
|
||||
I : Longint;
|
||||
begin
|
||||
if (Length(TrimL(FPostalCode)) < 5) then Exit;
|
||||
FCheckNumber := 0;
|
||||
for I := 1 to Length(FPostalCode) do
|
||||
FCheckNumber := FCheckNumber + StrToInt(FPostalCode[I]);
|
||||
I := FCheckNumber mod 10;
|
||||
if (I > 0) then
|
||||
FCheckNumber := 10 - I
|
||||
else
|
||||
FCheckNumber := 0;
|
||||
end;
|
||||
|
||||
procedure TStPNBarCode.SetPostalCode(Value : string);
|
||||
var
|
||||
I : Integer;
|
||||
Local : string;
|
||||
begin
|
||||
if (csLoading in ComponentState) then Exit;
|
||||
|
||||
Local := TrimL(Value);
|
||||
|
||||
{strip non-numerics}
|
||||
I := 1;
|
||||
repeat
|
||||
if not (Local[I] in ['0'..'9']) then
|
||||
System.Delete(Local, I, 1)
|
||||
else
|
||||
Inc(I);
|
||||
until (I > Length(Local));
|
||||
|
||||
{ looks like a valid Postal Code?}
|
||||
if (Local <> FPostalCode) then begin
|
||||
if (Length(Local) in [5, 9, 11]) then begin
|
||||
FPostalCode := Local;
|
||||
SetCheckNumber;
|
||||
Invalidate;
|
||||
end else
|
||||
RaiseStError(EStPNBarCodeError, stscInvalidLength);
|
||||
end; { else it's the same code, don't bother updating }
|
||||
end;
|
||||
|
||||
|
||||
function TStPNBarCode.DrawTallBar(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
XPos : Integer;
|
||||
AddSpace : Boolean) : Longint;
|
||||
var
|
||||
YPos : Longint;
|
||||
begin
|
||||
Result := XPos;
|
||||
YPos := Dims.Height - 5 - Dims.TallBarHeight;
|
||||
C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.TallBarHeight);
|
||||
Result := Result + Dims.PixPerBar;
|
||||
|
||||
if (AddSpace) then
|
||||
Inc(Result, Dims.PixPerSpace);
|
||||
end;
|
||||
|
||||
|
||||
function TStPNBarCode.DrawShortBar(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
XPos : Integer;
|
||||
AddSpace : Boolean) : Longint;
|
||||
var
|
||||
YPos : Longint;
|
||||
begin
|
||||
Result := XPos;
|
||||
YPos := Dims.Height - 5 - Dims.ShortBarHeight;
|
||||
C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.ShortBarHeight);
|
||||
Result := Result + Dims.PixPerBar;
|
||||
|
||||
if (AddSpace) then
|
||||
Inc(Result, Dims.PixPerSpace);
|
||||
end;
|
||||
|
||||
|
||||
function TStPNBarCode.DrawNumber(C : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
Value : Integer;
|
||||
XPos : Longint;
|
||||
FrontGuard : Boolean;
|
||||
EndGuard : Boolean) : Longint;
|
||||
begin
|
||||
Result := XPos;
|
||||
if (FrontGuard) then
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
|
||||
case Value of
|
||||
0 : begin
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
1 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
2 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
3 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
4 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
5 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
6 : begin
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
7 : begin
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
8 : begin
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
|
||||
9 : begin
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawTallBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
Result := DrawShortBar(C, Dims, Result, True);
|
||||
end;
|
||||
end;
|
||||
|
||||
if (EndGuard) then
|
||||
Result := DrawTallBar(C, Dims, Result, False);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.ComputeSizes(C : TCanvas;
|
||||
Res : TStPNBarCodeRes;
|
||||
var Dims : TStPNBarCodeDims);
|
||||
var
|
||||
PPIX,
|
||||
PPIY : Longint;
|
||||
begin
|
||||
if csLoading in ComponentState then
|
||||
Exit;
|
||||
{get resolution}
|
||||
if ((Res.XRes > 0) and (Res.YRes > 0)) then begin
|
||||
PPIX := Res.XRes;
|
||||
PPIY := Res.YRes;
|
||||
end else begin
|
||||
PPIX := GetDeviceCaps(C.Handle, LOGPIXELSX);
|
||||
PPIY := GetDeviceCaps(C.Handle, LOGPIXELSY);
|
||||
end;
|
||||
|
||||
{PN bar is 0.015" to 0.025" - use mid value}
|
||||
{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
|
||||
Dims.PixPerBar := Round(PPIX * 0.017) + 1;
|
||||
|
||||
{CenterLine distance is 0.0416" to 0.0500". Space is that minus width of bar}
|
||||
{In all cases the Pitch must be 22 +/-2 bars/Inch where a bar is the bar and}
|
||||
{the trailing space}
|
||||
|
||||
{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
|
||||
Dims.PixPerSpace := Round(0.0475 * PPIX) - Dims.PixPerBar + 1;
|
||||
|
||||
{max height of short bar is 0.050" +/-0.010". To allow for 75dpi, go a}
|
||||
{little less}
|
||||
{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
|
||||
Dims.ShortBarHeight := Round(0.047 * PPIY) + 1;
|
||||
|
||||
{max height of tall bar is 0.125" +/-0.010". To allow for 75dpi, go a}
|
||||
{little less}
|
||||
{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
|
||||
Dims.TallBarHeight := Round(0.122 * PPIY) + 1;
|
||||
|
||||
|
||||
{Total Width of Canvas =
|
||||
FrontGuardBar + Space +
|
||||
(NumberChars + CheckChar) * (5 * (PixelsPerBar + PixelsPerSpace)) +
|
||||
(EndBar w/o Space) +
|
||||
5 pixels left/right margin
|
||||
}
|
||||
Dims.Width :=
|
||||
(Dims.PixPerBar + Dims.PixPerSpace) +
|
||||
(Length(PostalCode) + 1) * (5 * (Dims.PixPerBar + Dims.PixPerSpace)) +
|
||||
Dims.PixPerBar + 10;
|
||||
|
||||
{Height = Height of tall bar + 3 pixel top/bottom margin}
|
||||
Dims.Height := Dims.TallBarHeight + 3;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStPNBarCode.DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
|
||||
var
|
||||
I,
|
||||
XPos : Longint;
|
||||
begin
|
||||
if csLoading in ComponentState then
|
||||
Exit;
|
||||
|
||||
C.Brush.Color := clBlack;
|
||||
C.Brush.Style := bsSolid;
|
||||
|
||||
{Draw the Code}
|
||||
XPos := 5;
|
||||
XPos := DrawNumber(C, Dims, StrToInt(PostalCode[1]), XPos, True, False);
|
||||
for I := 2 to Length(PostalCode) do
|
||||
XPos := DrawNumber(C, Dims, StrToInt(PostalCode[I]), XPos, False, False);
|
||||
DrawNumber(C, Dims, FCheckNumber, XPos, False, True);
|
||||
end;
|
||||
|
||||
|
||||
(*
|
||||
procedure TStPNBarCode.CMTextChanged(var Msg : TMessage);
|
||||
begin
|
||||
SetCheckNumber;
|
||||
Invalidate;
|
||||
end;
|
||||
*)
|
||||
|
||||
procedure TStPNBarCode.CopyToClipboard;
|
||||
var
|
||||
{$IFNDEF FPC}
|
||||
MetaFile : TMetaFile;
|
||||
MetaFileCanvas : TMetaFileCanvas;
|
||||
{$ENDIF}
|
||||
Bitmap : TBitmap;
|
||||
Dims : TStPNBarCodeDims;
|
||||
begin
|
||||
Clipboard.Clear;
|
||||
Clipboard.Open;
|
||||
try
|
||||
{bitmap}
|
||||
Bitmap := TBitmap.Create;
|
||||
try
|
||||
ComputeSizes(Bitmap.Canvas, pnbcDefRes, Dims);
|
||||
Bitmap.Width := Dims.Width;
|
||||
Bitmap.Height := Dims.Height;
|
||||
DrawBarCode(Bitmap.Canvas, Dims);
|
||||
Clipboard.Assign(Bitmap);
|
||||
|
||||
{$IFNDEF FPC}
|
||||
{metafile}
|
||||
MetaFile := TMetaFile.Create;
|
||||
try
|
||||
MetaFileCanvas := TMetaFileCanvas.Create(MetaFile, 0);
|
||||
try
|
||||
MetaFile.Enhanced := True;
|
||||
MetaFile.Width := ClientWidth;
|
||||
MetaFile.Height := ClientHeight;
|
||||
MetaFileCanvas.Draw(0, 0, Bitmap);
|
||||
finally
|
||||
MetaFileCanvas.Free;
|
||||
end;
|
||||
Clipboard.Assign(MetaFile);
|
||||
finally
|
||||
MetaFile.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
finally
|
||||
Bitmap.Free;
|
||||
end
|
||||
finally
|
||||
Clipboard.Close;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.PaintToDC(DC : hDC; Position : TPoint);
|
||||
var
|
||||
Bmp : TBitmap;
|
||||
ACanvas : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
R1,
|
||||
R2 : TRect;
|
||||
begin
|
||||
ACanvas := TCanvas.Create;
|
||||
ACanvas.Handle := DC;
|
||||
Bmp := TBitmap.Create;
|
||||
try
|
||||
ComputeSizes(ACanvas, pnbcDefRes, Dims);
|
||||
Bmp.Height := Dims.Height;
|
||||
Bmp.Width := Dims.Width;
|
||||
R1 := Rect(0, 0, Dims.Width, Dims.Height);
|
||||
R2 := Rect(Position.X, Position.Y,
|
||||
Dims.Width + Position.X,
|
||||
Dims.Height + Position.Y);
|
||||
|
||||
DrawBarCode(Bmp.Canvas, Dims);
|
||||
ACanvas.CopyRect(R2, Bmp.Canvas, R1);
|
||||
finally
|
||||
Bmp.Free;
|
||||
ACanvas.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
|
||||
begin
|
||||
PaintToDC(ACanvas.Handle, Position);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.PaintToPrinterCanvas(ACanvas : TCanvas;
|
||||
Position : TPoint);
|
||||
begin
|
||||
PaintToPrinterDC(ACanvas.Handle, Position);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.PaintToPrinterDC(DC : hDC; Position : TPoint);
|
||||
var
|
||||
Bmp : TBitmap;
|
||||
ACanvas : TCanvas;
|
||||
Dims : TStPNBarCodeDims;
|
||||
R1,
|
||||
R2 : TRect;
|
||||
|
||||
Info : PBitMapInfo;
|
||||
InfoSize : DWORD;
|
||||
ImageSize : DWORD;
|
||||
Image : Pointer;
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
// FIX ME
|
||||
ShowMessage('This function is not yet implemented.');
|
||||
{$ELSE}
|
||||
ACanvas := TCanvas.Create;
|
||||
Bmp := TBitmap.Create;
|
||||
ACanvas.Handle := DC;
|
||||
try
|
||||
ComputeSizes(ACanvas, pnbcDefRes, Dims);
|
||||
Bmp.Height := Dims.Height;
|
||||
Bmp.Width := Dims.Width;
|
||||
R1 := Rect(0, 0, Dims.Width, Dims.Height);
|
||||
R2 := Rect(Position.X, Position.Y,
|
||||
Dims.Width + Position.X,
|
||||
Dims.Height + Position.Y);
|
||||
|
||||
DrawBarCode(Bmp.Canvas, Dims);
|
||||
|
||||
{Delphi does not allow a simple Canvas.CopyRect to the printer Canvas}
|
||||
with Bmp do begin
|
||||
GetDIBSizes(Handle, InfoSize, ImageSize);
|
||||
GetMem(Info, InfoSize);
|
||||
try
|
||||
GetMem(Image, ImageSize);
|
||||
try
|
||||
GetDIB(Handle, Palette, Info^, Image^);
|
||||
with Info^.bmiHeader do begin
|
||||
StretchDIBits(ACanvas.Handle,
|
||||
R2.Left, R2.Top, Dims.Width, Dims.Height,
|
||||
0, 0, biWidth, biHeight,
|
||||
Image, Info^, DIB_RGB_COLORS, SRCCOPY);
|
||||
end;
|
||||
finally
|
||||
FreeMem(Image, ImageSize)
|
||||
end;
|
||||
finally
|
||||
FreeMem(Info, InfoSize);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Bmp.Free;
|
||||
ACanvas.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.SaveToFile(ACanvas : TCanvas;
|
||||
const FileName : string);
|
||||
var
|
||||
Bmp : TBitmap;
|
||||
Dims : TStPNBarCodeDims;
|
||||
begin
|
||||
Bmp := TBitmap.Create;
|
||||
try
|
||||
ComputeSizes(ACanvas, pnbcDefRes, Dims);
|
||||
Bmp.Height := Dims.Height;
|
||||
Bmp.Width := Dims.Width;
|
||||
DrawBarCode(Bmp.Canvas, Dims);
|
||||
Bmp.SaveToFile(FileName);
|
||||
finally
|
||||
Bmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStPNBarCode.SaveToFileRes(Res : TStPNBarCodeRes;
|
||||
const FileName : string);
|
||||
var
|
||||
Bmp : TBitmap;
|
||||
Dims : TStPNBarCodeDims;
|
||||
begin
|
||||
Bmp := TBitmap.Create;
|
||||
try
|
||||
ComputeSizes(Bmp.Canvas, Res, Dims);
|
||||
Bmp.Height := Dims.Height;
|
||||
Bmp.Width := Dims.Width;
|
||||
DrawBarCode(Bmp.Canvas, Dims);
|
||||
Bmp.SaveToFile(FileName);
|
||||
finally
|
||||
Bmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
315
components/systools/source/run/stccy.dat
Normal file
315
components/systools/source/run/stccy.dat
Normal file
@@ -0,0 +1,315 @@
|
||||
; World Currency Information
|
||||
; ISO 4217-style currency information
|
||||
; Format:
|
||||
;[ISOCode]
|
||||
;ISOName=<ISO 4217 3 Letter Currency ID>
|
||||
;ISOCode=<ISO 4217 3 Digit Currency Number>
|
||||
;UnitMajor=<Major Currency Name>
|
||||
;UnitMinor=<Minor Currency Name>
|
||||
;Ratio=<ratio of minor currency to major>
|
||||
;Name=<Country-Currency Name>
|
||||
|
||||
[AUD]
|
||||
ISOName=AUD
|
||||
ISOCode=036
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=Australian Dollar
|
||||
|
||||
[ATS]
|
||||
ISOName=ATS
|
||||
ISOCode=040
|
||||
UnitMajor=schilling
|
||||
UnitMinor=groschen
|
||||
Ratio=100
|
||||
Name=Austrian Schilling
|
||||
|
||||
[BEF]
|
||||
ISOName=BEF
|
||||
ISOCode=056
|
||||
UnitMajor=franc
|
||||
Ratio=100
|
||||
UnitMinor=
|
||||
Name=Belgium Franc
|
||||
|
||||
[BRL]
|
||||
ISOName=BRL
|
||||
ISOCode=986
|
||||
UnitMajor=real
|
||||
UnitMinor=centavo
|
||||
Ratio=100
|
||||
Name=Brazilian Real
|
||||
|
||||
[CAD]
|
||||
ISOName=CAD
|
||||
ISOCode=124
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=Canadian Dollar
|
||||
|
||||
[CNY]
|
||||
ISOName=CNY
|
||||
ISOCode=156
|
||||
UnitMajor=yuan renminbi
|
||||
UnitMinor=jiao
|
||||
Ratio=100
|
||||
Name=Chinese Renminbi Yuan
|
||||
|
||||
[DKK]
|
||||
ISOName=DKK
|
||||
ISOCode=208
|
||||
UnitMajor=krone
|
||||
UnitMinor=�re
|
||||
Ratio=100
|
||||
Name=Danish Krone
|
||||
|
||||
[DEM]
|
||||
ISOName=DEM
|
||||
ISOCode=276
|
||||
UnitMajor=deutsche mark
|
||||
UnitMinor=pfennig
|
||||
Ratio=100
|
||||
Name=Deutsche Mark
|
||||
|
||||
[NLG]
|
||||
ISOName=NLG
|
||||
ISOCode=528
|
||||
UnitMajor=gulden
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=Dutch Guilder
|
||||
|
||||
[EGP]
|
||||
ISOName=EGP
|
||||
ISOCode=818
|
||||
UnitMajor=pound
|
||||
UnitMinor=piaster
|
||||
Ratio=100
|
||||
Name=Egytian Pound
|
||||
|
||||
[EUR]
|
||||
ISOName=EUR
|
||||
ISOCode=978
|
||||
UnitMajor=Euro
|
||||
UnitMinor=euro-cent
|
||||
Ratio=100
|
||||
Name=Euro
|
||||
|
||||
[FRF]
|
||||
ISOName=FRF
|
||||
ISOCode=250
|
||||
UnitMajor=franc
|
||||
UnitMinor=centime
|
||||
Ratio=100
|
||||
Name=French Franc
|
||||
|
||||
[GRD]
|
||||
ISOName=GRD
|
||||
ISOCode=300
|
||||
UnitMajor=drachma
|
||||
UnitMinor=lepta
|
||||
Ratio=100
|
||||
Name=Greek Drachma
|
||||
|
||||
[HKD]
|
||||
ISOName=HKD
|
||||
ISOCode=344
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=Hong Kong Dollar
|
||||
|
||||
[ISK]
|
||||
ISOName=ISK
|
||||
ISOCode=352
|
||||
UnitMajor=kr�na
|
||||
UnitMinor=aurar
|
||||
Ratio=100
|
||||
Name=Icelandic Kr�na
|
||||
|
||||
[INR]
|
||||
ISOName=INR
|
||||
ISOCode=356
|
||||
UnitMajor=rupee
|
||||
UnitMinor=paise
|
||||
Ratio=100
|
||||
Name=Indian Rupee
|
||||
|
||||
[ILS]
|
||||
ISOName=ILS
|
||||
ISOCode=376
|
||||
UnitMajor=new shekel
|
||||
UnitMinor=agorot
|
||||
Ratio=100
|
||||
Name=Israel Shekel
|
||||
|
||||
[ITL]
|
||||
ISOName=ITL
|
||||
ISOCode=380
|
||||
UnitMajor=lira
|
||||
UnitMinor=ml
|
||||
Ratio=100
|
||||
Name=Italian Lira
|
||||
|
||||
[JPY]
|
||||
ISOName=JPY
|
||||
ISOCode=392
|
||||
UnitMajor=yen
|
||||
UnitMinor=sen
|
||||
Ratio=100
|
||||
Name=Japanese Yen
|
||||
|
||||
[MXN]
|
||||
ISOName=MXN
|
||||
ISOCode=484
|
||||
UnitMajor=peso
|
||||
UnitMinor=centavo
|
||||
Ratio=100
|
||||
Name=Mexican Peso
|
||||
|
||||
[NZD]
|
||||
ISOName=NZD
|
||||
ISOCode=554
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=New Zealand Dollar
|
||||
|
||||
[NOK]
|
||||
ISOName=NOK
|
||||
ISOCode=578
|
||||
UnitMajor=krone
|
||||
UnitMinor=�re
|
||||
Ratio=100
|
||||
Name=Norwegian Krone
|
||||
|
||||
[PLZ]
|
||||
ISOName=PLZ
|
||||
ISOCode=616
|
||||
UnitMajor=zloty
|
||||
UnitMinor=groszy
|
||||
Ratio=100
|
||||
Name=Poland New Zloty
|
||||
|
||||
[PTE]
|
||||
ISOName=PTE
|
||||
ISOCode=620
|
||||
UnitMajor=escudo
|
||||
UnitMinor=centavo
|
||||
Ratio=100
|
||||
Name=Portuguese Escudo
|
||||
|
||||
[RUR]
|
||||
ISOName=RUR
|
||||
ISOCode=810
|
||||
UnitMajor=ruble
|
||||
UnitMinor=kopeck
|
||||
Ratio=100
|
||||
Name=Russian Federation Rouble
|
||||
|
||||
[SGD]
|
||||
ISOName=SGD
|
||||
ISOCode=702
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=Singapore Dollar
|
||||
|
||||
[ESP]
|
||||
ISOName=ESP
|
||||
ISOCode=724
|
||||
UnitMajor=peseta
|
||||
UnitMinor=centimo
|
||||
Ratio=100
|
||||
Name=Spanish Peseta
|
||||
|
||||
[GBP]
|
||||
ISOName=GBP
|
||||
ISOCode=826
|
||||
UnitMajor=pound
|
||||
UnitMinor=pence
|
||||
Ratio=100
|
||||
Name=Sterling
|
||||
|
||||
[SEK]
|
||||
ISOName=SEK
|
||||
ISOCode=752
|
||||
UnitMajor=krona (pl. kronor)
|
||||
UnitMinor=�re
|
||||
Ratio=100
|
||||
Name=Swedish Krona
|
||||
|
||||
[CHF]
|
||||
ISOName=CHF
|
||||
ISOCode=756
|
||||
UnitMajor=franc
|
||||
UnitMinor=rappen
|
||||
Ratio=100
|
||||
Name=Swiss Franc
|
||||
|
||||
[USD]
|
||||
ISOName=USD
|
||||
ISOCode=840
|
||||
UnitMajor=dollar
|
||||
UnitMinor=cent
|
||||
Ratio=100
|
||||
Name=US DOLLAR
|
||||
|
||||
[DTR]
|
||||
ISOName=DTR
|
||||
ISOCode=005
|
||||
UnitMajor=rex
|
||||
UnitMinor=campi
|
||||
Ratio=100
|
||||
Name=Dinotopia Rex
|
||||
|
||||
[ZQP]
|
||||
ISOName=ZQP
|
||||
ISOCode=002
|
||||
UnitMajor=pazoor
|
||||
UnitMinor=dharma
|
||||
Ratio=100
|
||||
Name=Zothique Pazoor
|
||||
|
||||
[LAM]
|
||||
ISOName=LAM
|
||||
ISOCode=001
|
||||
UnitMajor=minim
|
||||
UnitMinor=speck
|
||||
Ratio=100
|
||||
Name=Lilliputia Minim
|
||||
|
||||
[BNG]
|
||||
ISOName=BNG
|
||||
ISOCode=008
|
||||
UnitMajor=gargantua
|
||||
UnitMinor=bloat
|
||||
Ratio=100
|
||||
Name=Brobdinagian Gargantua
|
||||
|
||||
[ELE]
|
||||
ISOName=ELE
|
||||
ISOCode=011
|
||||
UnitMajor=elbo
|
||||
UnitMinor=kni
|
||||
Ratio=100
|
||||
Name=Elbonia Elbo
|
||||
|
||||
[SBD]
|
||||
ISOName=SBD
|
||||
ISOCode=333
|
||||
UnitMajor=dunge
|
||||
UnitMinor=slop
|
||||
Ratio=100
|
||||
Name=Slobovia Dunge
|
||||
|
||||
[RYE]
|
||||
ISOName=RYE
|
||||
ISOCode=666
|
||||
UnitMajor=eldritch
|
||||
UnitMinor=voor
|
||||
Ratio=100
|
||||
Name=Rlyeh Eldritch
|
||||
|
||||
9842
components/systools/source/run/stccycnv.dat
Normal file
9842
components/systools/source/run/stccycnv.dat
Normal file
File diff suppressed because it is too large
Load Diff
848
components/systools/source/run/stconst.pas
Normal file
848
components/systools/source/run/stconst.pas
Normal file
@@ -0,0 +1,848 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StConst.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Base unit for SysTools *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
unit StConst;
|
||||
{-Resource constants for SysTools}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils;
|
||||
|
||||
const
|
||||
StVersionStr = '4.04';
|
||||
|
||||
const
|
||||
{string table constants for STREGINI}
|
||||
stscFalseString = 0;
|
||||
stscTrueString = 1;
|
||||
stscNoFileKey = 2;
|
||||
stscInvalidPKey = 3;
|
||||
stscNoWin32S = 4;
|
||||
stscCreateKeyFail = 5;
|
||||
stscOpenKeyFail = 6;
|
||||
stscIniWriteFail = 7;
|
||||
stscRegWriteFail = 8;
|
||||
stscNoKeyName = 9;
|
||||
stscQueryKeyFail = 10;
|
||||
stscEnumKeyFail = 11;
|
||||
stscEnumValueFail = 12;
|
||||
stscIniDeleteFail = 13;
|
||||
stscKeyHasSubKeys = 14;
|
||||
stscDeleteKeyFail = 15;
|
||||
stscIniDelValueFail = 16;
|
||||
stscRegDelValueFail = 17;
|
||||
stscOutputFileExists = 18;
|
||||
stscFileHasExtension = 19;
|
||||
stscSaveKeyFail = 20;
|
||||
stscNo16bitSupport = 21;
|
||||
stscCantFindInputFile = 22;
|
||||
stscLoadKeyFail = 23;
|
||||
stscUnloadKeyFail = 24;
|
||||
stscNotWinNTPlatform = 25;
|
||||
stscBadOptionsKeyCombo = 26;
|
||||
stscRestoreKeyFail = 27;
|
||||
stscReplaceKeyFail = 28;
|
||||
stscNoIniFileSupport = 29;
|
||||
stscRemoteKeyIsOpen = 30;
|
||||
stscConnectRemoteKeyFail = 31;
|
||||
stscCloseRemoteKeyFail = 32;
|
||||
stscFlushKeyFail = 33;
|
||||
stscBufferDataSizesDif = 34;
|
||||
stscKeyIsEmptyNotExists = 35;
|
||||
stscGetSecurityFail = 36;
|
||||
stscSetSecurityFail = 37;
|
||||
stscByteArrayTooLarge = 38;
|
||||
stscQueryValueFail = 39;
|
||||
stscNoValueNameSpecified = 40;
|
||||
|
||||
{string table constants for container classes}
|
||||
stscNoCompare = 51; {Compare property must be set}
|
||||
stscBadType = 52; {an incompatible class is passed to a method}
|
||||
stscBadSize = 53; {bad size for TStDictionary, TStBits, TStCollection}
|
||||
stscDupNode = 54; {attempt to add duplicate node to TStTree}
|
||||
stscBadIndex = 55; {bad index passed to TStBits or large array}
|
||||
stscBadWinMode = 56; {requires enhanced mode operation}
|
||||
stscUnknownClass = 57; {container class name not registered}
|
||||
stscUnknownNodeClass = 58; {container node class name not registered}
|
||||
stscNoStoreData = 59; {container has no store data routine}
|
||||
stscNoLoadData = 60; {container has no load data routine}
|
||||
stscWrongClass = 61; {container class and streamed class not equal}
|
||||
stscWrongNodeClass = 62; {container node class and streamed class not equal}
|
||||
stscBadCompare = 63; {invalid compare function or unable to assign now}
|
||||
stscTooManyCols = 64; {assign a matrix with >1 col to array}
|
||||
stscBadColCount = 65; {assign a matrix with wrong col count to virtual matrix}
|
||||
stscBadElSize = 66; {assign a matrix with wrong elem size to virtual matrix}
|
||||
stscBadDups = 67; {setting Dups to False in a non-empty sorted collection}
|
||||
|
||||
{string table constants for sorting unit}
|
||||
stscTooManyFiles = 71; {too many merge files in TStSorter}
|
||||
stscFileCreate = 72; {error creating file in TStSorter}
|
||||
stscFileOpen = 73; {error opening file in TStSorter}
|
||||
stscFileWrite = 74; {error writing file in TStSorter}
|
||||
stscFileRead = 75; {error reading file in TStSorter}
|
||||
stscBadState = 76; {TStSorter in wrong state}
|
||||
|
||||
{string table constants for Bcd unit}
|
||||
stscBcdBadFormat = 81; {bad BCD format}
|
||||
stscBcdOverflow = 82; {BCD larger than 10**64}
|
||||
stscBcdDivByZero = 83; {BCD divide by zero}
|
||||
stscBcdBadInput = 84; {BCD negative input to sqrt, ln, or power}
|
||||
stscBcdBufOverflow = 85; {buffer overflow in FormatBcd}
|
||||
|
||||
stscNoVerInfo = 100; {no version info in file}
|
||||
stscVerInfoFail = 101; {error reading version info}
|
||||
|
||||
(*
|
||||
{shell string constants}
|
||||
stscShellVersionError = 110; {not available in this version of Shell32.dll}
|
||||
stscShellFileOpSrcError = 111; {no source files specified}
|
||||
stscShellFileOpDstError = 112; {no destination files specified}
|
||||
stscShellFileOpMapError = 113; {mapping incomplete}
|
||||
stscShellFormatError = 114; {format error}
|
||||
stscShellFormatCancel = 115; {format cancelled}
|
||||
stscShellFormatNoFormat = 116; {drive cannot be formatted}
|
||||
stscShellFormatBadDrive = 117; {not removable drive}
|
||||
stscTrayIconInvalidOS = 118; {bad OS (NT 3.51)}
|
||||
stscTrayIconCantAdd = 119; {can't add icon to the tray}
|
||||
stscTrayIconCantDelete = 120; {can't delete icon from the tray}
|
||||
stscTrayIconError = 121; {general tray icon error}
|
||||
stscBadDropTarget = 122; {drop target is not TWinControl}
|
||||
stscCOMInitFailed = 123; {COInitialize failed}
|
||||
stscNoPathSpecified = 124; {No destination path for shortcut}
|
||||
stscIShellLinkError = 125; {Error creating IShellLink}
|
||||
stscNotShortcut = 126; {File is not a shortcut}
|
||||
stscTrayIconClose = 127; {Close}
|
||||
stscTrayIconRestore = 128; {Restore}
|
||||
stscInvalidTargetFile = 130; {Shortcut target file not found}
|
||||
stscShellFileOpDelete = 131; {Can't use file mappings with delete op}
|
||||
stscShellFileNotFound = 132; {One or more source files is missing}
|
||||
stscTrayIconDuplicate = 133; {Cant' have more than one tray icon}
|
||||
stscBadVerInfoKey = 134; {User-defined key not found in ver info}
|
||||
stscImageListInvalid = 135; {No image list assigned.}
|
||||
*)
|
||||
stscBadVerInfoKey = 134; {User-defined key not found in ver info}
|
||||
|
||||
{barcode errors}
|
||||
stscInvalidUPCACodeLen = 140;
|
||||
stscInvalidCharacter = 141;
|
||||
stscInvalidCheckCharacter = 142;
|
||||
stscInvalidUPCECodeLen = 143;
|
||||
stscInvalidEAN8CodeLen = 144;
|
||||
stscInvalidEAN13CodeLen = 145;
|
||||
stscInvalidSupCodeLen = 146;
|
||||
|
||||
{stexpr errors}
|
||||
stscExprEmpty = 150; {empty expression}
|
||||
stscExprBadNum = 151; {error in floating point number}
|
||||
stscExprBadChar = 152; {unknown character}
|
||||
stscExprOpndExp = 153; {expected function, number, sign, or (}
|
||||
stscExprNumeric = 154; {numeric error}
|
||||
stscExprBadExp = 155; {invalid expression}
|
||||
stscExprOpndOvfl = 156; {operand stack overflow}
|
||||
stscExprUnkFunc = 157; {unknown function identifier}
|
||||
stscExprLParExp = 158; {left parenthesis expected}
|
||||
stscExprRParExp = 159; {right parenthesis expected}
|
||||
stscExprCommExp = 160; {list separator (comma) expected}
|
||||
stscExprDupIdent = 161; {duplicate identifier}
|
||||
|
||||
{ststat errors}
|
||||
stscStatBadCount = 170; {unequal or bad counts of array elements}
|
||||
stscStatBadParam = 171; {invalid parameter}
|
||||
stscStatBadData = 172; {invalid data point in array}
|
||||
stscStatNoConverge = 173; {no convergence in numerical routine}
|
||||
|
||||
{stfin errors}
|
||||
stscFinBadArg = 180;
|
||||
stscFinNoConverge = 181;
|
||||
|
||||
{stmime errors}
|
||||
stscBadEncodeFmt = 190;
|
||||
stscBadAttachment = 191;
|
||||
stscDupeString = 192;
|
||||
stscInStream = 193;
|
||||
|
||||
{ststring errors}
|
||||
stscOutOfBounds = 200; {Index out of string bounds}
|
||||
|
||||
|
||||
{stBarPN errors}
|
||||
stscInvalidLength = 210;
|
||||
|
||||
{StHTML errors}
|
||||
stscNoInputFile = 215;
|
||||
stscNoOutputFile = 216;
|
||||
stscInFileError = 217;
|
||||
stscOutFileError = 218;
|
||||
stscWordDelimiters = 219;
|
||||
stscInvalidSLEntry = 220;
|
||||
stscBadStream = 221;
|
||||
|
||||
{StShlCtl constansts}
|
||||
stscName = 230;
|
||||
stscSize = 231;
|
||||
stscType = 232;
|
||||
stscModified = 233;
|
||||
stscAttributes = 234;
|
||||
stscFileFolder = 235;
|
||||
stscSystemFolder = 236;
|
||||
stscOriginalLoc = 237;
|
||||
stscDateDeleted = 238;
|
||||
stscFile = 239;
|
||||
stscInvalidFolder = 240;
|
||||
stscFolderReadOnly = 241;
|
||||
|
||||
{StSpawnApplication errors}
|
||||
stscInsufficientData= 250;
|
||||
|
||||
{StMemoryMappedFile errors}
|
||||
stscCreateFileFailed = 260;
|
||||
stscFileMappingFailed= 261;
|
||||
stscCreateViewFailed = 262;
|
||||
stscBadOrigin = 263;
|
||||
stscGetSizeFailed = 264;
|
||||
|
||||
{buffered stream errors}
|
||||
stscNilStream = 270;
|
||||
stscNoSeekForRead = 271;
|
||||
stscNoSeekForWrite = 272;
|
||||
stscCannotWrite = 273;
|
||||
stscBadTerminator = 274;
|
||||
stscBadLineLength = 275;
|
||||
stscCannotSetSize = 276;
|
||||
|
||||
{RegEx errors}
|
||||
stscUnknownError = 290;
|
||||
stscExpandingClass = 291;
|
||||
stscAlternationFollowsClosure = 292;
|
||||
stscUnbalancedParens = 293;
|
||||
stscFollowingClosure = 294;
|
||||
stscPatternError = 295;
|
||||
stscUnbalancedTag = 296;
|
||||
stscNoPatterns = 297;
|
||||
stscPatternTooLarge = 298;
|
||||
stscStreamsNil = 299;
|
||||
stscInTextStreamError = 300;
|
||||
stscOutTextStreamError = 301;
|
||||
stscClosureMaybeEmpty = 302;
|
||||
stscInFileNotFound = 303;
|
||||
stscREInFileError = 304;
|
||||
stscOutFileDelete = 305;
|
||||
stscOutFileCreate = 306;
|
||||
|
||||
|
||||
{StNet errors 320-339}
|
||||
stscNetNoManualCreate = 320;
|
||||
stscNetUnknownError = 321;
|
||||
stscNetGroupNotSpecified = 322;
|
||||
stscNetDateSpecifiedOutOfRange = 323;
|
||||
stscNetInvalidParameter = 324;
|
||||
stscNetInvalidItemType = 325;
|
||||
|
||||
{StNetConnection errors 330-334}
|
||||
|
||||
{StNetPerformance errors 335-339}
|
||||
|
||||
{StNetMessage errors 340-344}
|
||||
|
||||
{StMoney errors 400-429}
|
||||
// stscMoneyIdxOutOfRange = 400; //'Index out of range (%s)'
|
||||
stscMoneyNilResult = 401; //'Nil result parameter'
|
||||
stscMoneyNilParameter = 402; //'Nil parameter to operation'
|
||||
stscMoneyCurrenciesNotMatch = 403; //'Currencies do not match'
|
||||
stscMoneyNoExchangeRatesAvail = 410; //'No Exchange Rates Available'
|
||||
stscMoneyInvalidExchangeParams = 411; //'Invalid exchange parameters'
|
||||
stscMoneyInvalidTriangleExchange = 412; //'Invalid triangle exchange'
|
||||
stscMoneyNoSuchExchange = 413; //'No exchange rate for %s->%s available'
|
||||
stscMoneyMissingIntermediateRate = 414; //''Intermediate exchange rate for %s->%s missing'
|
||||
stscMoneyInvalidExchRate = 415; //'Exchange rate is missing a property value'
|
||||
stscMoneyTriExchUsesTriExch = 415; //'Triangular exchange rate is using triangular exchange rates'
|
||||
|
||||
stscDecMathRoundPlaces = 423; //'Decimal math: the number of decimal places to round to must be betwen 0 and 16'
|
||||
stscDecMathAsIntOverflow = 424; //'Decimal math: current value overflows an integer'
|
||||
stscDecMathConversion = 425; //'Decimal math: string value not a valid number';
|
||||
stscDecMathDivByZero = 426; //'Decimal math: division by zero attempted'
|
||||
stscDecMathNegExp = 427; //'Decimal math: cannot raise to a negative power';
|
||||
stscDecMathMultOverflow = 428; //'Decimal math: result overflowed during multiplication'
|
||||
stscDecMathDivOverflow = 429; //'Decimal math: result overflowed during division'
|
||||
|
||||
{ Text Data Set, Merge, and Export errors }
|
||||
stscTxtDatNoSuchField = 430; //'No such field'
|
||||
stscTxtDatUniqueNameRequired = 431; //'Field name must be unique'
|
||||
stscTxtDatUnhandledVariant = 432; //'Unhandled Variant Type'
|
||||
stscTxtDatInvalidSchema = 433; //'Invalid Schema'
|
||||
stscTxtDatRecordSetOpen = 434; //'Cannot perform this operation on an open record set'
|
||||
|
||||
{PRNG errors 460-479}
|
||||
stscPRNGDegFreedom = 460; //'StRandom: the number of degrees of freedom should be greater than zero'
|
||||
stscPRNGBetaShape = 461; //'StRandom: the Beta distribution shape values should be greater than zero'
|
||||
stscPRNGMean = 462; //'StRandom: the mean must be greater than zero'
|
||||
stscPRNGGammaShape = 463; //'StRandom: the Gamma distribution shape must be greater than zero'
|
||||
stscPRNGGammaScale = 464; //'StRandom: the Gamma distribution scale must be greater than zero'
|
||||
stscPRNGStdDev = 465; //'StRandom: the standard deviation must be greater than zero'
|
||||
stscPRNGWeibullShape = 466; //'StRandom: the Weibull distribution shape must be greater than zero'
|
||||
stscPRNGWeibullScale = 467; //'StRandom: the Weibull distribution scale must be greater than zero'
|
||||
stscPRNGLimit = 468; //'StRandom: the limit must be greater than zero'
|
||||
stscPRNGUpperLimit = 469; //'StRandom: the upper limit must be greater than the lower limit'
|
||||
stscPRNGErlangOrder = 470; //'StRandom: the Erlang distribution's order must be greater than zero'
|
||||
|
||||
resourcestring
|
||||
stscSysStringListFull = 'String list is full';
|
||||
stscSysBadStartDir = 'Invalid starting directory';
|
||||
|
||||
stscFalseStringS = 'FALSE';
|
||||
stscTrueStringS = 'TRUE';
|
||||
stscNoFileKeyS = 'No Ini File or Primary Key specified';
|
||||
stscInvalidPKeyS = 'Invalid primary key specified';
|
||||
stscNoWin32SS = 'RegIni Class not supported under Win32s';
|
||||
stscCreateKeyFailS = 'Failed to create key\nError Code: %d';
|
||||
stscOpenKeyFailS = 'Failed to open key\nError Code: %d';
|
||||
stscIniWriteFailS = 'Failed to write value to INI file';
|
||||
stscRegWriteFailS = 'Failed to write value to Registry\nError Code: %d';
|
||||
stscNoKeyNameS = 'No key name specified';
|
||||
stscQueryKeyFailS = 'Unable to query specified key\nError Code: %d';
|
||||
stscEnumKeyFailS = 'Unable to enumerate key\nError Code: %d';
|
||||
stscEnumValueFailS = 'Unable to enumerate value\nError Code: %d';
|
||||
stscIniDeleteFailS = 'Unable to delete section from INI file';
|
||||
stscKeyHasSubKeysS = 'Can not delete key which has subkeys (%d)';
|
||||
stscDeleteKeyFailS = 'Unable to delete key\nError Code: %d';
|
||||
stscIniDelValueFailS = 'Unable to delete value from INI file';
|
||||
stscRegDelValueFailS = 'Unable to delete value from key\nError Code: %d';
|
||||
stscOutputFileExistsS = 'Output file exists';
|
||||
stscFileHasExtensionS = 'File name can not have an extension';
|
||||
stscSaveKeyFailS = 'Unable to save key\nError Code: %d';
|
||||
stscNo16bitSupportS = 'Function not supported in 16-bit applications';
|
||||
stscCantFindInputFileS = 'Can not find input file';
|
||||
stscLoadKeyFailS = 'Unable to load key\nError Code: %d';
|
||||
stscUnloadKeyFailS = 'Unable to unload key\nErrorCode: %d';
|
||||
stscNotWinNTPlatformS = 'Function not supported on this platform';
|
||||
stscBadOptionsKeyComboS = 'Selection options incompatible\nwith specified primary key';
|
||||
stscRestoreKeyFailS = 'Unable to restore key\nError Code: %d';
|
||||
stscReplaceKeyFailS = 'Unable to replace key\nError Code: %d';
|
||||
stscNoIniFileSupportS = 'Function not supported on INI files';
|
||||
stscRemoteKeyIsOpenS = 'Remote key already open';
|
||||
stscConnectRemoteKeyFailS = 'Unable to connect to remote registry key\nError Code: %d';
|
||||
stscCloseRemoteKeyFailS = 'Unable to close remote registry key';
|
||||
stscFlushKeyFailS = 'Unable to flush specified key';
|
||||
stscBufferDataSizesDifS = 'Buffer size differs from data size\nBuffer: %d Data: %d';
|
||||
stscKeyIsEmptyNotExistsS = 'Specified Key is empty or does not exist';
|
||||
stscGetSecurityFailS = 'Failed to Get Security Information\nError Code: %d';
|
||||
stscSetSecurityFailS = 'Failed to Set Security Information\nError Code: %d';
|
||||
stscByteArrayTooLargeS = 'Size of byte array exceeds limit';
|
||||
stscQueryValueFailS = 'Unable to query value in key';
|
||||
stscNoValueNameSpecifiedS = 'No Value Name specified';
|
||||
|
||||
stscNoCompareS = 'Compare property must be set';
|
||||
stscBadTypeS = 'An incompatible class is passed to a method';
|
||||
stscBadSizeS = 'Bad size parameter';
|
||||
stscDupNodeS = 'Attempt to add duplicate node to TStTree';
|
||||
stscBadIndexS = 'Index is out of range';
|
||||
stscBadWinModeS = 'Requires enhanced mode operation for Windows 3.1x';
|
||||
stscUnknownClassS = 'Container class name %s read from stream is unregistered';
|
||||
stscUnknownNodeClassS = 'Node class name %s read from stream is unregistered';
|
||||
stscNoStoreDataS = 'Container''s StoreData property is unassigned';
|
||||
stscNoLoadDataS = 'Container''s LoadData property is unassigned';
|
||||
stscWrongClassS = 'Class name on stream differs from object''s class';
|
||||
stscWrongNodeClassS = 'Node class name on stream differs from object''s node class';
|
||||
stscBadCompareS = 'Unable to assign this compare function now';
|
||||
stscTooManyColsS = 'Cannot assign a matrix with more than 1 column to an array';
|
||||
stscBadColCountS = 'Can only assign a matrix to a virtual matrix if column counts are equal';
|
||||
stscBadElSizeS = 'Can only assign a matrix to a virtual matrix if element sizes are equal';
|
||||
stscBadDupsS = 'Can only set Duplicates to False in an empty sorted collection';
|
||||
|
||||
stscTooManyFilesS = 'Too many merge files in TStSorter';
|
||||
stscFileCreateS = 'Error creating file';
|
||||
stscFileOpenS = 'Error opening file';
|
||||
stscFileWriteS = 'Error writing file (bytes written <> bytes requested)';
|
||||
stscFileReadS = 'Error reading file (bytes read <> bytes requested)';
|
||||
stscBadStateS = 'TStSorter in wrong state';
|
||||
|
||||
stscBcdBadFormatS = 'Bad BCD format';
|
||||
stscBcdOverflowS = 'BCD larger than 10**64';
|
||||
stscBcdDivByZeroS = 'BCD divide by zero';
|
||||
stscBcdBadInputS = 'BCD negative input to sqrt, ln, or power';
|
||||
stscBcdBufOverflowS = 'Buffer overflow in FormatBcd';
|
||||
|
||||
stscNoVerInfoS = 'File does not contain version info';
|
||||
stscVerInfoFailS = 'Unable to read version info';
|
||||
|
||||
(*
|
||||
stscShellVersionErrorS = 'Operation not supported in this version of the shell';
|
||||
stscShellFileOpSrcErrorS = 'No source files specified';
|
||||
stscShellFileOpDstErrorS = 'No destination files specified';
|
||||
stscShellFileOpMapErrorS = 'File mapping incomplete';
|
||||
stscShellFormatErrorS = 'Format failed';
|
||||
stscShellFormatCancelS = 'Format cancelled';
|
||||
stscShellFormatNoFormatS = 'Drive cannot be formatted';
|
||||
stscShellFormatBadDriveS = 'Invalid drive. Drive is not removable';
|
||||
stscTrayIconInvalidOSS = 'Operating system does not support tray icons';
|
||||
stscTrayIconCantAddS = 'Error adding tray icon';
|
||||
stscTrayIconCantDeleteS = 'Error removing tray icon';
|
||||
stscTrayIconErrorS = 'Tray icon error';
|
||||
stscBadDropTargetS = 'Drop target must be a TWinControl descendant';
|
||||
stscCOMInitFailedS = 'Cannot initialize COM';
|
||||
stscNoPathSpecifiedS = 'Destination directory not specified';
|
||||
stscIShellLinkErrorS = 'Error creating IShellLink';
|
||||
stscNotShortcutS = 'File is not a shortcut';
|
||||
stscTrayIconCloseS = '&Close';
|
||||
stscTrayIconRestoreS = '&Restore';
|
||||
stscInvalidTargetFileS = 'Cannot create shortcut. Target file does not exist';
|
||||
stscShellFileOpDeleteS = 'Cannot use file mappings in a delete operation';
|
||||
stscShellFileNotFoundS = 'Source file error, file not found';
|
||||
stscTrayIconDuplicateS = 'Cannot have more than one StTrayIcon per application';
|
||||
stscBadVerInfoKeyS = 'The specified key cannnot be found in version info';
|
||||
stscImageListInvalidS = 'ImageList is not assigned';
|
||||
*)
|
||||
stscBadVerInfoKeyS = 'The specified key cannnot be found in version info';
|
||||
|
||||
stscInvalidUPCACodeLenS = 'Invalid code length (must be 11 or 12)';
|
||||
stscInvalidCharacterS = 'Invalid character';
|
||||
stscInvalidCheckCharacterS = 'Invalid check character';
|
||||
stscInvalidUPCECodeLenS = 'Invalid code length (must be 6)';
|
||||
stscInvalidEAN8CodeLenS = 'Invalid code length (must be 7 or 8)';
|
||||
stscInvalidEAN13CodeLenS = 'Invalid code length (must be 12 or 13)';
|
||||
stscInvalidSupCodeLenS = 'Invalid supplemental code length (must be 2 or 5)';
|
||||
|
||||
stscFinBadArgS = 'Invalid argument to financial function';
|
||||
stscFinNoConvergeS = 'Function does not converge';
|
||||
|
||||
stscExprEmptyS = 'Empty expression';
|
||||
stscExprBadNumS = 'Error in floating point number';
|
||||
stscExprBadCharS = 'Unknown character';
|
||||
stscExprOpndExpS = 'Expected function, number, sign, or (';
|
||||
stscExprNumericS = 'Numeric error';
|
||||
stscExprBadExpS = 'Invalid expression';
|
||||
stscExprOpndOvflS = 'Operand stack overflow';
|
||||
stscExprUnkFuncS = 'Unknown function identifier';
|
||||
stscExprLParExpS = 'Left parenthesis expected';
|
||||
stscExprRParExpS = 'Right parenthesis expected';
|
||||
stscExprCommExpS = 'List separator expected';
|
||||
stscExprDupIdentS = 'Duplicate identifier';
|
||||
|
||||
stscBadEncodeFmtS = 'Encoding Format Not Supported';
|
||||
stscBadAttachmentS = 'Attachment Doesn''t Exist';
|
||||
stscDupeStringS = 'Duplicate string';
|
||||
stscInStreamS = 'Error in input stream';
|
||||
|
||||
stscOutOfBoundsS = 'Index out of string bounds';
|
||||
|
||||
stscInvalidLengthS = 'POSTNET code must be 5, 9 or 11 digits';
|
||||
|
||||
|
||||
stscNoInputFileS = 'Input file not specified';
|
||||
stscNoOutputFileS = 'Output file not specified';
|
||||
stscInFileErrorS = 'Error opening input file';
|
||||
stscOutFileErrorS = 'Error creating output file';
|
||||
|
||||
|
||||
stscNameS = 'Name';
|
||||
stscSizeS = 'Size';
|
||||
stscTypeS = 'Type';
|
||||
stscModifiedS = 'Modified';
|
||||
stscAttributesS = 'Attributes';
|
||||
stscFileFolderS = 'File Folder';
|
||||
stscSystemFolderS = 'System Folder';
|
||||
stscOriginalLocS = 'Original Location';
|
||||
stscDateDeletedS = 'Date Deleted';
|
||||
stscFileS = 'File';
|
||||
stscInvalidFolderS = 'Invalid folder';
|
||||
stscFolderReadOnlyS = 'Cannot create folder: Parent folder is read-only';
|
||||
stscInvalidSortDirS = 'Invalid sort direction';
|
||||
|
||||
stscInsufficientDataS = 'FileName cannot be empty when RunParameters is specified';
|
||||
|
||||
stscCreateFileFailedS = 'CreateFile failed';
|
||||
stscFileMappingFailedS = 'CreateFileMapping failed';
|
||||
stscCreateViewFailedS = 'MapViewOfFile failed';
|
||||
stscBadOriginS = 'Bad origin parameter for call to Seek';
|
||||
stscGetSizeFailedS = 'Error reading size of existing file';
|
||||
|
||||
stscNilStreamS = 'Buffered/text stream: Attempted to read, write, or seek and underlying stream is nil';
|
||||
stscNoSeekForReadS = 'Buffered/text stream: Could not seek to the correct position in the underlying stream (for read request)';
|
||||
stscNoSeekForWriteS = 'Buffered/text stream: Could not seek to the correct position in the underlying stream (for write request)';
|
||||
stscCannotWriteS = 'Buffered/text stream: Could not write the entire buffer to the underlying stream';
|
||||
stscBadTerminatorS = 'Text stream: Case statement was used with a bad value of LineTerminator';
|
||||
stscBadLineLengthS = 'Text stream: Length of a fixed line must be between 1 and 4096 bytes';
|
||||
stscCannotSetSizeS = 'Buffered/text stream: Cannot set the size of the underlying stream (needs OnSetStreamSize event)';
|
||||
|
||||
stscUnknownErrorS = 'Unknown error creating a pattern token';
|
||||
stscExpandingClassS = 'Problem in expanding character class';
|
||||
stscAlternationFollowsClosureS = 'Alternation cannot immediately follow a closure marker';
|
||||
stscUnbalancedParensS = 'Unbalanced nesting parentheses';
|
||||
stscFollowingClosureS = 'Closure cannot immediately follow BegOfLine, EndOfLine or another closure';
|
||||
stscPatternErrorS = 'Error detected near end of pattern';
|
||||
stscUnbalancedTagS = 'Unbalanced tag marker';
|
||||
stscNoPatternsS = 'No Match, Replace, or SelAvoid Patterns defined';
|
||||
stscPatternTooLargeS = 'Pattern exceeds MaxPatLen';
|
||||
stscStreamsNilS = 'Input and/or output stream is not assigned';
|
||||
stscInTextStreamErrorS = 'Error creating internal input text stream';
|
||||
stscOutTextStreamErrorS = 'Error creating internal output text stream';
|
||||
stscClosureMaybeEmptyS = 'A * or + operand could be empty';
|
||||
stscOutFileDeleteS = 'Error deleting old previous file';
|
||||
stscInFileNotFoundS = 'Input file not found';
|
||||
stscREInFileErrorS = 'Error creating internal text stream';
|
||||
stscOutFileCreateS = 'Error creating output file';
|
||||
|
||||
|
||||
stscNetNoManualCreateS = 'Can''t manually create an object of this type';
|
||||
stscNetUnknownErrorS = 'Unknown network error';
|
||||
stscNetGroupNotSpecifiedS = 'Local or global group not specified';
|
||||
stscNetDateSpecifiedOutOfRangeS = 'Date specified out or range';
|
||||
stscNetInvalidParameterS = 'Invalid parameter';
|
||||
stscNetInvalidItemTypeS = 'Invalid item type for this method';
|
||||
|
||||
stscStatBadCountS = 'Unequal or bad counts of array elements';
|
||||
stscStatBadParamS = 'Invalid parameter';
|
||||
stscStatBadDataS = 'Invalid data point in array';
|
||||
stscStatNoConvergeS = 'no convergence in numerical routine';
|
||||
|
||||
stscWordDelimitersS = '219';
|
||||
stscInvalidSLEntryS = '220';
|
||||
stscBadStreamS = '221';
|
||||
|
||||
stscMoneyIdxOutOfRangeS = 'Index out of range (%s)';
|
||||
stscMoneyNilResultS = 'Nil result parameter';
|
||||
stscMoneyNilParameterS = 'Nil parameter to operation';
|
||||
stscMoneyCurrenciesNotMatchS = 'Currencies do not match';
|
||||
stscMoneyNoExchangeRatesAvailS = 'No Exchange Rates Available';
|
||||
stscMoneyInvalidExchangeParamsS = 'Invalid exchange parameters';
|
||||
stscMoneyInvalidTriangleExchangeS = 'Invalid triangle exchange';
|
||||
stscMoneyNoSuchExchangeS = 'No exchange rate for %s->%s available';
|
||||
stscMoneyMissingIntermediateRateS = 'Intermediate exchange rate for %s->%s missing';
|
||||
stscMoneyInvalidExchRateS = 'Exchange rate is missing a property value';
|
||||
stscMoneyTriExchUsesTriExchS = 'Triangular exchange rate is using triangular exchange rates';
|
||||
|
||||
stscDecMathRoundPlacesS = 'Decimal math: the number of decimal places to round to must be betwen 0 and 16';
|
||||
stscDecMathAsIntOverflowS = 'Decimal math: current value overflows an integer';
|
||||
stscDecMathConversionS = 'Decimal math: string value not a valid number';
|
||||
stscDecMathDivByZeroS = 'Decimal math: division by zero attempted';
|
||||
stscDecMathNegExpS = 'Decimal math: cannot raise to a negative power';
|
||||
stscDecMathMultOverflowS = 'Decimal math: result overflowed during multiplication';
|
||||
stscDecMathDivOverflowS = 'Decimal math: result overflowed during division';
|
||||
|
||||
stscTxtDatNoSuchFieldS = 'No such field';
|
||||
stscTxtDatUniqueNameRequiredS = 'Field name must be unique';
|
||||
stscTxtDatUnhandledVariantS = 'Unhandled Variant Type';
|
||||
stscTxtDatInvalidSchemaS = 'Invalid Schema';
|
||||
stscTxtDatRecordSetOpenS = 'Cannot perform this operation on an open record set';
|
||||
|
||||
stscPRNGDegFreedomS = 'StRandom: the number of degrees of freedom should be greater than zero';
|
||||
stscPRNGBetaShapeS = 'StRandom: the Beta distribution shape values should be greater than zero';
|
||||
stscPRNGMeanS = 'StRandom: the mean must be greater than zero';
|
||||
stscPRNGGammaShapeS = 'StRandom: the Gamma distribution shape must be greater than zero';
|
||||
stscPRNGGammaScaleS = 'StRandom: the Gamma distribution scale must be greater than zero';
|
||||
stscPRNGStdDevS = 'StRandom: the standard deviation must be greater than zero';
|
||||
stscPRNGWeibullShapeS = 'StRandom: the Weibull distribution shape must be greater than zero';
|
||||
stscPRNGWeibullScaleS = 'StRandom: the Weibull distribution scale must be greater than zero';
|
||||
stscPRNGLimitS = 'StRandom: the limit must be greater than zero';
|
||||
stscPRNGUpperLimitS = 'StRandom: the upper limit must be greater than the lower limit';
|
||||
stscPRNGErlangOrderS = 'StRandom: the Erlang distribution''s order must be greater than zero';
|
||||
|
||||
|
||||
type
|
||||
StStrRec = record
|
||||
ID: Integer;
|
||||
Str: string;
|
||||
end;
|
||||
|
||||
const
|
||||
SysToolsStrArray : array [0..174] of StStrRec = (
|
||||
|
||||
{string table constants for STREGINI}
|
||||
(ID: stscFalseString; Str: stscFalseStringS),
|
||||
(ID: stscTrueString; Str: stscTrueStringS),
|
||||
(ID: stscNoFileKey; Str: stscNoFileKeyS),
|
||||
(ID: stscInvalidPKey; Str: stscInvalidPKeyS),
|
||||
(ID: stscNoWin32S; Str: stscNoWin32SS),
|
||||
(ID: stscCreateKeyFail; Str: stscCreateKeyFailS),
|
||||
(ID: stscOpenKeyFail; Str: stscOpenKeyFailS),
|
||||
(ID: stscIniWriteFail; Str: stscIniWriteFailS),
|
||||
(ID: stscRegWriteFail; Str: stscRegWriteFailS),
|
||||
(ID: stscNoKeyName; Str: stscNoKeyNameS),
|
||||
(ID: stscQueryKeyFail; Str: stscQueryKeyFailS),
|
||||
(ID: stscEnumKeyFail; Str: stscEnumKeyFailS),
|
||||
(ID: stscEnumValueFail; Str: stscEnumValueFailS),
|
||||
(ID: stscIniDeleteFail; Str: stscIniDeleteFailS),
|
||||
(ID: stscKeyHasSubKeys; Str: stscKeyHasSubKeysS),
|
||||
(ID: stscDeleteKeyFail; Str: stscDeleteKeyFailS),
|
||||
(ID: stscIniDelValueFail; Str: stscIniDelValueFailS),
|
||||
(ID: stscRegDelValueFail; Str: stscRegDelValueFailS),
|
||||
(ID: stscOutputFileExists; Str: stscOutputFileExistsS),
|
||||
(ID: stscFileHasExtension; Str: stscFileHasExtensionS),
|
||||
(ID: stscSaveKeyFail; Str: stscSaveKeyFailS),
|
||||
(ID: stscNo16bitSupport; Str: stscNo16bitSupportS),
|
||||
(ID: stscCantFindInputFile; Str: stscCantFindInputFileS),
|
||||
(ID: stscLoadKeyFail; Str: stscLoadKeyFailS),
|
||||
(ID: stscUnloadKeyFail; Str: stscUnloadKeyFailS),
|
||||
(ID: stscNotWinNTPlatform; Str: stscNotWinNTPlatformS),
|
||||
(ID: stscBadOptionsKeyCombo; Str: stscBadOptionsKeyComboS),
|
||||
(ID: stscRestoreKeyFail; Str: stscRestoreKeyFailS),
|
||||
(ID: stscReplaceKeyFail; Str: stscReplaceKeyFailS),
|
||||
(ID: stscNoIniFileSupport; Str: stscNoIniFileSupportS),
|
||||
(ID: stscRemoteKeyIsOpen; Str: stscRemoteKeyIsOpenS),
|
||||
(ID: stscConnectRemoteKeyFail; Str: stscConnectRemoteKeyFailS),
|
||||
(ID: stscCloseRemoteKeyFail; Str: stscCloseRemoteKeyFailS),
|
||||
(ID: stscFlushKeyFail; Str: stscFlushKeyFailS),
|
||||
(ID: stscBufferDataSizesDif; Str: stscBufferDataSizesDifS),
|
||||
(ID: stscKeyIsEmptyNotExists; Str: stscKeyIsEmptyNotExistsS),
|
||||
(ID: stscGetSecurityFail; Str: stscGetSecurityFailS),
|
||||
(ID: stscSetSecurityFail; Str: stscSetSecurityFailS),
|
||||
(ID: stscByteArrayTooLarge; Str: stscByteArrayTooLargeS),
|
||||
(ID: stscQueryValueFail; Str: stscQueryValueFailS),
|
||||
(ID: stscNoValueNameSpecified; Str: stscNoValueNameSpecifiedS),
|
||||
|
||||
{string table constants for container classes}
|
||||
(ID: stscNoCompare; Str: stscNoCompareS), {Compare property must be set}
|
||||
(ID: stscBadType; Str: stscBadTypeS), {an incompatible class is passed to a method}
|
||||
(ID: stscBadSize; Str: stscBadSizeS), {bad size for TStDictionary, TStBits, TStCollection}
|
||||
(ID: stscDupNode; Str: stscDupNodeS), {attempt to add duplicate node to TStTree}
|
||||
(ID: stscBadIndex; Str: stscBadIndexS), {bad index passed to TStBits or large array}
|
||||
(ID: stscBadWinMode; Str: stscBadWinModeS), {requires enhanced mode operation}
|
||||
(ID: stscUnknownClass; Str: stscUnknownClassS), {container class name not registered}
|
||||
(ID: stscUnknownNodeClass; Str: stscUnknownNodeClassS), {container node class name not registered}
|
||||
(ID: stscNoStoreData; Str: stscNoStoreDataS), {container has no store data routine}
|
||||
(ID: stscNoLoadData; Str: stscNoLoadDataS), {container has no load data routine}
|
||||
(ID: stscWrongClass; Str: stscWrongClassS), {container class and streamed class not equal}
|
||||
(ID: stscWrongNodeClass; Str: stscWrongNodeClassS), {container node class and streamed class not equal}
|
||||
(ID: stscBadCompare; Str: stscBadCompareS), {invalid compare function or unable to assign now}
|
||||
(ID: stscTooManyCols; Str: stscTooManyColsS), {assign a matrix with >1 col to array}
|
||||
(ID: stscBadColCount; Str: stscBadColCountS), {assign a matrix with wrong col count to virtual matrix}
|
||||
(ID: stscBadElSize; Str: stscBadElSizeS), {assign a matrix with wrong elem size to virtual matrix}
|
||||
(ID: stscBadDups; Str: stscBadDupsS), {setting Dups to False in a non-empty sorted collection}
|
||||
|
||||
{string table constants for sorting unit}
|
||||
(ID: stscTooManyFiles; Str: stscTooManyFilesS), {too many merge files in TStSorter}
|
||||
(ID: stscFileCreate; Str: stscFileCreateS), {error creating file in TStSorter}
|
||||
(ID: stscFileOpen; Str: stscFileOpenS), {error opening file in TStSorter}
|
||||
(ID: stscFileWrite; Str: stscFileWriteS), {error writing file in TStSorter}
|
||||
(ID: stscFileRead; Str: stscFileReadS), {error reading file in TStSorter}
|
||||
(ID: stscBadState; Str: stscBadStateS), {TStSorter in wrong state}
|
||||
|
||||
{string table constants for Bcd unit}
|
||||
(ID: stscBcdBadFormat; Str: stscBcdBadFormatS), {bad BCD format}
|
||||
(ID: stscBcdOverflow; Str: stscBcdOverflowS), {BCD larger than 10**64}
|
||||
(ID: stscBcdDivByZero; Str: stscBcdDivByZeroS), {BCD divide by zero}
|
||||
(ID: stscBcdBadInput; Str: stscBcdBadInputS), {BCD negative input to sqrt, ln, or power}
|
||||
(ID: stscBcdBufOverflow; Str: stscBcdBufOverflowS), {buffer overflow in FormatBcd}
|
||||
(ID: stscNoVerInfo; Str: stscNoVerInfoS), {no version info in file}
|
||||
(ID: stscVerInfoFail; Str: stscVerInfoFailS), {error reading version info}
|
||||
|
||||
(*
|
||||
{shell string constants}
|
||||
(ID: stscShellVersionError; Str: stscShellVersionErrorS), {not available in this version of Shell32.dll}
|
||||
(ID: stscShellFileOpSrcError; Str: stscShellFileOpSrcErrorS), {no source files specified}
|
||||
(ID: stscShellFileOpDstError; Str: stscShellFileOpDstErrorS), {no destination files specified}
|
||||
(ID: stscShellFileOpMapError; Str: stscShellFileOpMapErrorS), {mapping incomplete}
|
||||
(ID: stscShellFormatError; Str: stscShellFormatErrorS), {format error}
|
||||
(ID: stscShellFormatCancel; Str: stscShellFormatCancelS), {format cancelled}
|
||||
(ID: stscShellFormatNoFormat; Str: stscShellFormatNoFormatS), {drive cannot be formatted}
|
||||
(ID: stscShellFormatBadDrive; Str: stscShellFormatBadDriveS), {not removable drive}
|
||||
(ID: stscTrayIconInvalidOS; Str: stscTrayIconInvalidOSS), {bad OS (NT 3.51)}
|
||||
(ID: stscTrayIconCantAdd; Str: stscTrayIconCantAddS), {can't add icon to the tray}
|
||||
(ID: stscTrayIconCantDelete; Str: stscTrayIconCantDeleteS), {can't delete icon from the tray}
|
||||
(ID: stscTrayIconError; Str: stscTrayIconErrorS), {general tray icon error}
|
||||
(ID: stscBadDropTarget; Str: stscBadDropTargetS), {drop target is not TWinControl}
|
||||
(ID: stscCOMInitFailed; Str: stscCOMInitFailedS), {COInitialize failed}
|
||||
(ID: stscNoPathSpecified; Str: stscNoPathSpecifiedS), {No destination path for shortcut}
|
||||
(ID: stscIShellLinkError; Str: stscIShellLinkErrorS), {Error creating IShellLink}
|
||||
(ID: stscNotShortcut; Str: stscNotShortcutS), {File is not a shortcut}
|
||||
(ID: stscTrayIconClose; Str: stscTrayIconCloseS), {Close}
|
||||
(ID: stscTrayIconRestore; Str: stscTrayIconRestoreS), {Restore}
|
||||
(ID: stscInvalidTargetFile; Str: stscInvalidTargetFileS), {Shortcut target file not found}
|
||||
(ID: stscShellFileOpDelete; Str: stscShellFileOpDeleteS), {Can't use file mappings with delete op}
|
||||
(ID: stscShellFileNotFound; Str: stscShellFileNotFoundS), {One or more source files is missing}
|
||||
(ID: stscTrayIconDuplicate; Str: stscTrayIconDuplicateS), {Cant' have more than one tray icon}
|
||||
(ID: stscBadVerInfoKey; Str: stscBadVerInfoKeyS), {User-defined key not found in ver info}
|
||||
(ID: stscImageListInvalid; Str: stscImageListInvalidS), {No image list assigned.}
|
||||
*)
|
||||
(ID: stscBadVerInfoKey; Str: stscBadVerInfoKeyS), {User-defined key not found in ver info}
|
||||
|
||||
{barcode errors}
|
||||
(ID: stscInvalidUPCACodeLen; Str: stscInvalidUPCACodeLenS),
|
||||
(ID: stscInvalidCharacter; Str: stscInvalidCharacterS),
|
||||
(ID: stscInvalidCheckCharacter; Str: stscInvalidCheckCharacterS),
|
||||
(ID: stscInvalidUPCECodeLen; Str: stscInvalidUPCECodeLenS),
|
||||
(ID: stscInvalidEAN8CodeLen; Str: stscInvalidEAN8CodeLenS),
|
||||
(ID: stscInvalidEAN13CodeLen; Str: stscInvalidEAN13CodeLenS),
|
||||
(ID: stscInvalidSupCodeLen; Str: stscInvalidSupCodeLenS),
|
||||
|
||||
{stexpr errors}
|
||||
(ID: stscExprEmpty; Str: stscExprEmptyS), {empty expression}
|
||||
(ID: stscExprBadNum; Str: stscExprBadNumS), {error in floating point number}
|
||||
(ID: stscExprBadChar; Str: stscExprBadCharS), {unknown character}
|
||||
(ID: stscExprOpndExp; Str: stscExprOpndExpS), {expected function, number, sign, or (}
|
||||
(ID: stscExprNumeric; Str: stscExprNumericS), {numeric error}
|
||||
(ID: stscExprBadExp; Str: stscExprBadExpS), {invalid expression}
|
||||
(ID: stscExprOpndOvfl; Str: stscExprOpndOvflS), {operand stack overflow}
|
||||
(ID: stscExprUnkFunc; Str: stscExprUnkFuncS), {unknown function identifier}
|
||||
(ID: stscExprLParExp; Str: stscExprLParExpS), {left parenthesis expected}
|
||||
(ID: stscExprRParExp; Str: stscExprRParExpS), {right parenthesis expected}
|
||||
(ID: stscExprCommExp; Str: stscExprCommExpS), {list separator (comma) expected}
|
||||
(ID: stscExprDupIdent; Str: stscExprDupIdentS), {duplicate identifier}
|
||||
|
||||
{ststat errors}
|
||||
(ID: stscStatBadCount; Str: stscStatBadCountS), {unequal or bad counts of array elements}
|
||||
(ID: stscStatBadParam; Str: stscStatBadParamS), {invalid parameter}
|
||||
(ID: stscStatBadData; Str: stscStatBadDataS), {invalid data point in array}
|
||||
(ID: stscStatNoConverge; Str: stscStatNoConvergeS), {no convergence in numerical routine}
|
||||
|
||||
{stfin errors}
|
||||
(ID: stscFinBadArg; Str: stscFinBadArgS),
|
||||
(ID: stscFinNoConverge; Str: stscFinNoConvergeS),
|
||||
|
||||
{stmime errors}
|
||||
(ID: stscBadEncodeFmt; Str: stscBadEncodeFmtS),
|
||||
(ID: stscBadAttachment; Str: stscBadAttachmentS),
|
||||
(ID: stscDupeString; Str: stscDupeStringS),
|
||||
(ID: stscInStream; Str: stscInStreamS),
|
||||
|
||||
{ststring errors}
|
||||
(ID: stscOutOfBounds; Str: stscOutOfBoundsS), {Index out of string bounds}
|
||||
|
||||
|
||||
{stBarPN errors}
|
||||
(ID: stscInvalidLength; Str: stscInvalidLengthS),
|
||||
|
||||
{StHTML errors}
|
||||
(ID: stscNoInputFile; Str: stscNoInputFileS),
|
||||
(ID: stscNoOutputFile; Str: stscNoOutputFileS),
|
||||
(ID: stscInFileError; Str: stscInFileErrorS),
|
||||
(ID: stscOutFileError; Str: stscOutFileErrorS),
|
||||
(ID: stscWordDelimiters; Str: stscWordDelimitersS),
|
||||
(ID: stscInvalidSLEntry; Str: stscInvalidSLEntryS),
|
||||
(ID: stscBadStream; Str: stscBadStreamS),
|
||||
|
||||
{StShlCtl constansts}
|
||||
(ID: stscName; Str: stscNameS),
|
||||
(ID: stscSize; Str: stscSizeS),
|
||||
(ID: stscType; Str: stscTypeS),
|
||||
(ID: stscModified; Str: stscModifiedS),
|
||||
(ID: stscAttributes; Str: stscAttributesS),
|
||||
(ID: stscFileFolder; Str: stscFileFolderS),
|
||||
(ID: stscSystemFolder; Str: stscSystemFolderS),
|
||||
(ID: stscOriginalLoc; Str: stscOriginalLocS),
|
||||
(ID: stscDateDeleted; Str: stscDateDeletedS),
|
||||
(ID: stscFile; Str: stscFileS),
|
||||
(ID: stscInvalidFolder; Str: stscInvalidFolderS),
|
||||
(ID: stscFolderReadOnly; Str: stscFolderReadOnlyS),
|
||||
|
||||
{StSpawnApplication errors}
|
||||
(ID: stscInsufficientData; Str: stscInsufficientDataS),
|
||||
|
||||
{StMemoryMappedFile errors}
|
||||
(ID: stscCreateFileFailed; Str: stscCreateFileFailedS),
|
||||
(ID: stscFileMappingFailed; Str: stscFileMappingFailedS),
|
||||
(ID: stscCreateViewFailed; Str: stscCreateViewFailedS),
|
||||
(ID: stscBadOrigin; Str: stscBadOriginS),
|
||||
(ID: stscGetSizeFailed; Str: stscGetSizeFailedS),
|
||||
|
||||
{buffered stream errors}
|
||||
(ID: stscNilStream; Str: stscNilStreamS),
|
||||
(ID: stscNoSeekForRead; Str: stscNoSeekForReadS),
|
||||
(ID: stscNoSeekForWrite; Str: stscNoSeekForWriteS),
|
||||
(ID: stscCannotWrite; Str: stscCannotWriteS),
|
||||
(ID: stscBadTerminator; Str: stscBadTerminatorS),
|
||||
(ID: stscBadLineLength; Str: stscBadLineLengthS),
|
||||
(ID: stscCannotSetSize; Str: stscCannotSetSizeS),
|
||||
|
||||
{RegEx errors}
|
||||
(ID: stscUnknownError; Str: stscUnknownErrorS),
|
||||
(ID: stscExpandingClass; Str: stscExpandingClassS),
|
||||
(ID: stscAlternationFollowsClosure; Str: stscAlternationFollowsClosureS),
|
||||
(ID: stscUnbalancedParens; Str: stscUnbalancedParensS),
|
||||
(ID: stscFollowingClosure; Str: stscFollowingClosureS),
|
||||
(ID: stscPatternError; Str: stscPatternErrorS),
|
||||
(ID: stscUnbalancedTag; Str: stscUnbalancedTagS),
|
||||
(ID: stscNoPatterns; Str: stscNoPatternsS),
|
||||
(ID: stscPatternTooLarge; Str: stscPatternTooLargeS),
|
||||
(ID: stscStreamsNil; Str: stscStreamsNilS),
|
||||
(ID: stscInTextStreamError; Str: stscInTextStreamErrorS),
|
||||
(ID: stscOutTextStreamError; Str: stscOutTextStreamErrorS),
|
||||
(ID: stscClosureMaybeEmpty; Str: stscClosureMaybeEmptyS),
|
||||
(ID: stscInFileNotFound; Str: stscInFileNotFoundS),
|
||||
(ID: stscREInFileError; Str: stscREInFileErrorS),
|
||||
(ID: stscOutFileDelete; Str: stscOutFileDeleteS),
|
||||
(ID: stscOutFileCreate; Str: stscOutFileCreateS),
|
||||
|
||||
|
||||
{StNet errors 320-339}
|
||||
(ID: stscNetNoManualCreate; Str: stscNetNoManualCreateS),
|
||||
(ID: stscNetUnknownError; Str: stscNetUnknownErrorS),
|
||||
(ID: stscNetGroupNotSpecified; Str: stscNetGroupNotSpecifiedS),
|
||||
(ID: stscNetDateSpecifiedOutOfRange; Str: stscNetDateSpecifiedOutOfRangeS),
|
||||
(ID: stscNetInvalidParameter; Str: stscNetInvalidParameterS),
|
||||
(ID: stscNetInvalidItemType; Str: stscNetInvalidItemTypeS),
|
||||
|
||||
{ StMoney errors }
|
||||
// (ID: stscMoneyIdxOutOfRange; Str: stscMoneyIdxOutOfRangeS),
|
||||
(ID: stscMoneyNilResult; Str: stscMoneyNilResultS),
|
||||
(ID: stscMoneyNilParameter; Str: stscMoneyNilParameterS),
|
||||
(ID: stscMoneyCurrenciesNotMatch; Str: stscMoneyCurrenciesNotMatchS),
|
||||
(ID: stscMoneyNoExchangeRatesAvail; Str: stscMoneyNoExchangeRatesAvailS),
|
||||
(ID: stscMoneyInvalidExchangeParams; Str: stscMoneyInvalidExchangeParamsS),
|
||||
(ID: stscMoneyInvalidTriangleExchange; Str: stscMoneyInvalidTriangleExchangeS),
|
||||
(ID: stscMoneyNoSuchExchange; Str: stscMoneyNoSuchExchangeS),
|
||||
(ID: stscMoneyMissingIntermediateRate; Str: stscMoneyMissingIntermediateRateS),
|
||||
(ID: stscMoneyInvalidExchRate; Str: stscMoneyInvalidExchRateS),
|
||||
(ID: stscMoneyTriExchUsesTriExch; Str: stscMoneyTriExchUsesTriExchS),
|
||||
(ID: stscDecMathMultOverflow; Str: stscDecMathMultOverflowS),
|
||||
(ID: stscDecMathDivOverflow; Str: stscDecMathDivOverflowS),
|
||||
|
||||
(ID: stscTxtDatNoSuchField; Str: stscTxtDatNoSuchFieldS),
|
||||
(ID: stscTxtDatUniqueNameRequired; Str: stscTxtDatUniqueNameRequiredS),
|
||||
(ID: stscTxtDatUnhandledVariant; Str: stscTxtDatUnhandledVariantS),
|
||||
(ID: stscTxtDatInvalidSchema; Str: stscTxtDatInvalidSchemaS),
|
||||
(ID: stscTxtDatRecordSetOpen; Str: stscTxtDatRecordSetOpenS)
|
||||
);
|
||||
|
||||
function SysToolsStr(Index : Integer) : string;
|
||||
|
||||
implementation
|
||||
|
||||
function SysToolsStr(Index : Integer) : string;
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
for i := Low(SysToolsStrArray) to High(SysToolsStrArray) do
|
||||
if SysToolsStrArray[i].ID = Index then
|
||||
Result := SysToolsStrArray[i].Str;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
|
||||
end.
|
||||
382
components/systools/source/run/stcrc.pas
Normal file
382
components/systools/source/run/stcrc.pas
Normal file
@@ -0,0 +1,382 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StCRC.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Cyclic redundancy check unit for SysTools *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$I StDefine.inc}
|
||||
{
|
||||
Note: CRC routines rely on overflows for their results,
|
||||
so these need to be off:
|
||||
}
|
||||
{$R-}
|
||||
{$Q-}
|
||||
|
||||
unit StCRC;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes,
|
||||
StBase;
|
||||
|
||||
const
|
||||
CrcBufSize = 2048;
|
||||
CrcFileMode = fmOpenRead or fmShareDenyWrite;
|
||||
|
||||
function Adler32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
|
||||
function Adler32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
|
||||
function Adler32OfFile(FileName : String) : LongInt;
|
||||
|
||||
function Crc16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
function Crc16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
function Crc16OfFile(FileName : String) : Cardinal;
|
||||
|
||||
function Crc32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
|
||||
function Crc32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
|
||||
function Crc32OfFile(FileName : String) : LongInt;
|
||||
|
||||
function InternetSumPrim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
function InternetSumOfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
function InternetSumOfFile(FileName : String) : Cardinal;
|
||||
|
||||
function Kermit16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
function Kermit16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
function Kermit16OfFile(FileName : String) : Cardinal;
|
||||
|
||||
const
|
||||
{ Cardinal takes more space, but is about 10% faster in 32-bit }
|
||||
CrcTable: array[0..255] of Cardinal = (
|
||||
$0000, $1021, $2042, $3063, $4084, $50a5, $60c6, $70e7,
|
||||
$8108, $9129, $a14a, $b16b, $c18c, $d1ad, $e1ce, $f1ef,
|
||||
$1231, $0210, $3273, $2252, $52b5, $4294, $72f7, $62d6,
|
||||
$9339, $8318, $b37b, $a35a, $d3bd, $c39c, $f3ff, $e3de,
|
||||
$2462, $3443, $0420, $1401, $64e6, $74c7, $44a4, $5485,
|
||||
$a56a, $b54b, $8528, $9509, $e5ee, $f5cf, $c5ac, $d58d,
|
||||
$3653, $2672, $1611, $0630, $76d7, $66f6, $5695, $46b4,
|
||||
$b75b, $a77a, $9719, $8738, $f7df, $e7fe, $d79d, $c7bc,
|
||||
$48c4, $58e5, $6886, $78a7, $0840, $1861, $2802, $3823,
|
||||
$c9cc, $d9ed, $e98e, $f9af, $8948, $9969, $a90a, $b92b,
|
||||
$5af5, $4ad4, $7ab7, $6a96, $1a71, $0a50, $3a33, $2a12,
|
||||
$dbfd, $cbdc, $fbbf, $eb9e, $9b79, $8b58, $bb3b, $ab1a,
|
||||
$6ca6, $7c87, $4ce4, $5cc5, $2c22, $3c03, $0c60, $1c41,
|
||||
$edae, $fd8f, $cdec, $ddcd, $ad2a, $bd0b, $8d68, $9d49,
|
||||
$7e97, $6eb6, $5ed5, $4ef4, $3e13, $2e32, $1e51, $0e70,
|
||||
$ff9f, $efbe, $dfdd, $cffc, $bf1b, $af3a, $9f59, $8f78,
|
||||
$9188, $81a9, $b1ca, $a1eb, $d10c, $c12d, $f14e, $e16f,
|
||||
$1080, $00a1, $30c2, $20e3, $5004, $4025, $7046, $6067,
|
||||
$83b9, $9398, $a3fb, $b3da, $c33d, $d31c, $e37f, $f35e,
|
||||
$02b1, $1290, $22f3, $32d2, $4235, $5214, $6277, $7256,
|
||||
$b5ea, $a5cb, $95a8, $8589, $f56e, $e54f, $d52c, $c50d,
|
||||
$34e2, $24c3, $14a0, $0481, $7466, $6447, $5424, $4405,
|
||||
$a7db, $b7fa, $8799, $97b8, $e75f, $f77e, $c71d, $d73c,
|
||||
$26d3, $36f2, $0691, $16b0, $6657, $7676, $4615, $5634,
|
||||
$d94c, $c96d, $f90e, $e92f, $99c8, $89e9, $b98a, $a9ab,
|
||||
$5844, $4865, $7806, $6827, $18c0, $08e1, $3882, $28a3,
|
||||
$cb7d, $db5c, $eb3f, $fb1e, $8bf9, $9bd8, $abbb, $bb9a,
|
||||
$4a75, $5a54, $6a37, $7a16, $0af1, $1ad0, $2ab3, $3a92,
|
||||
$fd2e, $ed0f, $dd6c, $cd4d, $bdaa, $ad8b, $9de8, $8dc9,
|
||||
$7c26, $6c07, $5c64, $4c45, $3ca2, $2c83, $1ce0, $0cc1,
|
||||
$ef1f, $ff3e, $cf5d, $df7c, $af9b, $bfba, $8fd9, $9ff8,
|
||||
$6e17, $7e36, $4e55, $5e74, $2e93, $3eb2, $0ed1, $1ef0
|
||||
);
|
||||
|
||||
const
|
||||
Crc32Table : array[0..255] of DWORD = (
|
||||
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535,
|
||||
$9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd,
|
||||
$e7b82d07, $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d,
|
||||
$6ddde4eb, $f4d4b551, $83d385c7, $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec,
|
||||
$14015c4f, $63066cd9, $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4,
|
||||
$a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
|
||||
$dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59, $26d930ac,
|
||||
$51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
|
||||
$2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab,
|
||||
$b6662d3d, $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f,
|
||||
$9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb,
|
||||
$086d3d2d, $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
|
||||
$6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, $8bbeb8ea,
|
||||
$fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65, $4db26158, $3ab551ce,
|
||||
$a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a,
|
||||
$346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
|
||||
$5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409,
|
||||
$ce61e49f, $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
|
||||
$b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739,
|
||||
$9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8,
|
||||
$e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, $8708a3d2, $1e01f268,
|
||||
$6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7, $fed41b76, $89d32be0,
|
||||
$10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8,
|
||||
$a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
|
||||
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef,
|
||||
$4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703,
|
||||
$220216b9, $5505262f, $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7,
|
||||
$b5d0cf31, $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, $026d930a,
|
||||
$9c0906a9, $eb0e363f, $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae,
|
||||
$0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
|
||||
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777, $88085ae6,
|
||||
$ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
|
||||
$a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d,
|
||||
$3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5,
|
||||
$47b2cf7f, $30b5ffe9, $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605,
|
||||
$cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
|
||||
$b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
|
||||
);
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF TRIALRUN}
|
||||
uses
|
||||
StTrial;
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
CRCByteArray = array[0..Pred(High(LongInt))] of Byte;
|
||||
|
||||
function Adler32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
|
||||
{ Calculates the Adler 32-bit CRC of a block }
|
||||
var
|
||||
S1, S2, I : LongInt;
|
||||
begin
|
||||
if DataSize > 0 then begin
|
||||
S1 := CurCrc and $FFFF;
|
||||
S2 := (CurCrc shr 16) and $FFFF;
|
||||
|
||||
for I := 0 to (DataSize-1) do begin
|
||||
S1 := (S1 + CRCByteArray(Data)[I]) mod 65521;
|
||||
S2 := (S2 + S1) mod 65521;
|
||||
end;
|
||||
|
||||
Result := (S2 shl 16) + S1;
|
||||
end else
|
||||
Result := CurCrc;
|
||||
end;
|
||||
|
||||
function Adler32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
|
||||
{ Calculates the Adler 32-bit CRC of a stream }
|
||||
var
|
||||
BufArray : array[0..(CrcBufSize-1)] of Byte;
|
||||
Res : LongInt;
|
||||
begin
|
||||
{Initialize Crc}
|
||||
Result := CurCrc;
|
||||
repeat
|
||||
Res := Stream.Read(BufArray, CrcBufSize);
|
||||
Result := Adler32Prim(BufArray, Res, Result);
|
||||
until (Res <> CrcBufSize);
|
||||
end;
|
||||
|
||||
function Adler32OfFile(FileName : String) : LongInt;
|
||||
{ Calculates the Adler 32-bit CRC of a file }
|
||||
var
|
||||
FileSt : TFileStream;
|
||||
begin
|
||||
FileSt := TFileStream.Create(FileName, CrcFileMode);
|
||||
try
|
||||
Result := Adler32OfStream(FileSt, 1);
|
||||
finally
|
||||
FileSt.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function Crc16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the 16-bit CRC of a block }
|
||||
var
|
||||
I : Integer;
|
||||
begin
|
||||
Result := CurCrc;
|
||||
for I := 0 to (DataSize-1) do
|
||||
Result := (CrcTable[((Result shr 8) and 255)] xor (Result shl 8) xor
|
||||
CRCByteArray(Data)[I]) and $FFFF;
|
||||
end;
|
||||
|
||||
function Crc16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the 16-bit CRC of a stream }
|
||||
var
|
||||
BufArray : array[0..(CrcBufSize-1)] of Byte;
|
||||
Res : LongInt;
|
||||
begin
|
||||
{Initialize Crc}
|
||||
Result := CurCrc;
|
||||
repeat
|
||||
Res := Stream.Read(BufArray, CrcBufSize);
|
||||
Result := Crc16Prim(BufArray, Res, Result);
|
||||
until (Res <> CrcBufSize);
|
||||
end;
|
||||
|
||||
function Crc16OfFile(FileName : String) : Cardinal;
|
||||
{ Calculates the 16-bit CRC of a file }
|
||||
var
|
||||
FileSt : TFileStream;
|
||||
begin
|
||||
FileSt := TFileStream.Create(FileName, CrcFileMode);
|
||||
try
|
||||
Result := Crc16OfStream(FileSt, 0);
|
||||
finally
|
||||
FileSt.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function Crc32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
|
||||
{ Calculates the 32-bit CRC of a block }
|
||||
var
|
||||
I : Integer;
|
||||
begin
|
||||
Result := CurCrc;
|
||||
for I := 0 to (DataSize-1) do
|
||||
Result := Crc32Table[Byte(Result xor CRCByteArray(Data)[I])] xor
|
||||
DWord((Result shr 8) and $00FFFFFF);
|
||||
end;
|
||||
|
||||
function Crc32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
|
||||
{ Calculates the 32-bit CRC of a stream }
|
||||
var
|
||||
BufArray : array[0..(CrcBufSize-1)] of Byte;
|
||||
Res : LongInt;
|
||||
begin
|
||||
{Initialize Crc}
|
||||
Result := CurCrc;
|
||||
repeat
|
||||
Res := Stream.Read(BufArray, CrcBufSize);
|
||||
Result := Crc32Prim(BufArray, Res, Result);
|
||||
until (Res <> CrcBufSize);
|
||||
end;
|
||||
|
||||
function Crc32OfFile(FileName : String) : LongInt;
|
||||
{ Calculates the 32-bit CRC of a file }
|
||||
var
|
||||
FileSt : TFileStream;
|
||||
begin
|
||||
FileSt := TFileStream.Create(FileName, CrcFileMode);
|
||||
try
|
||||
Result := not Crc32OfStream(FileSt, LongInt($FFFFFFFF));
|
||||
finally
|
||||
FileSt.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function InternetSumPrim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the Internet Checksum of a block }
|
||||
var
|
||||
I : Integer;
|
||||
begin
|
||||
Result := CurCrc;
|
||||
if DataSize = 0 then Exit;
|
||||
for I := 0 to (DataSize - 1) do begin
|
||||
if Odd(I) then
|
||||
Result := Result + (CRCByteArray(Data)[I] shl 8)
|
||||
else
|
||||
Result := Result + CRCByteArray(Data)[I];
|
||||
end;
|
||||
Result := (not((Result and $FFFF) + (Result shr 16))) and $FFFF;
|
||||
end;
|
||||
|
||||
function InternetSumOfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the Internet Checksum of a stream }
|
||||
var
|
||||
BufArray : array[0..(CrcBufSize-1)] of Byte;
|
||||
Res : LongInt;
|
||||
begin
|
||||
{Initialize Crc}
|
||||
Result := CurCrc;
|
||||
repeat
|
||||
Res := Stream.Read(BufArray, CrcBufSize);
|
||||
Result := InternetSumPrim(BufArray, Res, Result);
|
||||
until (Res <> CrcBufSize);
|
||||
end;
|
||||
|
||||
function InternetSumOfFile(FileName : String) : Cardinal;
|
||||
{ Calculates the Internet Checksum of a file }
|
||||
var
|
||||
FileSt : TFileStream;
|
||||
begin
|
||||
FileSt := TFileStream.Create(FileName, CrcFileMode);
|
||||
try
|
||||
Result := InternetSumOfStream(FileSt, 0);
|
||||
finally
|
||||
FileSt.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function Kermit16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the Kermit 16-bit CRC of a block }
|
||||
var
|
||||
I, J : Integer;
|
||||
Temp : Cardinal;
|
||||
CurrByte : Byte;
|
||||
begin
|
||||
for I := 0 to (DataSize-1) do begin
|
||||
CurrByte := CRCByteArray(Data)[I];
|
||||
for J := 0 to 7 do begin
|
||||
Temp := CurCrc xor CurrByte;
|
||||
CurCrc := CurCrc shr 1;
|
||||
if Odd(Temp) then
|
||||
CurCrc := CurCrc xor $8408;
|
||||
CurrByte := CurrByte shr 1;
|
||||
end;
|
||||
end;
|
||||
Result := CurCrc;
|
||||
end;
|
||||
|
||||
function Kermit16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
|
||||
{ Calculates the Kermit 16-bit CRC of a stream }
|
||||
var
|
||||
BufArray : array[0..(CrcBufSize-1)] of Byte;
|
||||
Res : LongInt;
|
||||
begin
|
||||
{Initialize Crc}
|
||||
Result := CurCrc;
|
||||
repeat
|
||||
Res := Stream.Read(BufArray, CrcBufSize);
|
||||
Result := Kermit16Prim(BufArray, Res, Result);
|
||||
until (Res <> CrcBufSize);
|
||||
end;
|
||||
|
||||
function Kermit16OfFile(FileName : String) : Cardinal;
|
||||
{ Calculates the Kermit 16-bit CRC of a file }
|
||||
var
|
||||
FileSt : TFileStream;
|
||||
begin
|
||||
FileSt := TFileStream.Create(FileName, CrcFileMode);
|
||||
try
|
||||
Result := Kermit16OfStream(FileSt, 0);
|
||||
finally
|
||||
FileSt.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
965
components/systools/source/run/stdate.pas
Normal file
965
components/systools/source/run/stdate.pas
Normal file
@@ -0,0 +1,965 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StDate.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Date and time manipulation *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
//{$I StDefine.inc}
|
||||
|
||||
{For BCB 3.0 package support.}
|
||||
{$IFDEF VER110}
|
||||
{$ObjExportAll On}
|
||||
{$ENDIF}
|
||||
|
||||
unit StDate;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils;
|
||||
|
||||
type
|
||||
TStDate = LongInt;
|
||||
{In STDATE, dates are stored in long integer format as the number of days
|
||||
since January 1, 1600}
|
||||
|
||||
TDateArray = array[0..(MaxLongInt div SizeOf(TStDate))-1] of TStDate;
|
||||
{Type for StDate open array}
|
||||
|
||||
TStDayType = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
|
||||
{An enumerated type used when representing a day of the week}
|
||||
|
||||
TStBondDateType = (bdtActual, bdt30E360, bdt30360, bdt30360psa);
|
||||
{An enumerated type used for calculating bond date differences}
|
||||
|
||||
TStTime = LongInt;
|
||||
{STDATE handles time in a manner similar to dates, representing a given
|
||||
time of day as the number of seconds since midnight}
|
||||
|
||||
TStDateTimeRec =
|
||||
record
|
||||
{This record type simply combines the two basic date types defined by
|
||||
STDATE, Date and Time}
|
||||
D : TStDate;
|
||||
T : TStTime;
|
||||
end;
|
||||
|
||||
const
|
||||
MinYear = 1600; {Minimum valid year for a date variable}
|
||||
MaxYear = 3999; {Maximum valid year for a date variable}
|
||||
Mindate = $00000000; {Minimum valid date for a date variable - 01/01/1600}
|
||||
Maxdate = $000D6025; {Maximum valid date for a date variable - 12/31/3999}
|
||||
Date1900 : longint = $0001AC05; {Julian date for 01/01/1900}
|
||||
Date1970 : longint = $00020FE4; {Julian date for 01/01/1970}
|
||||
Date1980 : longint = $00021E28; {Julian date for 01/01/1980}
|
||||
Date2000 : longint = $00023AB1; {Julian date for 01/01/2000}
|
||||
Days400Yr : longint = 146097; {days in 400 years}
|
||||
{This value is used to represent an invalid date, such as 12/32/1992}
|
||||
BadDate = LongInt($FFFFFFFF);
|
||||
|
||||
DeltaJD = $00232DA8; {Days between 1/1/-4173 and 1/1/1600}
|
||||
|
||||
MinTime = 0; {Minimum valid time for a time variable - 00:00:00 am}
|
||||
MaxTime = 86399; {Maximum valid time for a time variable - 23:59:59 pm}
|
||||
{This value is used to represent an invalid time of day, such as 12:61:00}
|
||||
BadTime = LongInt($FFFFFFFF);
|
||||
SecondsInDay = 86400; {Number of seconds in a day}
|
||||
SecondsInHour = 3600; {Number of seconds in an hour}
|
||||
SecondsInMinute = 60; {Number of seconds in a minute}
|
||||
HoursInDay = 24; {Number of hours in a day}
|
||||
MinutesInHour = 60; {Number of minutes in an hour}
|
||||
MinutesInDay = 1440; {Number of minutes in a day}
|
||||
|
||||
var
|
||||
DefaultYear : Integer; {default year--used by DateStringToDMY}
|
||||
DefaultMonth : ShortInt; {default month}
|
||||
|
||||
{-------julian date routines---------------}
|
||||
|
||||
function CurrentDate : TStDate;
|
||||
{-returns today's date as a Julian date}
|
||||
|
||||
function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean;
|
||||
{-Verify that day, month, year is a valid date}
|
||||
|
||||
function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate;
|
||||
{-Convert from day, month, year to a Julian date}
|
||||
|
||||
procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer);
|
||||
{-Convert from a Julian date to day, month, year}
|
||||
|
||||
function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate;
|
||||
{-Add (or subtract) the number of days, months, and years to a date}
|
||||
|
||||
function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate;
|
||||
{-Add (or subtract) the specified number of months and years to a date}
|
||||
|
||||
procedure DateDiff(Date1, Date2 : TStDate;
|
||||
var Days, Months, Years : Integer);
|
||||
{-Return the difference in days, months, and years between two valid Julian
|
||||
dates}
|
||||
|
||||
function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate;
|
||||
{-Return the difference in days between two valid Julian
|
||||
dates using a specific financial basis}
|
||||
|
||||
function WeekOfYear(Julian : TStDate) : Byte;
|
||||
{-Returns the week number of the year given the Julian Date}
|
||||
|
||||
function AstJulianDate(Julian : TStDate) : Double;
|
||||
{-Returns the Astronomical Julian Date from a TStDate}
|
||||
|
||||
function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate;
|
||||
{-Returns a TStDate from an Astronomical Julian Date.
|
||||
Truncate TRUE Converts to appropriate 0 hours then truncates
|
||||
FALSE Converts to appropriate 0 hours, then rounds to
|
||||
nearest;}
|
||||
|
||||
function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double;
|
||||
{-Returns an Astronomical Julian Date for any year, even those outside
|
||||
MinYear..MaxYear}
|
||||
|
||||
function DayOfWeek(Julian : TStDate) : TStDayType;
|
||||
{-Return the day of the week for a Julian date}
|
||||
|
||||
function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType;
|
||||
{-Return the day of the week for the day, month, year}
|
||||
|
||||
function IsLeapYear(Year : Integer) : Boolean;
|
||||
{-Return True if Year is a leap year}
|
||||
|
||||
function DaysInMonth(Month : Integer; Year, Epoch : Integer) : Integer;
|
||||
{-Return the number of days in the specified month of a given year}
|
||||
|
||||
function ResolveEpoch(Year, Epoch : Integer) : Integer;
|
||||
{-Convert 2 digit year to 4 digit year according to Epoch}
|
||||
|
||||
|
||||
{-------time routines---------------}
|
||||
|
||||
function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean;
|
||||
{-Return True if Hours:Minutes:Seconds is a valid time}
|
||||
|
||||
procedure StTimeToHMS(T : TStTime;
|
||||
var Hours, Minutes, Seconds : Byte);
|
||||
{-Convert a time variable to hours, minutes, seconds}
|
||||
|
||||
function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Convert hours, minutes, seconds to a time variable}
|
||||
|
||||
function CurrentTime : TStTime;
|
||||
{-Return the current time in seconds since midnight}
|
||||
|
||||
procedure TimeDiff(Time1, Time2 : TStTime;
|
||||
var Hours, Minutes, Seconds : Byte);
|
||||
{-Return the difference in hours, minutes, and seconds between two times}
|
||||
|
||||
function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Add the specified hours, minutes, and seconds to a given time of day}
|
||||
|
||||
function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Subtract the specified hours, minutes, and seconds from a given time of day}
|
||||
|
||||
function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime;
|
||||
{-Given a time, round it to the nearest hour, or truncate minutes and
|
||||
seconds}
|
||||
|
||||
function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime;
|
||||
{-Given a time, round it to the nearest minute, or truncate seconds}
|
||||
|
||||
{-------- routines for DateTimeRec records ---------}
|
||||
|
||||
procedure DateTimeDiff(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
|
||||
var Days : LongInt; var Secs : LongInt);
|
||||
{-Return the difference in days and seconds between two points in time}
|
||||
|
||||
procedure IncDateTime(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
|
||||
Days : Integer; Secs : LongInt);
|
||||
{-Increment (or decrement) a date and time by the specified number of days
|
||||
and seconds}
|
||||
|
||||
function DateTimeToStDate(DT : TDateTime) : TStDate;
|
||||
{-Convert Delphi TDateTime to TStDate}
|
||||
|
||||
function DateTimeToStTime(DT : TDateTime) : TStTime;
|
||||
{-Convert Delphi TDateTime to TStTime}
|
||||
|
||||
function StDateToDateTime(D : TStDate) : TDateTime;
|
||||
{-Convert TStDate to TDateTime}
|
||||
|
||||
function StTimeToDateTime(T : TStTime) : TDateTime;
|
||||
{-Convert TStTime to TDateTime}
|
||||
|
||||
function Convert2ByteDate(TwoByteDate : Word) : TStDate;
|
||||
{-Convert an Object Professional two byte date into a SysTools date}
|
||||
|
||||
function Convert4ByteDate(FourByteDate : TStDate) : Word;
|
||||
{-Convert a SysTools date into an Object Professional two byte date}
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
First2Months = 59; {1600 was a leap year}
|
||||
FirstDayOfWeek = Saturday; {01/01/1600 was a Saturday}
|
||||
DateLen = 40; {maximum length of Picture strings}
|
||||
MaxMonthName = 15;
|
||||
MaxDayName = 15;
|
||||
|
||||
|
||||
//type
|
||||
{ DateString = string[DateLen];}
|
||||
// SString = string[255];
|
||||
|
||||
function IsLeapYear(Year : Integer) : Boolean;
|
||||
{-Return True if Year is a leap year}
|
||||
begin
|
||||
Result := (Year mod 4 = 0) and (Year mod 4000 <> 0) and
|
||||
((Year mod 100 <> 0) or (Year mod 400 = 0));
|
||||
end;
|
||||
|
||||
function IsLastDayofMonth(Day, Month, Year : Integer) : Boolean;
|
||||
{-Return True if date is the last day in month}
|
||||
var
|
||||
Epoch : Integer;
|
||||
begin
|
||||
Epoch := (Year div 100) * 100;
|
||||
if ValidDate(Day + 1, Month, Year, Epoch) then
|
||||
Result := false
|
||||
else
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
function IsLastDayofFeb(Date : TStDate) : Boolean;
|
||||
{-Return True if date is the last day in February}
|
||||
var
|
||||
Day, Month, Year : Integer;
|
||||
begin
|
||||
StDateToDMY(Date, Day, Month, Year);
|
||||
if (Month = 2) and IsLastDayOfMonth(Day, Month, Year) then
|
||||
Result := true
|
||||
else
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
procedure ExchangeLongInts(var I, J : LongInt);
|
||||
register;
|
||||
asm
|
||||
mov ecx, [eax]
|
||||
push ecx
|
||||
mov ecx, [edx]
|
||||
mov [eax], ecx
|
||||
pop ecx
|
||||
mov [edx], ecx
|
||||
end;
|
||||
|
||||
procedure ExchangeStructs(var I, J; Size : Cardinal);
|
||||
register;
|
||||
asm
|
||||
push edi
|
||||
push ebx
|
||||
push ecx
|
||||
shr ecx, 2
|
||||
jz @@LessThanFour
|
||||
|
||||
@@AgainDWords:
|
||||
mov ebx, [eax]
|
||||
mov edi, [edx]
|
||||
mov [edx], ebx
|
||||
mov [eax], edi
|
||||
add eax, 4
|
||||
add edx, 4
|
||||
dec ecx
|
||||
jnz @@AgainDWords
|
||||
|
||||
@@LessThanFour:
|
||||
pop ecx
|
||||
and ecx, $3
|
||||
jz @@Done
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
inc eax
|
||||
inc edx
|
||||
dec ecx
|
||||
jz @@Done
|
||||
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
inc eax
|
||||
inc edx
|
||||
dec ecx
|
||||
jz @@Done
|
||||
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
|
||||
@@Done:
|
||||
pop ebx
|
||||
pop edi
|
||||
end;
|
||||
|
||||
|
||||
function ResolveEpoch(Year, Epoch : Integer) : Integer;
|
||||
{-Convert 2-digit year to 4-digit year according to Epoch}
|
||||
var
|
||||
EpochYear,
|
||||
EpochCent : Integer;
|
||||
begin
|
||||
if Word(Year) < 100 then begin
|
||||
EpochYear := Epoch mod 100;
|
||||
EpochCent := (Epoch div 100) * 100;
|
||||
if (Year < EpochYear) then
|
||||
Inc(Year,EpochCent+100)
|
||||
else
|
||||
Inc(Year,EpochCent);
|
||||
end;
|
||||
Result := Year;
|
||||
end;
|
||||
|
||||
function CurrentDate : TStDate;
|
||||
{-Returns today's date as a julian}
|
||||
var
|
||||
Year, Month, Date : Word;
|
||||
begin
|
||||
DecodeDate(Now,Year,Month,Date);
|
||||
Result := DMYToStDate(Date,Month,Year,0);
|
||||
end;
|
||||
|
||||
function DaysInMonth(Month : integer; Year, Epoch : Integer) : Integer;
|
||||
{-Return the number of days in the specified month of a given year}
|
||||
begin
|
||||
Year := ResolveEpoch(Year, Epoch);
|
||||
|
||||
if (Year < MinYear) OR (Year > MaxYear) then
|
||||
begin
|
||||
Result := 0;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
case Month of
|
||||
1, 3, 5, 7, 8, 10, 12 :
|
||||
Result := 31;
|
||||
4, 6, 9, 11 :
|
||||
Result := 30;
|
||||
2 :
|
||||
Result := 28+Ord(IsLeapYear(Year));
|
||||
else
|
||||
Result := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean;
|
||||
{-Verify that day, month, year is a valid date}
|
||||
begin
|
||||
Year := ResolveEpoch(Year, Epoch);
|
||||
|
||||
if (Day < 1) or (Year < MinYear) or (Year > MaxYear) then
|
||||
Result := False
|
||||
else case Month of
|
||||
1..12 :
|
||||
Result := Day <= DaysInMonth(Month, Year, Epoch);
|
||||
else
|
||||
Result := False;
|
||||
end
|
||||
end;
|
||||
|
||||
function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate;
|
||||
{-Convert from day, month, year to a julian date}
|
||||
begin
|
||||
Year := ResolveEpoch(Year, Epoch);
|
||||
|
||||
if not ValidDate(Day, Month, Year, Epoch) then
|
||||
Result := BadDate
|
||||
else if (Year = MinYear) and (Month < 3) then
|
||||
if Month = 1 then
|
||||
Result := Pred(Day)
|
||||
else
|
||||
Result := Day+30
|
||||
else begin
|
||||
if Month > 2 then
|
||||
Dec(Month, 3)
|
||||
else begin
|
||||
Inc(Month, 9);
|
||||
Dec(Year);
|
||||
end;
|
||||
Dec(Year, MinYear);
|
||||
Result :=
|
||||
((LongInt(Year div 100)*Days400Yr) div 4)+
|
||||
((LongInt(Year mod 100)*1461) div 4)+
|
||||
(((153*Month)+2) div 5)+Day+First2Months;
|
||||
end;
|
||||
end;
|
||||
|
||||
function WeekOfYear(Julian : TStDate) : Byte;
|
||||
{-Returns the week number of the year given the Julian Date}
|
||||
var
|
||||
Day, Month, Year : Integer;
|
||||
FirstJulian : TStDate;
|
||||
begin
|
||||
if (Julian < MinDate) or (Julian > MaxDate) then
|
||||
begin
|
||||
Result := 0;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Julian := Julian + 3 - ((6 + Ord(DayOfWeek(Julian))) mod 7);
|
||||
StDateToDMY(Julian,Day,Month,Year);
|
||||
FirstJulian := DMYToStDate(1,1,Year,0);
|
||||
Result := 1 + (Julian - FirstJulian) div 7;
|
||||
end;
|
||||
|
||||
function AstJulianDate(Julian : TStDate) : Double;
|
||||
{-Returns the Astronomical Julian Date from a TStDate}
|
||||
begin
|
||||
{Subtract 0.5d since Astronomical JD starts at noon
|
||||
while TStDate (with implied .0) starts at midnight}
|
||||
Result := Julian - 0.5 + DeltaJD;
|
||||
end;
|
||||
|
||||
|
||||
function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double;
|
||||
var
|
||||
A, B : integer;
|
||||
LY,
|
||||
GC : Boolean;
|
||||
|
||||
begin
|
||||
Result := -MaxLongInt;
|
||||
if (not (Month in [1..12])) or (Date < 1) then
|
||||
Exit
|
||||
else if (Month in [1, 3, 5, 7, 8, 10, 12]) and (Date > 31) then
|
||||
Exit
|
||||
else if (Month in [4, 6, 9, 11]) and (Date > 30) then
|
||||
Exit
|
||||
else if (Month = 2) then begin
|
||||
LY := IsLeapYear(Year);
|
||||
if ((LY) and (Date > 29)) or (not (LY) and (Date > 28)) then
|
||||
Exit;
|
||||
end else if ((UT < 0) or (UT >= SecondsInDay)) then
|
||||
Exit;
|
||||
|
||||
if (Month <= 2) then begin
|
||||
Year := Year - 1;
|
||||
Month := Month + 12;
|
||||
end;
|
||||
A := abs(Year div 100);
|
||||
|
||||
if (Year > 1582) then
|
||||
GC := True
|
||||
else if (Year = 1582) then begin
|
||||
if (Month > 10) then
|
||||
GC := True
|
||||
else if (Month < 10) then
|
||||
GC := False
|
||||
else begin
|
||||
if (Date >= 15) then
|
||||
GC := True
|
||||
else
|
||||
GC := False;
|
||||
end;
|
||||
end else
|
||||
GC := False;
|
||||
if (GC) then
|
||||
B := 2 - A + abs(A div 4)
|
||||
else
|
||||
B := 0;
|
||||
|
||||
Result := Trunc(365.25 * (Year + 4716))
|
||||
+ Trunc(30.6001 * (Month + 1))
|
||||
+ Date + B - 1524.5
|
||||
+ UT / SecondsInDay;
|
||||
end;
|
||||
|
||||
|
||||
function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate;
|
||||
{-Returns a TStDate from an Astronomical Julian Date.
|
||||
Truncate TRUE Converts to appropriate 0 hours then truncates
|
||||
FALSE Converts to appropriate 0 hours, then rounds to
|
||||
nearest;}
|
||||
begin
|
||||
{Convert to TStDate, adding 0.5d for implied .0d of TStDate}
|
||||
AstJulian := AstJulian + 0.5 - DeltaJD;
|
||||
if (AstJulian < MinDate) OR (AstJulian > MaxDate) then
|
||||
begin
|
||||
Result := BadDate;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if Truncate then
|
||||
Result := Trunc(AstJulian)
|
||||
else
|
||||
Result := Trunc(AstJulian + 0.5);
|
||||
end;
|
||||
|
||||
procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer);
|
||||
{-Convert from a julian date to month, day, year}
|
||||
var
|
||||
I, J : LongInt;
|
||||
begin
|
||||
if Julian = BadDate then begin
|
||||
Day := 0;
|
||||
Month := 0;
|
||||
Year := 0;
|
||||
end else if Julian <= First2Months then begin
|
||||
Year := MinYear;
|
||||
if Julian <= 30 then begin
|
||||
Month := 1;
|
||||
Day := Succ(Julian);
|
||||
end else begin
|
||||
Month := 2;
|
||||
Day := Julian-30;
|
||||
end;
|
||||
end else begin
|
||||
I := (4*LongInt(Julian-First2Months))-1;
|
||||
|
||||
J := (4*((I mod Days400Yr) div 4))+3;
|
||||
Year := (100*(I div Days400Yr))+(J div 1461);
|
||||
I := (5*(((J mod 1461)+4) div 4))-3;
|
||||
Day := ((I mod 153)+5) div 5;
|
||||
|
||||
Month := I div 153;
|
||||
if Month < 10 then
|
||||
Inc(Month, 3)
|
||||
else begin
|
||||
Dec(Month, 9);
|
||||
Inc(Year);
|
||||
end;
|
||||
Inc(Year, MinYear);
|
||||
end;
|
||||
end;
|
||||
|
||||
function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate;
|
||||
{-Add (or subtract) the number of months, days, and years to a date.
|
||||
Months and years are added before days. No overflow/underflow
|
||||
checks are made}
|
||||
var
|
||||
Day, Month, Year, Day28Delta : Integer;
|
||||
begin
|
||||
StDateToDMY(Julian, Day, Month, Year);
|
||||
Day28Delta := Day-28;
|
||||
if Day28Delta < 0 then
|
||||
Day28Delta := 0
|
||||
else
|
||||
Day := 28;
|
||||
|
||||
Inc(Year, Years);
|
||||
Inc(Year, Months div 12);
|
||||
Inc(Month, Months mod 12);
|
||||
if Month < 1 then begin
|
||||
Inc(Month, 12);
|
||||
Dec(Year);
|
||||
end
|
||||
else if Month > 12 then begin
|
||||
Dec(Month, 12);
|
||||
Inc(Year);
|
||||
end;
|
||||
|
||||
Julian := DMYtoStDate(Day, Month, Year,0);
|
||||
if Julian <> BadDate then begin
|
||||
Inc(Julian, Days);
|
||||
Inc(Julian, Day28Delta);
|
||||
end;
|
||||
Result := Julian;
|
||||
end;
|
||||
|
||||
function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate;
|
||||
{-Add (or subtract) the specified number of months and years to a date}
|
||||
var
|
||||
Day, Month, Year : Integer;
|
||||
MaxDay, Day28Delta : Integer;
|
||||
begin
|
||||
StDateToDMY(Julian, Day, Month, Year);
|
||||
Day28Delta := Day-28;
|
||||
if Day28Delta < 0 then
|
||||
Day28Delta := 0
|
||||
else
|
||||
Day := 28;
|
||||
|
||||
Inc(Year, Years);
|
||||
Inc(Year, Months div 12);
|
||||
Inc(Month, Months mod 12);
|
||||
if Month < 1 then begin
|
||||
Inc(Month, 12);
|
||||
Dec(Year);
|
||||
end
|
||||
else if Month > 12 then begin
|
||||
Dec(Month, 12);
|
||||
Inc(Year);
|
||||
end;
|
||||
|
||||
Julian := DMYtoStDate(Day, Month, Year,0);
|
||||
if Julian <> BadDate then begin
|
||||
MaxDay := DaysInMonth(Month, Year,0);
|
||||
if Day+Day28Delta > MaxDay then
|
||||
Inc(Julian, MaxDay-Day)
|
||||
else
|
||||
Inc(Julian, Day28Delta);
|
||||
end;
|
||||
Result := Julian;
|
||||
end;
|
||||
|
||||
procedure DateDiff(Date1, Date2 : TStDate; var Days, Months, Years : Integer);
|
||||
{-Return the difference in days,months,years between two valid julian dates}
|
||||
var
|
||||
Day1, Day2, Month1, Month2, Year1, Year2 : Integer;
|
||||
begin
|
||||
{we want Date2 > Date1}
|
||||
if Date1 > Date2 then
|
||||
ExchangeLongInts(Date1, Date2);
|
||||
|
||||
{convert dates to day,month,year}
|
||||
StDateToDMY(Date1, Day1, Month1, Year1);
|
||||
StDateToDMY(Date2, Day2, Month2, Year2);
|
||||
|
||||
{days first}
|
||||
if (Day1 = DaysInMonth(Month1, Year1, 0)) then begin
|
||||
Day1 := 0;
|
||||
Inc(Month1); {OK if Month1 > 12}
|
||||
end;
|
||||
if (Day2 = DaysInMonth(Month2, Year2, 0)) then begin
|
||||
Day2 := 0;
|
||||
Inc(Month2); {OK if Month2 > 12}
|
||||
end;
|
||||
if (Day2 < Day1) then begin
|
||||
Dec(Month2);
|
||||
if Month2 = 0 then begin
|
||||
Month2 := 12;
|
||||
Dec(Year2);
|
||||
end;
|
||||
Days := Day2 + DaysInMonth(Month2, Year2, 0) - Day1; {!!.02}
|
||||
end else
|
||||
Days := Day2-Day1;
|
||||
|
||||
{now months and years}
|
||||
if Month2 < Month1 then begin
|
||||
Inc(Month2, 12);
|
||||
Dec(Year2);
|
||||
end;
|
||||
Months := Month2-Month1;
|
||||
Years := Year2-Year1;
|
||||
end;
|
||||
|
||||
function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate;
|
||||
{-Return the difference in days between two valid Julian
|
||||
dates using one a specific accrual method}
|
||||
var
|
||||
Day1,
|
||||
Month1,
|
||||
Year1,
|
||||
Day2,
|
||||
Month2,
|
||||
Year2 : Integer;
|
||||
IY : LongInt;
|
||||
begin
|
||||
{we want Date2 > Date1}
|
||||
if Date1 > Date2 then
|
||||
ExchangeLongInts(Date1, Date2);
|
||||
|
||||
if (DayBasis = bdtActual) then
|
||||
Result := Date2-Date1
|
||||
else
|
||||
begin
|
||||
StDateToDMY(Date1, Day1, Month1, Year1);
|
||||
StDateToDMY(Date2, Day2, Month2, Year2);
|
||||
|
||||
if ((DayBasis = bdt30360PSA) and IsLastDayofFeb(Date1)) or (Day1 = 31) then
|
||||
Day1 := 30;
|
||||
if (DayBasis = bdt30E360) then
|
||||
begin
|
||||
if (Day2 = 31) then
|
||||
Day2 := 30
|
||||
end else
|
||||
if (Day2 = 31) and (Day1 >= 30) then
|
||||
Day2 := 30;
|
||||
|
||||
IY := 360 * (Year2 - Year1);
|
||||
Result := IY + 30 * (Month2 - Month1) + (Day2 - Day1);
|
||||
end;
|
||||
end;
|
||||
|
||||
function DayOfWeek(Julian : TStDate) : TStDayType;
|
||||
{-Return the day of the week for the date. Returns TStDayType(7) if Julian =
|
||||
BadDate.}
|
||||
var
|
||||
B : Byte;
|
||||
begin
|
||||
if Julian = BadDate then begin
|
||||
B := 7;
|
||||
Result := TStDayType(B);
|
||||
end else
|
||||
Result := TStDayType( (Julian+Ord(FirstDayOfWeek)) mod 7 );
|
||||
end;
|
||||
|
||||
function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType;
|
||||
{-Return the day of the week for the day, month, year}
|
||||
begin
|
||||
Result := DayOfWeek( DMYtoStDate(Day, Month, Year, Epoch) );
|
||||
end;
|
||||
|
||||
procedure StTimeToHMS(T : TStTime; var Hours, Minutes, Seconds : Byte);
|
||||
{-Convert a Time variable to Hours, Minutes, Seconds}
|
||||
begin
|
||||
if T = BadTime then begin
|
||||
Hours := 0;
|
||||
Minutes := 0;
|
||||
Seconds := 0;
|
||||
end
|
||||
else begin
|
||||
Hours := T div SecondsInHour;
|
||||
Dec(T, LongInt(Hours)*SecondsInHour);
|
||||
Minutes := T div SecondsInMinute;
|
||||
Dec(T, LongInt(Minutes)*SecondsInMinute);
|
||||
Seconds := T;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Convert Hours, Minutes, Seconds to a Time variable}
|
||||
var
|
||||
T : TStTime;
|
||||
begin
|
||||
Hours := Hours mod HoursInDay;
|
||||
T := (LongInt(Hours)*SecondsInHour)+(LongInt(Minutes)*SecondsInMinute)+Seconds;
|
||||
Result := T mod SecondsInDay;
|
||||
end;
|
||||
|
||||
function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean;
|
||||
{-Return true if Hours:Minutes:Seconds is a valid time}
|
||||
begin
|
||||
if (Hours < 0) or (Hours > 23) or
|
||||
(Minutes < 0) or (Minutes >= 60) or
|
||||
(Seconds < 0) or (Seconds >= 60) then
|
||||
Result := False
|
||||
else
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function CurrentTime : TStTime;
|
||||
{-Returns current time in seconds since midnight}
|
||||
begin
|
||||
Result := Trunc(SysUtils.Time * SecondsInDay);
|
||||
end;
|
||||
|
||||
procedure TimeDiff(Time1, Time2 : TStTime; var Hours, Minutes, Seconds : Byte);
|
||||
{-Return the difference in hours,minutes,seconds between two times}
|
||||
begin
|
||||
StTimeToHMS(Abs(Time1-Time2), Hours, Minutes, Seconds);
|
||||
end;
|
||||
|
||||
function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Add the specified hours,minutes,seconds to T and return the result}
|
||||
begin
|
||||
Inc(T, HMStoStTime(Hours, Minutes, Seconds));
|
||||
Result := T mod SecondsInDay;
|
||||
end;
|
||||
|
||||
function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
|
||||
{-Subtract the specified hours,minutes,seconds from T and return the result}
|
||||
begin
|
||||
Hours := Hours mod HoursInDay;
|
||||
Dec(T, HMStoStTime(Hours, Minutes, Seconds));
|
||||
if T < 0 then
|
||||
Result := T+SecondsInDay
|
||||
else
|
||||
Result := T;
|
||||
end;
|
||||
|
||||
function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime;
|
||||
{-Round T to the nearest hour, or Truncate minutes and seconds from T}
|
||||
var
|
||||
Hours, Minutes, Seconds : Byte;
|
||||
begin
|
||||
StTimeToHMS(T, Hours, Minutes, Seconds);
|
||||
Seconds := 0;
|
||||
if not Truncate then
|
||||
if Minutes >= (MinutesInHour div 2) then
|
||||
Inc(Hours);
|
||||
Minutes := 0;
|
||||
Result := HMStoStTime(Hours, Minutes, Seconds);
|
||||
end;
|
||||
|
||||
function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime;
|
||||
{-Round T to the nearest minute, or Truncate seconds from T}
|
||||
var
|
||||
Hours, Minutes, Seconds : Byte;
|
||||
begin
|
||||
StTimeToHMS(T, Hours, Minutes, Seconds);
|
||||
if not Truncate then
|
||||
if Seconds >= (SecondsInMinute div 2) then
|
||||
Inc(Minutes);
|
||||
Seconds := 0;
|
||||
Result := HMStoStTime(Hours, Minutes, Seconds);
|
||||
end;
|
||||
|
||||
|
||||
procedure DateTimeDiff(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
|
||||
var Days : LongInt; var Secs : LongInt);
|
||||
{-Return the difference in days and seconds between two points in time}
|
||||
var
|
||||
tDT1, tDT2 : TStDateTimeRec;
|
||||
begin
|
||||
tDT1 := DT1;
|
||||
tDT2 := DT2;
|
||||
{swap if tDT1 later than tDT2}
|
||||
if (tDT1.D > tDT2.D) or ((tDT1.D = tDT2.D) and (tDT1.T > tDT2.T)) then
|
||||
ExchangeStructs(tDT1, tDT2,sizeof(TStDateTimeRec));
|
||||
|
||||
{the difference in days is easy}
|
||||
Days := tDT2.D-tDT1.D;
|
||||
|
||||
{difference in seconds}
|
||||
if tDT2.T < tDT1.T then begin
|
||||
{subtract one day, add 24 hours}
|
||||
Dec(Days);
|
||||
Inc(tDT2.T, SecondsInDay);
|
||||
end;
|
||||
Secs := tDT2.T-tDT1.T;
|
||||
end;
|
||||
|
||||
function DateTimeToStDate(DT : TDateTime) : TStDate;
|
||||
{-Convert Delphi TDateTime to TStDate}
|
||||
var
|
||||
Day, Month, Year : Word;
|
||||
begin
|
||||
DecodeDate(DT, Year, Month, Day);
|
||||
Result := DMYToStDate(Day, Month, Year, 0);
|
||||
end;
|
||||
|
||||
function DateTimeToStTime(DT : TDateTime) : TStTime;
|
||||
{-Convert Delphi TDateTime to TStTime}
|
||||
var
|
||||
Hour, Min, Sec, MSec : Word;
|
||||
begin
|
||||
DecodeTime(DT, Hour, Min, Sec, MSec);
|
||||
Result := HMSToStTime(Hour, Min, Sec);
|
||||
end;
|
||||
|
||||
function StDateToDateTime(D : TStDate) : TDateTime;
|
||||
{-Convert TStDate to TDateTime}
|
||||
var
|
||||
Day, Month, Year : Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
if D <> BadDate then begin
|
||||
StDateToDMY(D, Day, Month, Year);
|
||||
Result := EncodeDate(Year, Month, Day);
|
||||
end;
|
||||
end;
|
||||
|
||||
function StTimeToDateTime(T : TStTime) : TDateTime;
|
||||
{-Convert TStTime to TDateTime}
|
||||
var
|
||||
Hour, Min, Sec : Byte;
|
||||
begin
|
||||
Result := 0;
|
||||
if T <> BadTime then begin
|
||||
StTimeToHMS(T, Hour, Min, Sec);
|
||||
Result := EncodeTime(Hour, Min, Sec, 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure IncDateTime(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
|
||||
Days : Integer; Secs : LongInt);
|
||||
{-Increment (or decrement) DT1 by the specified number of days and seconds
|
||||
and put the result in DT2}
|
||||
begin
|
||||
DT2 := DT1;
|
||||
|
||||
{date first}
|
||||
Inc(DT2.D, LongInt(Days));
|
||||
|
||||
if Secs < 0 then begin
|
||||
{change the sign}
|
||||
Secs := -Secs;
|
||||
|
||||
{adjust the date}
|
||||
Dec(DT2.D, Secs div SecondsInDay);
|
||||
Secs := Secs mod SecondsInDay;
|
||||
|
||||
if Secs > DT2.T then begin
|
||||
{subtract a day from DT2.D and add a day's worth of seconds to DT2.T}
|
||||
Dec(DT2.D);
|
||||
Inc(DT2.T, SecondsInDay);
|
||||
end;
|
||||
|
||||
{now subtract the seconds}
|
||||
Dec(DT2.T, Secs);
|
||||
end
|
||||
else begin
|
||||
{increment the seconds}
|
||||
Inc(DT2.T, Secs);
|
||||
|
||||
{adjust date if necessary}
|
||||
Inc(DT2.D, DT2.T div SecondsInDay);
|
||||
|
||||
{force time to 0..SecondsInDay-1 range}
|
||||
DT2.T := DT2.T mod SecondsInDay;
|
||||
end;
|
||||
end;
|
||||
|
||||
function Convert2ByteDate(TwoByteDate : Word) : TStDate;
|
||||
begin
|
||||
Result := LongInt(TwoByteDate) + Date1900;
|
||||
end;
|
||||
|
||||
function Convert4ByteDate(FourByteDate : TStDate) : Word;
|
||||
begin
|
||||
Result := Word(FourByteDate - Date1900);
|
||||
end;
|
||||
|
||||
procedure SetDefaultYear;
|
||||
{-Initialize DefaultYear and DefaultMonth}
|
||||
var
|
||||
Month, Day, Year : Word;
|
||||
T : TDateTime;
|
||||
begin
|
||||
T := Now;
|
||||
DecodeDate(T, Year, Month, Day);
|
||||
DefaultYear := Year;
|
||||
DefaultMonth := Month;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
{initialize DefaultYear and DefaultMonth}
|
||||
SetDefaultYear;
|
||||
end.
|
||||
1111
components/systools/source/run/stdatest.pas
Normal file
1111
components/systools/source/run/stdatest.pas
Normal file
File diff suppressed because it is too large
Load Diff
1308
components/systools/source/run/stdecmth.pas
Normal file
1308
components/systools/source/run/stdecmth.pas
Normal file
File diff suppressed because it is too large
Load Diff
886
components/systools/source/run/stdict.pas
Normal file
886
components/systools/source/run/stdict.pas
Normal file
@@ -0,0 +1,886 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StDict.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Dictionary class *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$I StDefine.inc}
|
||||
|
||||
{Notes:
|
||||
Nodes stored in the dictionary must be of type TStDictNode.
|
||||
|
||||
Duplicate strings are not allowed in the dictionary.
|
||||
|
||||
Calling Exists moves the found node to the front of its hash bin list.
|
||||
|
||||
Iterate scans the nodes in hash order.
|
||||
|
||||
Hashing and comparison is case-insensitive by default.
|
||||
|
||||
In 16-bit mode, HashSize must be in the range 1..16380. In 32-bit
|
||||
mode, there is no practical limit on HashSize. A particular value
|
||||
of HashSize may lead to a better distribution of symbols in the
|
||||
dictionary, and therefore to better performance. Generally HashSize
|
||||
should be about the same size as the number of symbols expected in
|
||||
the dictionary. A prime number tends to give a better distribution.
|
||||
Based on analysis by D. Knuth, the following values are good
|
||||
choices for HashSize when the dictionary keys are alphanumeric
|
||||
strings:
|
||||
|
||||
59 61 67 71 73 127 131 137 191 193 197 199 251 257 263 311 313
|
||||
317 379 383 389 439 443 449 457 503 509 521 569 571 577 631 641
|
||||
643 647 701 709 761 769 773 823 827 829 839 887 953 967
|
||||
|
||||
Good values for larger tables can be computed by the GOODHASH.PAS
|
||||
bonus program.
|
||||
}
|
||||
|
||||
unit StDict;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes,
|
||||
StConst, StBase;
|
||||
|
||||
type
|
||||
TStDictNode = class(TStNode)
|
||||
{.Z+}
|
||||
protected
|
||||
dnNext : TStDictNode; {Next node in hash list}
|
||||
dnName : string; {Name of symbol, already a pointer}
|
||||
function GetName : string;
|
||||
|
||||
{.Z-}
|
||||
public
|
||||
constructor CreateStr(const Name : string; AData : Pointer);
|
||||
{-Initialize node}
|
||||
destructor Destroy; override;
|
||||
{-Free name string and destroy node}
|
||||
|
||||
property Name : string
|
||||
read GetName;
|
||||
end;
|
||||
|
||||
{.Z+}
|
||||
TSymbolArray = array[0..(StMaxBlockSize div SizeOf(TStDictNode))-1] of TStDictNode;
|
||||
PSymbolArray = ^TSymbolArray;
|
||||
{.Z-}
|
||||
|
||||
TDictHashFunc =
|
||||
function(const S : AnsiString; Size : Integer) : Integer;
|
||||
|
||||
TStDictionary = class(TStContainer)
|
||||
{.Z+}
|
||||
protected
|
||||
{property instance variables}
|
||||
FHashSize : Integer; {Bins in symbol array}
|
||||
FEqual : TStringCompareFunc; {String compare function}
|
||||
FHash : TDictHashFunc;
|
||||
|
||||
{event variables}
|
||||
FOnEqual : TStStringCompareEvent;
|
||||
|
||||
{private instance variables}
|
||||
dySymbols : PSymbolArray; {Pointer to symbol array}
|
||||
dyIgnoreDups : Boolean; {Ignore duplicates during Join?}
|
||||
|
||||
{protected undocumented methods}
|
||||
procedure dySetEqual(E : TStringCompareFunc);
|
||||
procedure dySetHash(H : TDictHashFunc);
|
||||
procedure dySetHashSize(Size : Integer);
|
||||
procedure dyFindNode(const Name : string; var H : Integer;
|
||||
var Prev, This : TStDictNode);
|
||||
{.Z-}
|
||||
public
|
||||
constructor Create(AHashSize : Integer); virtual;
|
||||
{-Initialize an empty dictionary}
|
||||
destructor Destroy; override;
|
||||
{-Destroy a dictionary}
|
||||
|
||||
procedure LoadFromStream(S : TStream); override;
|
||||
{-Read a dictionary and its data from a stream}
|
||||
procedure StoreToStream(S : TStream); override;
|
||||
{-Write a dictionary and its data to a stream}
|
||||
|
||||
procedure Clear; override;
|
||||
{-Remove all nodes from container but leave it instantiated}
|
||||
function DoEqual(const String1, String2 : string) : Integer;
|
||||
virtual;
|
||||
function Exists(const Name : string; var Data : Pointer) : Boolean;
|
||||
{-Return True and the Data pointer if Name is in the dictionary}
|
||||
procedure Add(const Name : string; Data : Pointer);
|
||||
{-Add new Name and Data to the dictionary}
|
||||
procedure Delete(const Name : string);
|
||||
{-Delete a Name from the dictionary}
|
||||
procedure GetItems(S : TStrings);
|
||||
{-Fill the string list with all stored strings}
|
||||
procedure SetItems(S : TStrings);
|
||||
{-Fill the container with the strings and objects in S}
|
||||
procedure Update(const Name : string; Data : Pointer);
|
||||
{-Update the data for an existing element}
|
||||
function Find(Data : Pointer; var Name : string) : Boolean;
|
||||
{-Return True and the element Name that matches Data}
|
||||
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
{-Assign another container's contents to this one}
|
||||
procedure Join(D : TStDictionary; IgnoreDups : Boolean);
|
||||
{-Add dictionary D into this one and dispose D}
|
||||
|
||||
function Iterate(Action : TIterateFunc;
|
||||
OtherData : Pointer) : TStDictNode;
|
||||
{-Call Action for all the nodes, returning the last node visited}
|
||||
|
||||
function BinCount(H : Integer) : LongInt;
|
||||
{-Return number of names in a hash bin (for testing)}
|
||||
|
||||
property Equal : TStringCompareFunc
|
||||
read FEqual
|
||||
write dySetEqual;
|
||||
|
||||
property Hash : TDictHashFunc
|
||||
read FHash
|
||||
write dySetHash;
|
||||
|
||||
property HashSize : Integer
|
||||
read FHashSize
|
||||
write dySetHashSize;
|
||||
|
||||
property OnEqual : TStStringCompareEvent
|
||||
read FOnEqual
|
||||
write FOnEqual;
|
||||
end;
|
||||
|
||||
|
||||
function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
|
||||
{-Case-insensitive hash function that uses the current language driver}
|
||||
function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
|
||||
{-Case-sensitive hash function}
|
||||
function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
|
||||
{-Case-insensitive ELF hash function that uses the current language driver}
|
||||
function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
|
||||
{-Case-sensitive ELF hash function}
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
uses
|
||||
AnsiStrings;
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF ThreadSafe}
|
||||
var
|
||||
ClassCritSect : TRTLCriticalSection;
|
||||
{$ENDIF}
|
||||
|
||||
procedure EnterClassCS;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure LeaveClassCS;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
LeaveCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
{The following routine was extracted from LockBox and modified}
|
||||
function HashElf(const Buf; BufSize : LongInt) : LongInt;
|
||||
var
|
||||
// Bytes : TByteArray absolute Buf; {!!.02}
|
||||
Bytes : PAnsiChar; {!!.02}
|
||||
I, X : LongInt;
|
||||
begin
|
||||
Bytes := @Buf; {!!.02}
|
||||
Result := 0;
|
||||
for I := 0 to BufSize - 1 do begin
|
||||
Result := (Result shl 4) + Ord(Bytes^); {!!.02}
|
||||
Inc(Bytes); {!!.02}
|
||||
X := LongInt(Result and $F0000000); {!!.02}
|
||||
if (X <> 0) then
|
||||
Result := Result xor (X shr 24);
|
||||
Result := Result and (not X);
|
||||
end;
|
||||
end;
|
||||
|
||||
function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
|
||||
begin
|
||||
{$IFDEF WStrings}
|
||||
Result := AnsiELFHashStr(AnsiUpperCaseShort32(S), Size);
|
||||
{$ELSE}
|
||||
Result := AnsiELFHashStr(AnsiUpperCase(S), Size);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
|
||||
begin
|
||||
Result := HashElf(S[1], Length(S)) mod Size;
|
||||
if Result < 0 then
|
||||
Inc(Result, Size);
|
||||
end;
|
||||
|
||||
constructor TStDictNode.CreateStr(const Name : string; AData : Pointer);
|
||||
begin
|
||||
Create(AData);
|
||||
dnName := Name;
|
||||
end;
|
||||
|
||||
destructor TStDictNode.Destroy;
|
||||
begin
|
||||
dnName := '';
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TStDictNode.GetName : string;
|
||||
begin
|
||||
Result := dnName;
|
||||
end;
|
||||
|
||||
function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
|
||||
{32-bit huge string}
|
||||
register;
|
||||
asm
|
||||
push ebx
|
||||
push esi
|
||||
push edi
|
||||
mov esi,S
|
||||
mov edi,Size
|
||||
xor ebx,ebx {ebx will be hash}
|
||||
or esi,esi {empty literal string comes in as a nil pointer}
|
||||
jz @2
|
||||
mov edx,[esi-4] {edx = length}
|
||||
or edx,edx {length zero?}
|
||||
jz @2
|
||||
xor ecx,ecx {ecx is shift counter}
|
||||
@1:xor eax,eax
|
||||
mov al,[esi] {eax = character}
|
||||
inc esi
|
||||
rol eax,cl {rotate character}
|
||||
xor ebx,eax {xor with hash}
|
||||
inc ecx {increment shift counter (rol uses only bottom 5 bits)}
|
||||
dec edx
|
||||
jnz @1
|
||||
@2:mov eax,ebx
|
||||
xor edx,edx
|
||||
div edi {edi = Size}
|
||||
mov eax,edx {return hash mod size}
|
||||
pop edi
|
||||
pop esi
|
||||
pop ebx
|
||||
end;
|
||||
|
||||
function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
|
||||
begin
|
||||
{$IFDEF WStrings}
|
||||
Result := AnsiHashStr(AnsiUpperCaseShort32(S), Size);
|
||||
{$ELSE}
|
||||
Result := AnsiHashStr(AnsiUpperCase(S), Size);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function FindNodeData(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
begin
|
||||
Result := (OtherData <> Node.Data);
|
||||
end;
|
||||
|
||||
function JoinNode(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
Result := True;
|
||||
with TStDictionary(OtherData) do begin
|
||||
dyFindNode(TStDictNode(Node).dnName, H, P, T);
|
||||
if Assigned(T) then
|
||||
if dyIgnoreDups then begin
|
||||
Node.Free;
|
||||
Exit;
|
||||
end else
|
||||
RaiseContainerError(stscDupNode);
|
||||
T := dySymbols^[H];
|
||||
dySymbols^[H] := TStDictNode(Node);
|
||||
dySymbols^[H].dnNext := T;
|
||||
Inc(FCount);
|
||||
end;
|
||||
end;
|
||||
|
||||
function AssignNode(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
var
|
||||
DictNode : TStDictNode absolute Node;
|
||||
OurDict : TStDictionary absolute OtherData;
|
||||
begin
|
||||
OurDict.Add(DictNode.Name, DictNode.Data);
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
{----------------------------------------------------------------------}
|
||||
|
||||
procedure TStDictionary.Add(const Name : string; Data : Pointer);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
dyFindNode(Name, H, P, T);
|
||||
if Assigned(T) then
|
||||
RaiseContainerError(stscDupNode);
|
||||
T := dySymbols^[H];
|
||||
dySymbols^[H] := TStDictNode.CreateStr(Name, Data);
|
||||
dySymbols^[H].dnNext := T;
|
||||
Inc(FCount);
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.Assign(Source: TPersistent);
|
||||
var
|
||||
i : integer;
|
||||
begin
|
||||
{The only two containers that we allow to be assigned to a string
|
||||
dictionary are (1) another string dictionary and (2) a Delphi string
|
||||
list (TStrings)}
|
||||
if (Source is TStDictionary) then
|
||||
begin
|
||||
Clear;
|
||||
TStDictionary(Source).Iterate(AssignNode, Self);
|
||||
end
|
||||
else if (Source is TStrings) then
|
||||
begin
|
||||
Clear;
|
||||
for i := 0 to pred(TStrings(Source).Count) do
|
||||
Add(TStrings(Source).Strings[i], TStrings(Source).Objects[i]);
|
||||
end
|
||||
else
|
||||
inherited Assign(Source);
|
||||
end;
|
||||
|
||||
function TStDictionary.BinCount(H : Integer) : LongInt;
|
||||
var
|
||||
C : LongInt;
|
||||
T : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
C := 0;
|
||||
T := dySymbols^[H];
|
||||
while Assigned(T) do begin
|
||||
inc(C);
|
||||
T := T.dnNext;
|
||||
end;
|
||||
Result := C;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.Clear;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if FCount <> 0 then begin
|
||||
Iterate(DestroyNode, nil);
|
||||
FCount := 0;
|
||||
FillChar(dySymbols^, LongInt(FHashSize)*SizeOf(TStDictNode), 0);
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
constructor TStDictionary.Create(AHashSize : Integer);
|
||||
begin
|
||||
CreateContainer(TStDictNode, 0);
|
||||
{FHashSize := 0;}
|
||||
{$IFDEF WStrings}
|
||||
FEqual := AnsiCompareTextShort32;
|
||||
{$ELSE}
|
||||
FEqual := AnsiCompareText;
|
||||
{$ENDIF}
|
||||
FHash := AnsiHashText;
|
||||
HashSize := AHashSize;
|
||||
end;
|
||||
|
||||
procedure TStDictionary.Delete(const Name : string);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
dyFindNode(Name, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
if Assigned(P) then
|
||||
P.dnNext := T.dnNext
|
||||
else
|
||||
dySymbols^[H] := T.dnNext;
|
||||
DestroyNode(Self, T, nil);
|
||||
Dec(FCount);
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
destructor TStDictionary.Destroy;
|
||||
begin
|
||||
if conNodeProt = 0 then
|
||||
Clear;
|
||||
if Assigned(dySymbols) then
|
||||
FreeMem(dySymbols, LongInt(FHashSize)*SizeOf(TStDictNode));
|
||||
IncNodeProtection;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TStDictionary.DoEqual(const String1, String2 : string) : Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
if Assigned(FOnEqual) then
|
||||
FOnEqual(Self, String1, String2, Result)
|
||||
else if Assigned(FEqual) then
|
||||
Result := FEqual(String1, String2);
|
||||
end;
|
||||
|
||||
procedure TStDictionary.dyFindNode(const Name : string; var H : Integer;
|
||||
var Prev, This : TStDictNode);
|
||||
var
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
Prev := nil;
|
||||
This := nil;
|
||||
H := Hash(Name, HashSize);
|
||||
T := dySymbols^[H];
|
||||
P := nil;
|
||||
while Assigned(T) do begin
|
||||
if DoEqual(Name, T.dnName) = 0 then begin
|
||||
Prev := P;
|
||||
This := T;
|
||||
Exit;
|
||||
end;
|
||||
P := T;
|
||||
T := T.dnNext;
|
||||
end;
|
||||
|
||||
{Not found}
|
||||
This := nil;
|
||||
end;
|
||||
|
||||
procedure TStDictionary.dySetEqual(E : TStringCompareFunc);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if Count = 0 then
|
||||
FEqual := E;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.dySetHash(H : TDictHashFunc);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if Count = 0 then
|
||||
FHash := H;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.dySetHashSize(Size : Integer);
|
||||
var
|
||||
H, OldSize : Integer;
|
||||
TableSize : LongInt;
|
||||
T, N : TStDictNode;
|
||||
OldSymbols : PSymbolArray;
|
||||
OldDisposeData : TDisposeDataProc;
|
||||
OldOnDisposeData : TStDisposeDataEvent;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
TableSize := LongInt(Size)*SizeOf(TStDictNode);
|
||||
if (Size <= 0) {or (TableSize > MaxBlockSize)} then
|
||||
RaiseContainerError(stscBadSize);
|
||||
|
||||
if Size <> FHashSize then begin
|
||||
OldSymbols := dySymbols;
|
||||
OldSize := FHashSize;
|
||||
|
||||
{Get a new hash table}
|
||||
GetMem(dySymbols, TableSize);
|
||||
FillChar(dySymbols^, TableSize, 0);
|
||||
FCount := 0;
|
||||
FHashSize := Size;
|
||||
|
||||
if OldSize <> 0 then begin
|
||||
{Prevent disposing of the user data while transferring elements}
|
||||
OldDisposeData := DisposeData;
|
||||
DisposeData := nil;
|
||||
OldOnDisposeData := OnDisposeData;
|
||||
OnDisposeData := nil;
|
||||
{Add old symbols into new hash table}
|
||||
for H := 0 to OldSize-1 do begin
|
||||
T := OldSymbols^[H];
|
||||
while Assigned(T) do begin
|
||||
Add(T.dnName, T.Data);
|
||||
N := T.dnNext;
|
||||
{free the node just transferred}
|
||||
T.Free;
|
||||
T := N;
|
||||
end;
|
||||
end;
|
||||
{Dispose of old hash table}
|
||||
FreeMem(OldSymbols, OldSize*SizeOf(TStDictNode));
|
||||
{Reassign the dispose data routine}
|
||||
DisposeData := OldDisposeData;
|
||||
OnDisposeData := OldOnDisposeData;
|
||||
end;
|
||||
|
||||
{FHashSize := Size;}
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TStDictionary.Exists(const Name : String; var Data : Pointer) : Boolean;
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
dyFindNode(Name, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
if Assigned(P) then begin
|
||||
{Move T to front of list}
|
||||
P.dnNext := T.dnNext;
|
||||
T.dnNext := dySymbols^[H];
|
||||
dySymbols^[H] := T;
|
||||
end;
|
||||
Result := True;
|
||||
Data := T.Data;
|
||||
end else
|
||||
Result := False;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TStDictionary.Find(Data : Pointer; var Name : string) : Boolean;
|
||||
var
|
||||
T : TStDictNode;
|
||||
begin
|
||||
Name := '';
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
T := Iterate(FindNodeData, Data);
|
||||
if Assigned(T) then begin
|
||||
Result := True;
|
||||
Name := T.dnName;
|
||||
end else
|
||||
Result := False;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.GetItems(S : TStrings);
|
||||
var
|
||||
H : Integer;
|
||||
T : TStDictNode;
|
||||
begin
|
||||
S.Clear;
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if FCount <> 0 then begin
|
||||
for H := 0 to FHashSize-1 do begin
|
||||
T := dySymbols^[H];
|
||||
while Assigned(T) do begin
|
||||
S.AddObject(T.Name, T.Data);
|
||||
T := T.dnNext;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.SetItems(S : TStrings);
|
||||
var
|
||||
I : Integer;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
Clear;
|
||||
for I := 0 to S.Count-1 do
|
||||
Add(S.Strings[I], S.Objects[I]);
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TStDictionary.Iterate(Action : TIterateFunc;
|
||||
OtherData : Pointer) : TStDictNode;
|
||||
var
|
||||
H : Integer;
|
||||
T, N : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if FCount <> 0 then begin
|
||||
for H := 0 to FHashSize-1 do begin
|
||||
T := dySymbols^[H];
|
||||
while Assigned(T) do begin
|
||||
N := T.dnNext;
|
||||
if Action(Self, T, OtherData) then
|
||||
T := N
|
||||
else begin
|
||||
Result := T;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Result := nil;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.Join(D : TStDictionary; IgnoreDups : Boolean);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterClassCS;
|
||||
EnterCS;
|
||||
D.EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
dyIgnoreDups := IgnoreDups;
|
||||
D.Iterate(JoinNode, Self);
|
||||
|
||||
{Dispose of D, but not its nodes}
|
||||
D.IncNodeProtection;
|
||||
D.Free;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
D.LeaveCS;
|
||||
LeaveCS;
|
||||
LeaveClassCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.Update(const Name : string; Data : Pointer);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStDictNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
dyFindNode(Name, H, P, T);
|
||||
if Assigned(T) then
|
||||
T.Data := Data;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.LoadFromStream(S : TStream);
|
||||
var
|
||||
Data : pointer;
|
||||
Reader : TReader;
|
||||
StreamedClass : TPersistentClass;
|
||||
StreamedNodeClass : TPersistentClass;
|
||||
StreamedClassName : string;
|
||||
StreamedNodeClassName : string;
|
||||
St : string;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
Clear;
|
||||
Reader := TReader.Create(S, 1024);
|
||||
try
|
||||
with Reader do
|
||||
begin
|
||||
StreamedClassName := ReadString;
|
||||
StreamedClass := GetClass(StreamedClassName);
|
||||
if (StreamedClass = nil) then
|
||||
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
|
||||
if (StreamedClass <> Self.ClassType) then
|
||||
RaiseContainerError(stscWrongClass);
|
||||
StreamedNodeClassName := ReadString;
|
||||
StreamedNodeClass := GetClass(StreamedNodeClassName);
|
||||
if (StreamedNodeClass = nil) then
|
||||
RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
|
||||
if (StreamedNodeClass <> conNodeClass) then
|
||||
RaiseContainerError(stscWrongNodeClass);
|
||||
HashSize := ReadInteger;
|
||||
ReadListBegin;
|
||||
while not EndOfList do
|
||||
begin
|
||||
St := ReadString;
|
||||
Data := DoLoadData(Reader);
|
||||
Add(St, Data);
|
||||
end;
|
||||
ReadListEnd;
|
||||
end;
|
||||
finally
|
||||
Reader.Free;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStDictionary.StoreToStream(S : TStream);
|
||||
var
|
||||
H : Integer;
|
||||
Walker : TStDictNode;
|
||||
Writer : TWriter;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
Writer := TWriter.Create(S, 1024);
|
||||
try
|
||||
with Writer do
|
||||
begin
|
||||
WriteString(Self.ClassName);
|
||||
WriteString(conNodeClass.ClassName);
|
||||
WriteInteger(HashSize);
|
||||
WriteListBegin;
|
||||
if (Count <> 0) then
|
||||
for H := 0 to FHashSize-1 do
|
||||
begin
|
||||
Walker := dySymbols^[H];
|
||||
while Assigned(Walker) do
|
||||
begin
|
||||
WriteString(Walker.dnName);
|
||||
DoStoreData(Writer, Walker.Data);
|
||||
Walker := Walker.dnNext;
|
||||
end;
|
||||
end;
|
||||
WriteListEnd;
|
||||
end;
|
||||
finally
|
||||
Writer.Free;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{$IFDEF ThreadSafe}
|
||||
initialization
|
||||
Windows.InitializeCriticalSection(ClassCritSect);
|
||||
finalization
|
||||
Windows.DeleteCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end.
|
||||
1660
components/systools/source/run/stexpr.pas
Normal file
1660
components/systools/source/run/stexpr.pas
Normal file
File diff suppressed because it is too large
Load Diff
355
components/systools/source/run/stexpr.txt
Normal file
355
components/systools/source/run/stexpr.txt
Normal file
@@ -0,0 +1,355 @@
|
||||
|
||||
This file documents the TStExpression and TStExpressionEdit components.
|
||||
|
||||
|
||||
TStExpression
|
||||
=============
|
||||
|
||||
TStExpression is a non-visual component that provides expression evaluation
|
||||
at several different levels. At the lowest level, simple mathematical
|
||||
expressions can be evaluated and the resulting value obtained. On a higher
|
||||
level, you can define alpha-numeric constants that can then be used within
|
||||
expressions; You can add user-defined functions (and even methods of a class)
|
||||
so that the names of these routines can be used in expressions; You can
|
||||
define variables that relate directly to variables in your program and even
|
||||
use them in expressions.
|
||||
|
||||
Note: TStExpression replaces AnalyzeExpr that SysTools version 2.00 provided,
|
||||
but a version of that routine is still provided for backward compatibility.
|
||||
|
||||
The TStExpression expression parser implements the following grammar, similar
|
||||
to a subset of Pascal:
|
||||
|
||||
expression: term | expression+term | expression-term
|
||||
term: factor | term*factor | term/factor
|
||||
factor: base | base^factor
|
||||
base: unsigned_num | (expression) | sign factor | func_call
|
||||
unsigned_num: digit_seq | digit_seq.digit_seq | digit_seq scale_fac |
|
||||
digit_seq.digit_seq scale_fac
|
||||
sign: + | -
|
||||
func_call: identifier | identifier(params)
|
||||
params: expression | params,expression
|
||||
scale_fac: E digit_seq | E sign digit_seq
|
||||
digit_seq: digit | digit_seq digit
|
||||
identifier: starts with A..Z,_ continues with A..Z,_,0..9
|
||||
digit: 0..9
|
||||
|
||||
Case is not significant when matching characters.
|
||||
|
||||
The grammar follows normal rules of arithmetic precedence, with ^ highest, *
|
||||
and / in the middle, and + and - lowest. Thus, 1+2*3^4 means 1+(2*(3^4)).
|
||||
Parentheses can be used to force non-default precedence.
|
||||
|
||||
Note that the power operator x^y is right-associative. This means that
|
||||
2^0.5^2 is equivalent to 2^(0.5^2). All other arithmetic operators are left
|
||||
associative: 1-2-3 is equivalent to (1-2)-3.
|
||||
|
||||
The following functions are supported in 16-bit and 32-bit applications:
|
||||
|
||||
abs, arctan, cos, exp, frac, int(trunc), ln, pi, round, sin, sqr,
|
||||
sqrt
|
||||
|
||||
If the VCL Math unit is available and you define the "UseMathUnit" define in
|
||||
STDEFINE.INC, the following are also available:
|
||||
|
||||
arccos, arcsin, arctan2, tan, cotan, hypot, cosh, sinh, tanh,
|
||||
arccosh, arcsinh, arctanh, lnxp1, log10, log2, logn, ceil, floor
|
||||
|
||||
The calling conventions for all functions match those of the VCL runtime
|
||||
library or Math unit. The acceptable parameter ranges and output values also
|
||||
match thoses of the VCL runtime library or MATH unit.
|
||||
|
||||
When the input expression contains an error, TStExpression raises an
|
||||
exception of type EStExprError. Its ErrorCode property provides more detail
|
||||
about the error. Its ErrorColumn property gives the string index of the start
|
||||
of the token where the error was detected.
|
||||
|
||||
TStExpression is very flexible. You can add support for your own functions
|
||||
easily. For example, to add support for the Sin() function, first write a
|
||||
function to provide the proper number and type of parameters (the "far" can
|
||||
be omitted with 32-bit compilers):
|
||||
|
||||
function _Sin(Value : TStFloat) : TStFloat; far;
|
||||
begin
|
||||
Result := Sin(Value);
|
||||
end;
|
||||
|
||||
and then add it to the TStExpression component:
|
||||
|
||||
MyStExpression.AddFunction1Param('sin', _Sin);
|
||||
|
||||
Or, if you wanted to use a method of the form (or any other class) that you
|
||||
were working in, you could do the same thing this way:
|
||||
|
||||
function MyForm._Sin(Value : TStFloat) : TStFloat;
|
||||
begin
|
||||
Result := Sin(Value);
|
||||
end;
|
||||
|
||||
and then add it to the TStExpression component:
|
||||
|
||||
MyStExpression.AddMethod1Param('sin', _Sin);
|
||||
|
||||
TStExpression supports user-defined functions with 0 to 3 parameters. The
|
||||
parameters and function result must be the TStFloat type (defined in the
|
||||
STBASE unit). In the example above, that's why we didn't just add
|
||||
the Sin() function directly, in the call to AddFunction1Param -- The
|
||||
TStExpression component must know the data types of parameters and return
|
||||
values. If the function you are adding has no parameters, use the
|
||||
AddFunction0Parm() method. AddFunction2Param for functions with two
|
||||
parameters, etc.
|
||||
|
||||
The following function and method types define all possible user-defined
|
||||
function and method types accepted by the TStExpression component:
|
||||
|
||||
{user-defined functions with up to 3 parameters}
|
||||
TStFunction0Param =
|
||||
function : TStFloat;
|
||||
TStFunction1Param =
|
||||
function(Value1 : TStFloat) : TStFloat;
|
||||
TStFunction2Param =
|
||||
function(Value1, Value2 : TStFloat) : TStFloat;
|
||||
TStFunction3Param =
|
||||
function(Value1, Value2, Value3 : TStFloat) : TStFloat;
|
||||
|
||||
{user-defined methods with up to 3 parameters}
|
||||
TStMethod0Param =
|
||||
function : TStFloat
|
||||
of object;
|
||||
TStMethod1Param =
|
||||
function(Value1 : TStFloat) : TStFloat
|
||||
of object;
|
||||
TStMethod2Param =
|
||||
function(Value1, Value2 : TStFloat) : TStFloat
|
||||
of object;
|
||||
TStMethod3Param =
|
||||
function(Value1, Value2, Value3 : TStFloat) : TStFloat
|
||||
of object;
|
||||
|
||||
Add predefined constant values by using the AddConstant method:
|
||||
|
||||
AddConstant('X', 50)
|
||||
|
||||
Then, in any expression that uses the identifier "X", the value 50 will be
|
||||
used when the expression is evaluated.
|
||||
|
||||
Add references to variables in your program by using the AddVariable method:
|
||||
|
||||
var
|
||||
MyVar : TStFloat;
|
||||
|
||||
AddVariable('MyVar', @MyVar);
|
||||
|
||||
Whenever an expression is evaluated that contains the "MyVar" identifier,
|
||||
the actual value of the variable (in your program) is retrieved and used
|
||||
to compute the expression result. Changes to variable's value in your
|
||||
program will be reflected when the expression is next evaluated.
|
||||
|
||||
Two things to note: First, the variable must be a TStFloat type and second,
|
||||
the variable must remain in "scope". In general, this means that the variable
|
||||
must either be defined globally or as a class variable. You normally would not
|
||||
use AddVariable for variables defined local to a procedure or function (a
|
||||
stack variable).
|
||||
|
||||
TStExpression offers a way to dynamically determine the value of an variable
|
||||
or function that is being used in an expression -- the OnGetIdentValue event.
|
||||
This event is fired if the expression parser is unable to locate the identifier
|
||||
in its internal list of identifier names. In response to the event, you should
|
||||
assign a value to the Value parameter that corresponds to the identifier name
|
||||
passed to the event as the Identifier parameter. If no event handler is
|
||||
assigned to this even and the expression parser is unable to locate a match for
|
||||
an identifier used in an expression, an exception is raised.
|
||||
|
||||
|
||||
Reference Section
|
||||
-----------------
|
||||
|
||||
methods
|
||||
-------
|
||||
|
||||
function AnalyzeExpression : TStFloat;
|
||||
-> AnalyzeExpression causes the expression contained in the Expression property
|
||||
to be evaluated and returns the resulting value as the function result.
|
||||
|
||||
|
||||
procedure AddConstant(const Name : string; Value : TStFloat);
|
||||
-> AddConstant adds named constant values for use within expressions.
|
||||
|
||||
Example: AddConstant('X', 50)
|
||||
|
||||
|
||||
procedure AddFunction0Param(const Name : string; FunctionAddr : TStFunction0Param);
|
||||
procedure AddFunction1Param(const Name : string; FunctionAddr : TStFunction1Param);
|
||||
procedure AddFunction2Param(const Name : string; FunctionAddr : TStFunction2Param);
|
||||
procedure AddFunction3Param(const Name : string; FunctionAddr : TStFunction3Param);
|
||||
-> AddFunctionXParam adds support for user-defined functions within expressions.
|
||||
|
||||
The four variations allow defining functions with no parameters, or, with one,
|
||||
two, or three parameters. Name is the identifier that is entered into the
|
||||
expression. The name does not need to be the same as the actual function name.
|
||||
|
||||
Parameter and function results must be defined as TStFloat.
|
||||
|
||||
|
||||
procedure AddInternalFunctions;
|
||||
-> AddInternalFunctions adds support for all of the predefined internal
|
||||
functions.
|
||||
|
||||
Since AddInternalFunctions is called by default, calling this routine without
|
||||
first calling ClearIdentifiers will result in duplicate identifier exceptions.
|
||||
|
||||
|
||||
procedure AddMethod0Param(const Name : string; MethodAddr : TStMethod0Param);
|
||||
procedure AddMethod1Param(const Name : string; MethodAddr : TStMethod1Param);
|
||||
procedure AddMethod2Param(const Name : string; MethodAddr : TStMethod2Param);
|
||||
procedure AddMethod3Param(const Name : string; MethodAddr : TStMethod3Param);
|
||||
-> AddMethodXParam adds support for user-defined methods within expressions.
|
||||
|
||||
The four variations allow defining methods with no parameters, or, with one,
|
||||
two, or three parameters. Name is the identifier that is entered into the
|
||||
expression. The name does not need to be the same as the actual method name.
|
||||
|
||||
Parameter and function results must be defined as TStFloat.
|
||||
|
||||
|
||||
procedure AddVariable(const Name : string; VariableAddr : PStFloat);
|
||||
-> Adds Name as a reference to a variable in your program.
|
||||
|
||||
Name is the identifier used in expressions.
|
||||
|
||||
Example:
|
||||
|
||||
var
|
||||
X : TStFloat;
|
||||
...
|
||||
AddVariable('X', @X)
|
||||
|
||||
|
||||
procedure ClearIdentifiers;
|
||||
-> ClearIdentifiers removes all function, method, constant, and variable identifiers.
|
||||
|
||||
|
||||
procedure GetIdentList(S : TStrings);
|
||||
-> GetIdentList fills S with a list of identifiers current recognized.
|
||||
|
||||
|
||||
procedure RemoveIdentifier(const Name : string);
|
||||
-> RemoveIdentifier removes support for the identifier Name.
|
||||
|
||||
If Name is not found, no action is taken.
|
||||
|
||||
|
||||
properties
|
||||
----------
|
||||
property AsFloat : TStFloat (run-time read-only)
|
||||
-> AsFloat evaluates the expression and returns the value as a TStFloat
|
||||
value;
|
||||
|
||||
property AsInteger : Integer (run-time read-only)
|
||||
-> AsInteger evaluates the expression and returns the value as a whole number
|
||||
using the Round() function to convert the TStFloat value.
|
||||
|
||||
property AsString : string (run-time read-only)
|
||||
-> AsString evaluates the expression and returns the value as a string using
|
||||
the FloatToStr() function to format the TStFloat value.
|
||||
|
||||
property LastError : Integer (run-time read-only)
|
||||
-> LastError returns the error code (zero if no error).
|
||||
|
||||
property ErrorPosition : Integer (run-time read-only)
|
||||
-> ErrorPosition returns the position of the error within the expression.
|
||||
|
||||
ErrorPosition is valid only if LastError is non-zero.
|
||||
|
||||
property Expression : string (run-time)
|
||||
-> Expression defines the expression that should be evaluated.
|
||||
|
||||
property AllowEqual : Boolean
|
||||
default: True
|
||||
-> AllowEqual determines if the use of the "=" symbol in the expression will
|
||||
add constant declarations.
|
||||
|
||||
If true, expressions like X = 5 will cause the identifer "X" to be added and
|
||||
associated with the value 5. This expression will also return a value of 5
|
||||
when analyzed. If false, a bad character exception is raised.
|
||||
|
||||
|
||||
events
|
||||
------
|
||||
property OnAddIdentifier : TNotifyEvent
|
||||
-> OnAddIdentifier defines an event that is fired when a new identifier
|
||||
is added.
|
||||
|
||||
This event is fired for additions of function, method, constant, and variable
|
||||
identifiers.
|
||||
|
||||
property OnGetIdentValue : TGetIdentValueEvent
|
||||
TGetIdentValueEvent =
|
||||
procedure(Sender : TObject; const Identifier : string; var Value : TStFloat)
|
||||
of object;
|
||||
-> OnGetIdentValue defines an event handler that is fired to obtain the value
|
||||
for an identifier that was not found in the internal list of known identifiers.
|
||||
|
||||
|
||||
TStExpressionEdit
|
||||
=================
|
||||
The TStExpressionEdit component is a simple descendant of a TEdit component
|
||||
that adds one new method, two properties, and two new events. In all other
|
||||
respects, this control is the same as the standard VCL TEdit control.
|
||||
|
||||
The TStExpressionEdit uses an instance of the TStExpression component to do
|
||||
most of the work. Any expression that is valid for the TStExpression
|
||||
component can be entered into the component or assigned to the Text property.
|
||||
The expression is evaluated when the component loses the focus (with AutoEval
|
||||
true) or when the Evaluate method is called. Also, if AutoEval is true and
|
||||
the control loses the focus, the resulting value is displayed in the control.
|
||||
|
||||
|
||||
New properties and methods:
|
||||
|
||||
function Evaluate : TStFloat;
|
||||
|
||||
-> Evaluate evaluates the contents of the Text property as an expression
|
||||
using the contained TStExpression component and returns the result of the
|
||||
expression as the function result.
|
||||
|
||||
If an error occurs an exception is raised unless an event handler for the
|
||||
OnError event is assigned. In which case, the event is fired instead.
|
||||
|
||||
Note: The AnalyzeExpr function (which is documented in the printed
|
||||
manual and on-line help) is obsolete and is provided for backward
|
||||
compatibility only.
|
||||
|
||||
|
||||
property AutoEval : Boolean
|
||||
|
||||
-> AutoEval determines if the entered expression is automatically evaluated
|
||||
when the control loses the focus.
|
||||
|
||||
If AutoEval is true, the Evaluate method is called automatically and the
|
||||
Text of the edit control is set to the result of evaluating the expression.
|
||||
If False, no additional action is taken.
|
||||
|
||||
|
||||
property Expr : TStExpression (run-time)
|
||||
|
||||
-> Expr provides access to the contained TStExpression component and all of
|
||||
its properties, methods, and events.
|
||||
|
||||
|
||||
property OnAddIdentifier : TNotifyEvent
|
||||
|
||||
-> OnAddIdentifier defines an event that is fired when an identifier is
|
||||
added to the internal TStExpression component.
|
||||
|
||||
This event is fired to notify you that a constant or function identifier has
|
||||
been added to the contained TStExpression component.
|
||||
|
||||
|
||||
property OnError : TStExprErrorEvent
|
||||
|
||||
TStExprErrorEvent =
|
||||
procedure(Sender : TObject; ErrorNumber : LongInt; const ErrorStr : string)
|
||||
of object;
|
||||
|
||||
-> OnError defines an event that is fired when an evaluation error occurs.
|
||||
1312
components/systools/source/run/stfin.pas
Normal file
1312
components/systools/source/run/stfin.pas
Normal file
File diff suppressed because it is too large
Load Diff
995
components/systools/source/run/sthash.pas
Normal file
995
components/systools/source/run/sthash.pas
Normal file
@@ -0,0 +1,995 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StHASH.PAS 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Hash table class *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$I StDefine.inc}
|
||||
|
||||
{Notes:
|
||||
- Generally the same as STDICT.PAS, but the hash table is
|
||||
keyed on elements of arbitrary type rather than just strings.
|
||||
|
||||
- Also manages an LRU counter and updates each node's LRU when
|
||||
it is added or accessed. If the maximum allowed number of nodes
|
||||
in the table is exceeded, the least recently used node is
|
||||
automatically removed from the table. By default, MaxLongInt
|
||||
nodes can be in the table so the automatic removal logic does
|
||||
not come into play. When a node is automatically removed, the
|
||||
NodeRemoved virtual method is called to notify the program
|
||||
that the node is being removed.
|
||||
}
|
||||
|
||||
unit StHASH;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
Classes,
|
||||
{$IFNDEF FPC}
|
||||
{$IFDEF ThreadSafe}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
StConst,
|
||||
StBase;
|
||||
|
||||
type
|
||||
TStHashNode = class(TStNode)
|
||||
{.Z+}
|
||||
protected
|
||||
hnNext : TStHashNode; {Next node in hash list}
|
||||
hnValue: Pointer; {Pointer to value of element}
|
||||
hnValSize : Cardinal; {Size of hnValue memory block}
|
||||
FLRU : LongInt; {LRU counter of this node}
|
||||
|
||||
function GetValue : Pointer;
|
||||
|
||||
{.Z-}
|
||||
public
|
||||
constructor CreateNode(const AValue; AValSize : Cardinal; AData : Pointer);
|
||||
virtual;
|
||||
{-Initialize node}
|
||||
destructor Destroy; override;
|
||||
{-Free name string and destroy node}
|
||||
|
||||
property Value : Pointer
|
||||
read GetValue;
|
||||
property LRU : LongInt
|
||||
read FLRU
|
||||
write FLRU;
|
||||
end;
|
||||
|
||||
{.Z+}
|
||||
THashArray = array[0..(MaxInt div SizeOf(TStHashNode))-1] of TStHashNode;
|
||||
PHashArray = ^THashArray;
|
||||
{.Z-}
|
||||
|
||||
THashFunc = function (const V; Size : Integer) : Integer;
|
||||
|
||||
TStHashTable = class(TStContainer)
|
||||
{.Z+}
|
||||
protected
|
||||
{property instance variables}
|
||||
FValSize : Cardinal; {Size of each element in table}
|
||||
FHashSize : Integer; {Bins in hash array}
|
||||
FEqual : TUntypedCompareFunc; {Element compare function}
|
||||
FHash : THashFunc; {Hash function}
|
||||
FMaxNodes : LongInt; {Max nodes allowed in table}
|
||||
|
||||
{private instance variables}
|
||||
htHeads : PHashArray; {Pointer to head of node lists}
|
||||
htTails : PHashArray; {Pointer to tail of node lists}
|
||||
htLRU : LongInt; {LRU counter}
|
||||
htIgnoreDups : Boolean; {Ignore duplicates during Join?}
|
||||
|
||||
{protected undocumented methods}
|
||||
procedure htInsertNode(H : Integer; This : TStHashNode);
|
||||
procedure htIterate(Action : TIterateFunc; OtherData : Pointer;
|
||||
var H : Integer; var Prev, This : TStHashNode);
|
||||
procedure htSetEqual(E : TUntypedCompareFunc);
|
||||
procedure htSetHash(H : THashFunc);
|
||||
procedure htSetHashSize(Size : Integer);
|
||||
procedure htSetMaxNodes(Nodes : LongInt);
|
||||
procedure htMoveToFront(H : Integer; Prev, This : TStHashNode);
|
||||
procedure htFindNode(const V; var H : Integer;
|
||||
var Prev, This : TStHashNode);
|
||||
procedure htUpdateLRU(This : TStHashNode);
|
||||
procedure htDeleteOldestNode;
|
||||
|
||||
{.Z-}
|
||||
public
|
||||
constructor Create(AValSize : Cardinal; AHashSize : Integer); virtual;
|
||||
{-Initialize an empty hash table}
|
||||
destructor Destroy; override;
|
||||
{-Destroy a hash table}
|
||||
|
||||
procedure LoadFromStream(S : TStream); override;
|
||||
{-Read a hash table and its data from a stream}
|
||||
procedure StoreToStream(S : TStream); override;
|
||||
{-Write a hash table and its data to a stream}
|
||||
|
||||
procedure Clear; override;
|
||||
{-Remove all nodes from container but leave it instantiated}
|
||||
|
||||
function Exists(const V; var Data : Pointer) : Boolean;
|
||||
{-Return True and the Data pointer if V is in the hash table}
|
||||
procedure Add(const V; Data : Pointer);
|
||||
{-Add new value and Data to the hash table}
|
||||
procedure Delete(const V);
|
||||
{-Delete a value from the hash table}
|
||||
procedure Update(const V; Data : Pointer);
|
||||
{-Update the data for an existing element}
|
||||
function Find(Data : Pointer; var V) : Boolean;
|
||||
{-Return True and the element value that matches Data}
|
||||
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
{-Assign another hash table's contents to this one}
|
||||
procedure Join(H : TStHashTable; IgnoreDups : Boolean);
|
||||
{-Add hash table H into this one and dispose H}
|
||||
|
||||
function Iterate(Action : TIterateFunc;
|
||||
OtherData : Pointer) : TStHashNode;
|
||||
{-Call Action for all the nodes, returning the last node visited}
|
||||
|
||||
procedure NodeRemoved(const V; Data : Pointer); virtual;
|
||||
{-Called when a not recently used node is removed from the table}
|
||||
|
||||
function BinCount(H : Integer) : LongInt;
|
||||
{-Return number of names in a hash bin (for testing)}
|
||||
|
||||
property Equal : TUntypedCompareFunc
|
||||
{-Change the string compare function; only for an empty table}
|
||||
read FEqual
|
||||
write htSetEqual;
|
||||
|
||||
property Hash : THashFunc
|
||||
{-Change the hash function; only for an empty table}
|
||||
read FHash
|
||||
write htSetHash;
|
||||
|
||||
property HashSize : Integer
|
||||
{-Change the hash table size; preserves existing elements}
|
||||
read FHashSize
|
||||
write htSetHashSize;
|
||||
|
||||
property ValSize : Cardinal
|
||||
{-Read the size of each element in the table}
|
||||
read FValSize;
|
||||
|
||||
property MaxNodes : LongInt
|
||||
{-Change the maximum nodes in the table}
|
||||
read FMaxNodes
|
||||
write htSetMaxNodes;
|
||||
end;
|
||||
|
||||
{======================================================================}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF ThreadSafe}
|
||||
var
|
||||
ClassCritSect : TRTLCriticalSection;
|
||||
{$ENDIF}
|
||||
|
||||
procedure EnterClassCS;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure LeaveClassCS;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
LeaveCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{----------------------------------------------------------------------}
|
||||
|
||||
constructor TStHashNode.CreateNode(const AValue; AValSize : Cardinal;
|
||||
AData : Pointer);
|
||||
begin
|
||||
Create(AData);
|
||||
hnValSize := AValSize;
|
||||
GetMem(hnValue, AValSize);
|
||||
Move(AValue, hnValue^, AValSize);
|
||||
end;
|
||||
|
||||
destructor TStHashNode.Destroy;
|
||||
begin
|
||||
if Assigned(hnValue) then
|
||||
FreeMem(hnValue, hnValSize);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TStHashNode.GetValue : Pointer;
|
||||
begin
|
||||
Result := hnValue;
|
||||
end;
|
||||
|
||||
{----------------------------------------------------------------------}
|
||||
|
||||
procedure TStHashTable.Add(const V; Data : Pointer);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htFindNode(V, H, P, T);
|
||||
if Assigned(T) then
|
||||
RaiseContainerError(stscDupNode);
|
||||
htInsertNode(H, TStHashNode.CreateNode(V, FValSize, Data));
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function AssignNode(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
var
|
||||
HashNode : TStHashNode absolute Node;
|
||||
OurHashTbl : TStHashTable absolute OtherData;
|
||||
begin
|
||||
OurHashTbl.Add(HashNode.Value^, HashNode.Data);
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.Assign(Source: TPersistent);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
{The only container that we allow to be assigned to a hash table
|
||||
is... another hash table}
|
||||
if (Source is TStHashTable) then begin
|
||||
Clear;
|
||||
FValSize := TStHashTable(Source).ValSize;
|
||||
TStHashTable(Source).Iterate(AssignNode, Self);
|
||||
end
|
||||
else
|
||||
inherited Assign(Source);
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
function TStHashTable.BinCount(H : Integer) : LongInt;
|
||||
var
|
||||
C : LongInt;
|
||||
T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
C := 0;
|
||||
T := htHeads^[H];
|
||||
while Assigned(T) do begin
|
||||
inc(C);
|
||||
T := T.hnNext;
|
||||
end;
|
||||
Result := C;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.Clear;
|
||||
var
|
||||
TableSize : Cardinal;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if FCount <> 0 then begin
|
||||
Iterate(DestroyNode, nil);
|
||||
FCount := 0;
|
||||
htLRU := 0;
|
||||
TableSize := FHashSize*SizeOf(TStHashNode);
|
||||
FillChar(htHeads^, TableSize, 0);
|
||||
FillChar(htTails^, TableSize, 0);
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
constructor TStHashTable.Create(AValSize : Cardinal; AHashSize : Integer);
|
||||
begin
|
||||
if AValSize = 0 then
|
||||
RaiseContainerError(stscBadSize);
|
||||
|
||||
CreateContainer(TStHashNode, 0);
|
||||
|
||||
FValSize := AValSize;
|
||||
FMaxNodes := MaxLongInt;
|
||||
|
||||
{allocate hash table by assigning to the HashSize property}
|
||||
HashSize := AHashSize;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.Delete(const V);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htFindNode(V, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
if Assigned(P) then
|
||||
P.hnNext := T.hnNext
|
||||
else
|
||||
htHeads^[H] := T.hnNext;
|
||||
if T = htTails^[H] then
|
||||
htTails^[H] := P;
|
||||
DestroyNode(Self, T, nil);
|
||||
Dec(FCount);
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
destructor TStHashTable.Destroy;
|
||||
var
|
||||
TableSize : Cardinal;
|
||||
begin
|
||||
if conNodeProt = 0 then
|
||||
Clear;
|
||||
TableSize := FHashSize*SizeOf(TStHashNode);
|
||||
if Assigned(htHeads) then
|
||||
FreeMem(htHeads, TableSize);
|
||||
if Assigned(htTails) then
|
||||
FreeMem(htTails, TableSize);
|
||||
IncNodeProtection;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TStHashTable.Exists(const V; var Data : Pointer) : Boolean;
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htFindNode(V, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
htMoveToFront(H, P, T);
|
||||
htUpdateLRU(T);
|
||||
Result := True;
|
||||
Data := T.Data;
|
||||
end else
|
||||
Result := False;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function FindNodeData(Container : TStContainer; Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
begin
|
||||
Result := (OtherData <> Node.Data);
|
||||
end;
|
||||
|
||||
function TStHashTable.Find(Data : Pointer; var V) : Boolean;
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htIterate(FindNodeData, Data, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
htMoveToFront(H, P, T);
|
||||
htUpdateLRU(T);
|
||||
Result := True;
|
||||
Move(T.Value^, V, FValSize);
|
||||
end else
|
||||
Result := False;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htDeleteOldestNode;
|
||||
{-Find and delete the hash node with the smallest LRU counter}
|
||||
var
|
||||
H, MinH : Integer;
|
||||
MinLRU : LongInt;
|
||||
T, P : TStHashNode;
|
||||
begin
|
||||
if FCount <> 0 then begin
|
||||
MinLRU := MaxLongInt;
|
||||
MinH := 0;
|
||||
for H := 0 to FHashSize-1 do
|
||||
if Assigned(htTails^[H]) and (htTails^[H].LRU <= MinLRU) then begin
|
||||
MinH := H;
|
||||
MinLRU := htTails^[H].LRU;
|
||||
end;
|
||||
|
||||
{notify the application}
|
||||
with htTails^[MinH] do
|
||||
NodeRemoved(hnValue^, Data);
|
||||
|
||||
{destroy the node}
|
||||
DestroyNode(Self, htTails^[MinH], nil);
|
||||
dec(FCount);
|
||||
|
||||
{remove the node}
|
||||
if htTails^[MinH] = htHeads^[MinH] then begin
|
||||
{only node in this bin}
|
||||
htTails^[MinH] := nil;
|
||||
htHeads^[MinH] := nil;
|
||||
end else begin
|
||||
{at least two nodes in this bin}
|
||||
T := htHeads^[MinH];
|
||||
P := nil;
|
||||
while T <> htTails^[MinH] do begin
|
||||
P := T;
|
||||
T := T.hnNext;
|
||||
end;
|
||||
P.hnNext := nil;
|
||||
htTails^[MinH] := P;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htFindNode(const V; var H : Integer;
|
||||
var Prev, This : TStHashNode);
|
||||
var
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
if not(Assigned(FEqual) and Assigned(FHash)) then
|
||||
RaiseContainerError(stscNoCompare);
|
||||
|
||||
Prev := nil;
|
||||
This := nil;
|
||||
H := FHash(V, HashSize);
|
||||
T := htHeads^[H];
|
||||
P := nil;
|
||||
while Assigned(T) do begin
|
||||
if FEqual(V, T.Value^) = 0 then begin
|
||||
Prev := P;
|
||||
This := T;
|
||||
Exit;
|
||||
end;
|
||||
P := T;
|
||||
T := T.hnNext;
|
||||
end;
|
||||
|
||||
{not found}
|
||||
This := nil;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htInsertNode(H : Integer; This : TStHashNode);
|
||||
{-Insert node This at front of hash bin H}
|
||||
var
|
||||
P : TStHashNode;
|
||||
begin
|
||||
P := htHeads^[H];
|
||||
htHeads^[H] := This;
|
||||
if not Assigned(htTails^[H]) then
|
||||
htTails^[H] := This;
|
||||
This.hnNext := P;
|
||||
htUpdateLRU(This);
|
||||
Inc(FCount);
|
||||
if FCount > FMaxNodes then
|
||||
htDeleteOldestNode;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htIterate(Action : TIterateFunc; OtherData : Pointer;
|
||||
var H : Integer; var Prev, This : TStHashNode);
|
||||
{-Internal version of Iterate that returns more details}
|
||||
var
|
||||
AHash : Integer;
|
||||
P, T, N : TStHashNode;
|
||||
begin
|
||||
if FCount <> 0 then begin
|
||||
for AHash := 0 to FHashSize-1 do begin
|
||||
T := htHeads^[AHash];
|
||||
P := nil;
|
||||
while Assigned(T) do begin
|
||||
N := T.hnNext;
|
||||
if Action(Self, T, OtherData) then begin
|
||||
P := T;
|
||||
T := N;
|
||||
end else begin
|
||||
H := AHash;
|
||||
Prev := P;
|
||||
This := T;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
This := nil;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htMoveToFront(H : Integer; Prev, This : TStHashNode);
|
||||
{-Move This to front of list}
|
||||
begin
|
||||
if Assigned(Prev) then begin
|
||||
Prev.hnNext := This.hnNext;
|
||||
This.hnNext := htHeads^[H];
|
||||
htHeads^[H] := This;
|
||||
if This = htTails^[H] then
|
||||
htTails^[H] := Prev;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htSetEqual(E : TUntypedCompareFunc);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if Count = 0 then
|
||||
FEqual := E;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htSetHash(H : THashFunc);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
if Count = 0 then
|
||||
FHash := H;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htSetHashSize(Size : Integer);
|
||||
var
|
||||
HInx : integer;
|
||||
TableSize: LongInt;
|
||||
Temp : TStHashNode;
|
||||
Node : TStHashNode;
|
||||
OldHeads : PHashArray;
|
||||
OldTails : PHashArray;
|
||||
OldSize : Integer;
|
||||
OldCount : Integer;
|
||||
OldDisposeData : TDisposeDataProc;
|
||||
OldOnDisposeData : TStDisposeDataEvent;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
{calculate the new table size}
|
||||
TableSize := LongInt(Size) * sizeof(TStHashNode);
|
||||
if (Size <= 0) {or (TableSize > MaxBlockSize)} then
|
||||
RaiseContainerError(stscBadSize);
|
||||
|
||||
{only do something if there's something to do}
|
||||
if (Size <> FHashSize) then begin
|
||||
|
||||
{Notes: lots of things are going to be happening here: new
|
||||
allocations, nodes copied from the old table to the new,
|
||||
etc. Ideally if an exception is raised we would like to
|
||||
restore the hash table to the state it was in
|
||||
originally, before letting the exception escape}
|
||||
|
||||
{save enough data about the current state of the table to
|
||||
allow restoring in case of an exception}
|
||||
OldHeads := htHeads;
|
||||
OldTails := htTails;
|
||||
OldSize := FHashSize;
|
||||
OldCount := FCount;
|
||||
OldDisposeData := DisposeData;
|
||||
OldOnDisposeData := OnDisposeData;
|
||||
|
||||
{reset Self's data}
|
||||
htHeads := nil;
|
||||
htTails := nil;
|
||||
FHashSize := Size;
|
||||
FCount := 0;
|
||||
DisposeData := nil;
|
||||
OnDisposeData := nil;
|
||||
|
||||
{from this point, exceptions can occur with impunity...}
|
||||
try
|
||||
{allocate the new head and tail tables}
|
||||
htHeads := AllocMem(TableSize);
|
||||
htTails := AllocMem(TableSize);
|
||||
|
||||
{if there is data to transfer, do so}
|
||||
if (OldHeads <> nil) and (OldCount <> 0) then begin
|
||||
for HInx := 0 to pred(OldSize) do begin
|
||||
Node := OldHeads^[HInx];
|
||||
while Assigned(Node) do begin
|
||||
Add(Node.hnValue^, Node.Data);
|
||||
Node := Node.hnNext;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{now all the data has been transferred, we can
|
||||
destroy the old table}
|
||||
if (OldHeads <> nil) then begin
|
||||
for HInx := 0 to pred(OldSize) do begin
|
||||
Node := OldHeads^[HInx];
|
||||
while Assigned(Node) do begin
|
||||
Temp := Node;
|
||||
Node := Node.hnNext;
|
||||
Temp.Free;
|
||||
end;
|
||||
end;
|
||||
FreeMem(OldHeads, OldSize * sizeof(TStHashNode));
|
||||
end;
|
||||
if (OldTails <> nil) then
|
||||
FreeMem(OldTails, OldSize * sizeof(TStHashNode));
|
||||
|
||||
{restore the disposedata routines}
|
||||
DisposeData := OldDisposeData;
|
||||
OnDisposeData := OldOnDisposeData;
|
||||
|
||||
except
|
||||
{destroy the new data}
|
||||
if (htHeads <> nil) then begin
|
||||
for HInx := 0 to pred(FHashSize) do begin
|
||||
Node := htHeads^[HInx];
|
||||
while Assigned(Node) do begin
|
||||
Temp := Node;
|
||||
Node := Node.hnNext;
|
||||
Temp.Free;
|
||||
end;
|
||||
end;
|
||||
FreeMem(htHeads, TableSize);
|
||||
end;
|
||||
if (htTails <> nil) then
|
||||
FreeMem(htTails, TableSize);
|
||||
{restore the old data}
|
||||
htHeads := OldHeads;
|
||||
htTails := OldTails;
|
||||
FHashSize := OldSize;
|
||||
FCount := OldCount;
|
||||
DisposeData := OldDisposeData;
|
||||
OnDisposeData := OldOnDisposeData;
|
||||
{reraise the exception}
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htSetMaxNodes(Nodes : LongInt);
|
||||
begin
|
||||
if Nodes < 1 then
|
||||
RaiseContainerError(stscBadSize);
|
||||
FMaxNodes := Nodes;
|
||||
while FCount > FMaxNodes do
|
||||
htDeleteOldestNode;
|
||||
end;
|
||||
|
||||
type
|
||||
TMinNode = record
|
||||
MLRU : LongInt;
|
||||
MNode : TStHashNode;
|
||||
end;
|
||||
PMinNode = ^TMinNode;
|
||||
|
||||
function FindMinPositiveNode(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
{-Used to find the smallest non-negative LRU in the table}
|
||||
begin
|
||||
with PMinNode(OtherData)^, TStHashNode(Node) do
|
||||
if (LRU >= 0) and (LRU <= MLRU) then begin
|
||||
MLRU := LRU;
|
||||
MNode := TStHashNode(Node);
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function NegateNodeLRU(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
{-Used to negate the LRU values of all nodes in the table}
|
||||
begin
|
||||
with TStHashNode(Node) do
|
||||
LRU := -LRU;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.htUpdateLRU(This : TStHashNode);
|
||||
{-Reassign all LRU values sequentially in their existing order}
|
||||
var
|
||||
MinNode : TMinNode;
|
||||
begin
|
||||
inc(htLRU);
|
||||
This.LRU := htLRU;
|
||||
if htLRU = MaxLongInt then begin
|
||||
{scan table and pack LRU values}
|
||||
htLRU := 0;
|
||||
repeat
|
||||
inc(htLRU);
|
||||
MinNode.MLRU := MaxLongInt;
|
||||
MinNode.MNode := nil;
|
||||
Iterate(FindMinPositiveNode, @MinNode);
|
||||
if not Assigned(MinNode.MNode) then
|
||||
break;
|
||||
{nodes already visited are set to a negative value}
|
||||
{depends on never having an LRU of zero}
|
||||
MinNode.MNode.LRU := -htLRU;
|
||||
until False;
|
||||
{negative values are made positive}
|
||||
Iterate(NegateNodeLRU, nil);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TStHashTable.Iterate(Action : TIterateFunc;
|
||||
OtherData : Pointer) : TStHashNode;
|
||||
var
|
||||
H : Integer;
|
||||
P : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htIterate(Action, OtherData, H, P, Result);
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function JoinNode(Container : TStContainer;
|
||||
Node : TStNode;
|
||||
OtherData : Pointer) : Boolean; far;
|
||||
{-Used to add nodes from another table into this one}
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
Result := True;
|
||||
with TStHashTable(OtherData) do begin
|
||||
htFindNode(TStHashNode(Node).Value^, H, P, T);
|
||||
if Assigned(T) then
|
||||
if htIgnoreDups then begin
|
||||
Node.Free;
|
||||
Exit;
|
||||
end else
|
||||
RaiseContainerError(stscDupNode);
|
||||
htInsertNode(H, TStHashNode(Node));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStHashTable.Join(H : TStHashTable; IgnoreDups : Boolean);
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterClassCS;
|
||||
EnterCS;
|
||||
H.EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htIgnoreDups := IgnoreDups;
|
||||
H.Iterate(JoinNode, Self);
|
||||
{dispose of D, but not its nodes}
|
||||
H.IncNodeProtection;
|
||||
H.Free;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
H.LeaveCS;
|
||||
LeaveCS;
|
||||
LeaveClassCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.LoadFromStream(S : TStream);
|
||||
var
|
||||
Data, Value : Pointer;
|
||||
AValSize : Cardinal;
|
||||
Reader : TReader;
|
||||
StreamedClass : TPersistentClass;
|
||||
StreamedNodeClass : TPersistentClass;
|
||||
StreamedClassName : string;
|
||||
StreamedNodeClassName : string;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
Clear;
|
||||
Reader := TReader.Create(S, 1024);
|
||||
try
|
||||
with Reader do begin
|
||||
StreamedClassName := ReadString;
|
||||
StreamedClass := GetClass(StreamedClassName);
|
||||
if not Assigned(StreamedClass) then
|
||||
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
|
||||
if (StreamedClass <> Self.ClassType) then
|
||||
RaiseContainerError(stscWrongClass);
|
||||
StreamedNodeClassName := ReadString;
|
||||
StreamedNodeClass := GetClass(StreamedNodeClassName);
|
||||
if not Assigned(StreamedNodeClass) then
|
||||
RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
|
||||
if (StreamedNodeClass <> conNodeClass) then
|
||||
RaiseContainerError(stscWrongNodeClass);
|
||||
|
||||
AValSize := ReadInteger;
|
||||
if AValSize <> FValSize then
|
||||
RaiseContainerError(stscBadSize);
|
||||
HashSize := ReadInteger;
|
||||
FMaxNodes := ReadInteger;
|
||||
GetMem(Value, FValSize);
|
||||
try
|
||||
ReadListBegin;
|
||||
while not EndOfList do begin
|
||||
ReadBoolean;
|
||||
Read(Value^, FValSize);
|
||||
Data := DoLoadData(Reader);
|
||||
Add(Value^, Data);
|
||||
end;
|
||||
ReadListEnd;
|
||||
finally
|
||||
FreeMem(Value, FValSize);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Reader.Free;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.NodeRemoved(const V; Data : Pointer);
|
||||
begin
|
||||
{does nothing by default}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.StoreToStream(S : TStream);
|
||||
var
|
||||
H : Integer;
|
||||
Walker : TStHashNode;
|
||||
Writer : TWriter;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
Writer := TWriter.Create(S, 1024);
|
||||
try
|
||||
with Writer do begin
|
||||
WriteString(Self.ClassName);
|
||||
WriteString(conNodeClass.ClassName);
|
||||
WriteInteger(FValSize);
|
||||
WriteInteger(FHashSize);
|
||||
WriteInteger(FMaxNodes);
|
||||
WriteListBegin;
|
||||
if Count <> 0 then
|
||||
for H := 0 to FHashSize-1 do begin
|
||||
Walker := htHeads^[H];
|
||||
while Assigned(Walker) do begin
|
||||
{writing the True boolean prevents false termination of the
|
||||
list if Value's first byte is zero when the stream is
|
||||
loaded into another hash table}
|
||||
WriteBoolean(True);
|
||||
Write(Walker.Value^, FValSize);
|
||||
DoStoreData(Writer, Walker.Data);
|
||||
Walker := Walker.hnNext;
|
||||
end;
|
||||
end;
|
||||
WriteListEnd;
|
||||
end;
|
||||
finally
|
||||
Writer.Free;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TStHashTable.Update(const V; Data : Pointer);
|
||||
var
|
||||
H : Integer;
|
||||
P, T : TStHashNode;
|
||||
begin
|
||||
{$IFDEF ThreadSafe}
|
||||
EnterCS;
|
||||
try
|
||||
{$ENDIF}
|
||||
htFindNode(V, H, P, T);
|
||||
if Assigned(T) then begin
|
||||
htMoveToFront(H, P, T);
|
||||
htUpdateLRU(T);
|
||||
T.Data := Data;
|
||||
end;
|
||||
{$IFDEF ThreadSafe}
|
||||
finally
|
||||
LeaveCS;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{$IFDEF ThreadSafe}
|
||||
initialization
|
||||
Windows.InitializeCriticalSection(ClassCritSect);
|
||||
finalization
|
||||
Windows.DeleteCriticalSection(ClassCritSect);
|
||||
{$ENDIF}
|
||||
end.
|
||||
594
components/systools/source/run/stinistm.pas
Normal file
594
components/systools/source/run/stinistm.pas
Normal file
@@ -0,0 +1,594 @@
|
||||
// Upgraded to Delphi 2009: Sebastian Zierer
|
||||
// FIXME: TStAnsiTextStream
|
||||
|
||||
(* ***** 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StIniStm.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: .INI file-like stream class *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$include StDefine.inc}
|
||||
|
||||
unit StIniStm;
|
||||
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, StStrms;
|
||||
|
||||
type
|
||||
|
||||
TStIniStream = class(TObject)
|
||||
private
|
||||
FAnsiStream : TStAnsiTextStream;
|
||||
FSections : TStringList;
|
||||
procedure GetSecStrings(Strs: TStrings);
|
||||
protected
|
||||
procedure GotoSection(const Section : String);
|
||||
procedure UpdateSections;
|
||||
procedure WriteSectionName(const Section : String);
|
||||
procedure WriteValue(const Key, Value : String);
|
||||
public
|
||||
constructor Create(aStream : TStream);
|
||||
destructor Destroy; override;
|
||||
|
||||
function SectionExists(const Section : String): Boolean;
|
||||
function ReadString(const Section, Ident, Default : String) : String;
|
||||
procedure WriteString(const Section, Ident, Value : String);
|
||||
procedure WriteSection(const Section : String; Strings: TStrings);
|
||||
procedure ReadSection(const Section : String; Strings: TStrings);
|
||||
procedure ReadSections(Strings: TStrings);
|
||||
procedure ReadSectionValues(const Section : String; Strings: TStrings);
|
||||
procedure EraseSection(const Section : String);
|
||||
procedure DeleteKey(const Section, Ident : String);
|
||||
function ValueExists(const Section, Ident : String): Boolean;
|
||||
end;
|
||||
|
||||
procedure SplitNameValue(const Line : string; var Name, Value : string); {!!.04}
|
||||
|
||||
implementation
|
||||
|
||||
{!!.04 - Added }
|
||||
procedure SplitNameValue(const Line : string; var Name, Value : string);
|
||||
var
|
||||
P : Integer;
|
||||
begin
|
||||
P := Pos('=', Line);
|
||||
if P < 1 then begin
|
||||
Name := Line;
|
||||
Value := '';
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Name := Copy(Line, 1, P-1);
|
||||
Value := Copy(Line, P+1, Length(Line) - P);
|
||||
end;
|
||||
{!!.04 - Added End}
|
||||
|
||||
function IsHeader(const AString : String) : Boolean;
|
||||
{ see if passed in text looks like an .INI header }
|
||||
var
|
||||
Temp : String;
|
||||
begin
|
||||
if AString = '' then begin
|
||||
Result := False;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Temp := Trim(AString);
|
||||
Result := (Temp[1] = '[') and (Temp[Length(Temp)] = ']')
|
||||
end;
|
||||
|
||||
|
||||
{ TStIniStream }
|
||||
|
||||
constructor TStIniStream.Create(aStream: TStream);
|
||||
begin
|
||||
inherited Create;
|
||||
FAnsiStream := TStAnsiTextStream.Create(aStream);
|
||||
FSections := TStringList.Create;
|
||||
FSections.Sorted := True;
|
||||
FSections.Duplicates := dupIgnore;
|
||||
|
||||
if aStream.Size > 0 then { not an empty stream }
|
||||
UpdateSections;
|
||||
end;
|
||||
|
||||
destructor TStIniStream.Destroy;
|
||||
begin
|
||||
FSections.Free;
|
||||
FAnsiStream.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStIniStream.DeleteKey(const Section, Ident : String);
|
||||
{ delete specified item from Section }
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
SecIdx : Integer;
|
||||
MS : TMemoryStream;
|
||||
TS : TStAnsiTextStream;
|
||||
i, Idx : Integer;
|
||||
begin
|
||||
SecStrs := TStringList.Create;
|
||||
MS := TMemoryStream.Create;
|
||||
TS := TStAnsiTextStream.Create(MS);
|
||||
|
||||
try
|
||||
{ locate and read section }
|
||||
GotoSection(Section);
|
||||
GetSecStrings(SecStrs);
|
||||
Idx := SecStrs.IndexOfName(Ident);
|
||||
|
||||
if Idx > - 1 then begin
|
||||
{ remove desired key }
|
||||
SecStrs.Delete(Idx);
|
||||
|
||||
{ locate subsequent section }
|
||||
SecIdx := FSections.IndexOf(Section);
|
||||
if SecIdx < Pred(FSections.Count) then begin
|
||||
GotoSection(FSections[SecIdx+1]);
|
||||
|
||||
{ copy remaining sections }
|
||||
while not FAnsiStream.AtEndOfStream do
|
||||
TS.WriteLine(FAnsiStream.ReadLine);
|
||||
end;
|
||||
{ else this is the last section }
|
||||
|
||||
{ seek back and truncate }
|
||||
GotoSection(Section);
|
||||
FAnsiStream.Size := FAnsiStream.Position;
|
||||
// FAnsiStream.SetSize(FAnsiStream.Position);
|
||||
|
||||
{ write updated section }
|
||||
WriteSectionName(Section);
|
||||
for i := 0 to Pred(SecStrs.Count) do
|
||||
FAnsiStream.WriteLine(SecStrs[i]);
|
||||
FAnsiStream.Stream.Seek(0, soFromEnd);
|
||||
|
||||
{ append saved subsequent sections }
|
||||
TS.SeekLine(0);
|
||||
while not TS.AtEndOfStream do
|
||||
FAnsiStream.WriteLine(TS.ReadLine);
|
||||
|
||||
end; { if Ident > -1 }
|
||||
{ else the Ident doesn't exist so don't alter anything }
|
||||
|
||||
finally
|
||||
SecStrs.Free;
|
||||
TS.Free;
|
||||
MS.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStIniStream.EraseSection(const Section : String);
|
||||
{ erase specified section from Ini data }
|
||||
var
|
||||
SecIdx : Integer;
|
||||
MS : TMemoryStream;
|
||||
TS : TStAnsiTextStream;
|
||||
begin
|
||||
MS := TMemoryStream.Create;
|
||||
TS := TStAnsiTextStream.Create(MS);
|
||||
|
||||
{ locate section }
|
||||
SecIdx := FSections.IndexOf(Section);
|
||||
|
||||
{ if section found }
|
||||
if SectionExists(Section) then begin
|
||||
try
|
||||
{ if this is not the last section }
|
||||
if (SecIdx < Pred(FSections.Count)) then begin
|
||||
{ locate subsequent section }
|
||||
GotoSection(FSections[SecIdx+1]);
|
||||
|
||||
{ copy remaining sections to temporary stream}
|
||||
while not FAnsiStream.AtEndOfStream do
|
||||
TS.WriteLine(FAnsiStream.ReadLine);
|
||||
end;
|
||||
{ else this is the last section }
|
||||
|
||||
{ locate section to delete and truncate }
|
||||
GotoSection(Section);
|
||||
FAnsiStream.Size := FAnsiStream.Position;
|
||||
// FAnsiStream.SetSize(FAnsiStream.Position);
|
||||
|
||||
{ append saved subsequent sections }
|
||||
TS.SeekLine(0);
|
||||
while not TS.AtEndOfStream do
|
||||
FAnsiStream.WriteLine(TS.ReadLine);
|
||||
|
||||
finally
|
||||
TS.Free;
|
||||
MS.Free;
|
||||
end;
|
||||
UpdateSections;
|
||||
end;
|
||||
{ else section doesn't exist, do nothing }
|
||||
end;
|
||||
|
||||
procedure TStIniStream.GetSecStrings(Strs : TStrings);
|
||||
{ read strings from a section, preserving comments and blanks }
|
||||
var
|
||||
LineVal : String;
|
||||
begin
|
||||
{ assume we're at the start of a section }
|
||||
FAnsiStream.ReadLine; { skip section header }
|
||||
|
||||
LineVal := FAnsiStream.ReadLine;
|
||||
while not (FAnsiStream.AtEndOfStream) and not (IsHeader(LineVal)) do begin
|
||||
Strs.Add(LineVal); { add it to the list }
|
||||
LineVal := FAnsiStream.ReadLine; { get next line }
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStIniStream.GotoSection(const Section: String);
|
||||
{ position stream to requested section header }
|
||||
var
|
||||
Idx : Integer;
|
||||
begin
|
||||
Idx := FSections.IndexOf(Section);
|
||||
if Idx > -1 then
|
||||
FAnsiStream.SeekLine(Integer(FSections.Objects[Idx]));
|
||||
end;
|
||||
|
||||
procedure TStIniStream.ReadSectionValues(const Section : String;
|
||||
Strings: TStrings);
|
||||
{ return <Name>=<Value> pairs of requested Section in Strings }
|
||||
var
|
||||
Strs : TStringList;
|
||||
LineVal : String;
|
||||
i : Integer;
|
||||
begin
|
||||
if not Assigned(Strings) then Exit;
|
||||
|
||||
Strs := TStringList.Create;
|
||||
if SectionExists(Section) then begin { section exists }
|
||||
Strings.Clear;
|
||||
try
|
||||
{ locate section }
|
||||
GotoSection(Section);
|
||||
|
||||
{ retrieve section contents, comments, blank lines and all }
|
||||
GetSecStrings(Strs);
|
||||
|
||||
{ iterate section lines looking for entries }
|
||||
for i := 0 to Pred(Strs.Count) do begin
|
||||
LineVal := Strs[i];
|
||||
if (Trim(LineVal) <> '') and (Trim(LineVal[1]) <> ';') and (Pos('=', LineVal) > 0) then {!!.02}
|
||||
{ not empty and not a comment and at least superficially resembles a
|
||||
<Name>=<Value> pair }
|
||||
Strings.Add(Trim(LineVal)); { add it to the list } {!!.02}
|
||||
end;
|
||||
finally
|
||||
Strs.Free;
|
||||
end;
|
||||
end;
|
||||
{ else section doesn't exist, do nothing }
|
||||
end;
|
||||
|
||||
procedure TStIniStream.ReadSections(Strings: TStrings);
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
if not Assigned(Strings) then Exit;
|
||||
|
||||
{ omit the pseudo section }
|
||||
for i := 1 to Pred(FSections.Count) do
|
||||
Strings.Add(Trim(FSections[i])); {!!.02}
|
||||
end;
|
||||
|
||||
procedure TStIniStream.ReadSection(const Section : String;
|
||||
Strings: TStrings);
|
||||
{ return Name strings for all entries in requested section }
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
i : Integer;
|
||||
LineVal, Name : String;
|
||||
begin
|
||||
if not Assigned(Strings) then Exit;
|
||||
|
||||
SecStrs := TStringList.Create;
|
||||
try
|
||||
// ReadSection(Section, SecStrs);
|
||||
{!!.02 - Rewritten }
|
||||
Strings.Clear;
|
||||
{ locate section }
|
||||
GotoSection(Section);
|
||||
|
||||
{ retrieve section contents, comments, blank lines and all }
|
||||
GetSecStrings(SecStrs);
|
||||
|
||||
{ iterate section lines looking for entries }
|
||||
for i := 0 to Pred(SecStrs.Count) do begin
|
||||
LineVal := SecStrs[i];
|
||||
if (Trim(LineVal) <> '') and (Trim(LineVal[1]) <> ';') and (Pos('=', LineVal) > 0) then begin
|
||||
{ not empty and not a comment and at least superficially resembles a
|
||||
<Name>=<Value> pair }
|
||||
SplitNameValue(LineVal, Name, LineVal);
|
||||
Strings.Add(Trim(Name));
|
||||
end;
|
||||
end;
|
||||
|
||||
// for i := 0 to Pred(SecStrs.Count) do
|
||||
// Strings.Add(SecStrs.Names[i]);
|
||||
{!!.02 - Rewritten End }
|
||||
|
||||
|
||||
finally
|
||||
SecStrs.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TStIniStream.ReadString(const Section, Ident,
|
||||
Default : String) : String;
|
||||
{
|
||||
return a particular string selected by Ident from Section
|
||||
if empty or doesn't exist, return Default
|
||||
}
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
begin
|
||||
SecStrs := TStringList.Create;
|
||||
try
|
||||
ReadSectionValues(Section, SecStrs); {!!.04}
|
||||
|
||||
Result := SecStrs.Values[Ident];
|
||||
if Result = '' then
|
||||
Result := Default;
|
||||
|
||||
finally
|
||||
SecStrs.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TStIniStream.SectionExists(const Section : String): Boolean;
|
||||
{ returns True if Section exists in section list, False otherwise }
|
||||
begin
|
||||
Result := FSections.IndexOf(Section) > -1;
|
||||
end;
|
||||
|
||||
procedure TStIniStream.UpdateSections;
|
||||
{ refresh Sections list }
|
||||
var
|
||||
i : Integer;
|
||||
Line : String;
|
||||
begin
|
||||
i := 0;
|
||||
FSections.Clear;
|
||||
FAnsiStream.SeekLine(0);
|
||||
|
||||
{ pseudo section to account for any comments or whitespace prior to first
|
||||
real section in data }
|
||||
FSections.AddObject('[]', TObject(0));
|
||||
|
||||
{ iterate data looking for section headers: '[blah]' }
|
||||
while not FAnsiStream.AtEndOfStream do begin
|
||||
Line := Trim(FAnsiStream.ReadLine);
|
||||
{ if it looks like a header }
|
||||
if IsHeader(Line) then
|
||||
{ add it to the list with a line index }
|
||||
FSections.AddObject(Copy(Line, 2, Length(Line) - 2), TObject(i));
|
||||
{ go to next line }
|
||||
Inc(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TStIniStream.ValueExists(const Section, Ident : String): Boolean;
|
||||
{
|
||||
see if requested section contains requested Ident
|
||||
implies "<Ident>=" exists in section, not that there's necessarily any
|
||||
explicit Value associated, i.e. Value may be blank
|
||||
}
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
i : Integer;
|
||||
begin
|
||||
Result := False;
|
||||
SecStrs := TStringList.Create;
|
||||
try
|
||||
{ get section }
|
||||
ReadSection(Section, SecStrs);
|
||||
|
||||
{ see if Ident exists in Names collection }
|
||||
for i := 0 to Pred(SecStrs.Count) do
|
||||
if SecStrs.Names[i] = Ident then begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
finally
|
||||
SecStrs.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TStIniStream.WriteString(const Section, Ident, Value : String);
|
||||
{ write individual string value to IniStream }
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
SecIdx : Integer;
|
||||
MS : TMemoryStream;
|
||||
TS : TStAnsiTextStream;
|
||||
i : Integer;
|
||||
begin
|
||||
if SectionExists(Section) then begin
|
||||
SecStrs := TStringList.Create;
|
||||
MS := TMemoryStream.Create;
|
||||
TS := TStAnsiTextStream.Create(MS);
|
||||
|
||||
try
|
||||
{ locate and read section }
|
||||
GotoSection(Section);
|
||||
GetSecStrings(SecStrs);
|
||||
|
||||
{ locate subsequent section }
|
||||
SecIdx := FSections.IndexOf(Section);
|
||||
if SecIdx < Pred(FSections.Count) then begin
|
||||
GotoSection(FSections[SecIdx+1]);
|
||||
|
||||
{ copy remaining sections }
|
||||
while not FAnsiStream.AtEndOfStream do
|
||||
TS.WriteLine(FAnsiStream.ReadLine);
|
||||
end;
|
||||
{ else this is the last section }
|
||||
|
||||
{ seek back and truncate }
|
||||
GotoSection(Section);
|
||||
FAnsiStream.Size := FAnsiStream.Position;
|
||||
|
||||
// FAnsiStream.SetSize(FAnsiStream.Position);
|
||||
|
||||
{ insert new value }
|
||||
SecStrs.Add(Ident + '=' + Value);
|
||||
|
||||
{ write updated section }
|
||||
WriteSectionName(Section);
|
||||
for i := 0 to Pred(SecStrs.Count) do
|
||||
FAnsiStream.WriteLine(SecStrs[i]);
|
||||
FAnsiStream.Stream.Seek(0, soFromEnd);
|
||||
|
||||
{ append saved subsequent sections }
|
||||
TS.SeekLine(0);
|
||||
while not TS.AtEndOfStream do
|
||||
FAnsiStream.WriteLine(TS.ReadLine);
|
||||
|
||||
finally
|
||||
SecStrs.Free;
|
||||
TS.Free;
|
||||
MS.Free;
|
||||
end;
|
||||
|
||||
end
|
||||
else begin { no such section exists, append new one }
|
||||
FAnsiStream.Seek(0, soFromEnd);
|
||||
WriteSectionName(Section);
|
||||
WriteValue(Ident, Value);
|
||||
UpdateSections;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TStIniStream.WriteSectionName(const Section: String);
|
||||
{ write section header at current location }
|
||||
begin
|
||||
FAnsiStream.WriteLine('[' + Section + ']');
|
||||
end;
|
||||
|
||||
procedure TStIniStream.WriteValue(const Key, Value: String);
|
||||
{ write <Name>=<Value> pair at current location }
|
||||
begin
|
||||
FAnsiStream.WriteLine(Key + '=' + Value);
|
||||
end;
|
||||
|
||||
procedure TStIniStream.WriteSection(const Section: String;
|
||||
Strings: TStrings);
|
||||
{ write entire section described by Strings }
|
||||
var
|
||||
SecStrs : TStringList;
|
||||
SecIdx : Integer;
|
||||
MS : TMemoryStream;
|
||||
TS : TStAnsiTextStream;
|
||||
i : Integer;
|
||||
L : LongInt;
|
||||
Name : String;
|
||||
begin
|
||||
if not Assigned(Strings) then Exit;
|
||||
|
||||
if SectionExists(Section) then begin
|
||||
SecStrs := TStringList.Create;
|
||||
MS := TMemoryStream.Create;
|
||||
TS := TStAnsiTextStream.Create(MS);
|
||||
|
||||
try
|
||||
{ locate and read section }
|
||||
GotoSection(Section);
|
||||
GetSecStrings(SecStrs);
|
||||
|
||||
{ locate subsequent section }
|
||||
SecIdx := FSections.IndexOf(Section);
|
||||
if SecIdx < Pred(FSections.Count) then begin
|
||||
GotoSection(FSections[SecIdx+1]);
|
||||
|
||||
{ copy remaining sections }
|
||||
while not FAnsiStream.AtEndOfStream do
|
||||
TS.WriteLine(FAnsiStream.ReadLine);
|
||||
end;
|
||||
{ else this is the last section }
|
||||
|
||||
{ seek back and truncate }
|
||||
GotoSection(Section);
|
||||
FAnsiStream.Size := FAnsiStream.Position;
|
||||
// FAnsiStream.SetSize(FAnsiStream.Position);
|
||||
|
||||
{ update section }
|
||||
for i := 0 to Pred(Strings.Count) do begin
|
||||
Name := Strings.Names[i];
|
||||
if SecStrs.IndexOfName(Name) > -1 then { entry exists, change value }
|
||||
SecStrs.Values[Name] := Strings.Values[Name]
|
||||
else { new entry, just append it }
|
||||
SecStrs.Add(Strings[i]);
|
||||
end;
|
||||
|
||||
{ write updated section }
|
||||
WriteSectionName(Section);
|
||||
for i := 0 to Pred(SecStrs.Count) do
|
||||
FAnsiStream.WriteLine(SecStrs[i]);
|
||||
FAnsiStream.Stream.Seek(0, soFromEnd);
|
||||
|
||||
{ append saved subsequent sections }
|
||||
TS.SeekLine(0);
|
||||
while not TS.AtEndOfStream do
|
||||
FAnsiStream.WriteLine(TS.ReadLine);
|
||||
|
||||
finally
|
||||
SecStrs.Free;
|
||||
TS.Free;
|
||||
MS.Free;
|
||||
end;
|
||||
|
||||
end
|
||||
else begin { no such section exists, append new one }
|
||||
L := FAnsiStream.LineCount;
|
||||
FAnsiStream.Seek(0, soFromEnd);
|
||||
WriteSectionName(Section);
|
||||
FSections.AddObject(Section, TObject(L+1));
|
||||
for i := 0 to Pred(Strings.Count) do
|
||||
FAnsiStream.WriteLine(Strings[i]);
|
||||
// UpdateSections;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
175
components/systools/source/run/stmath.pas
Normal file
175
components/systools/source/run/stmath.pas
Normal file
@@ -0,0 +1,175 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StMath.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Miscellaneous math functions *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$I StDefine.inc}
|
||||
|
||||
unit StMath;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, StDate, StBase, StConst;
|
||||
|
||||
const
|
||||
RadCor : Double = 57.29577951308232; {number of degrees in a radian}
|
||||
|
||||
{$IFNDEF UseMathUnit}
|
||||
function IntPower(Base : Extended; Exponent : Integer): Extended;
|
||||
{-Raise Base to an integral power Exponent}
|
||||
|
||||
function Power(Base, Exponent : Extended) : Extended;
|
||||
{-Raise Base to an arbitrary power Exponent}
|
||||
{$ENDIF}
|
||||
|
||||
function StInvCos(X : Double): Double;
|
||||
{-Returns the ArcCos of Y}
|
||||
|
||||
function StInvSin(Y : Double): Double;
|
||||
{-Returns the ArcSin of Y}
|
||||
|
||||
function StInvTan2(X, Y : Double) : Double;
|
||||
{-Returns the ArcTangent of Y / X}
|
||||
|
||||
function StTan(A : Double) : Double;
|
||||
{-Returns the Tangent of A}
|
||||
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFNDEF UseMathUnit}
|
||||
function IntPower(Base : Extended; Exponent : Integer): Extended;
|
||||
var
|
||||
Y : Integer;
|
||||
begin
|
||||
Y := Abs(Exponent);
|
||||
Result := 1;
|
||||
while (Y > 0) do begin
|
||||
while (not Odd(Y)) do begin
|
||||
Y := Y shr 1;
|
||||
Base := Base * Base;
|
||||
end;
|
||||
Dec(Y);
|
||||
Result := Result * Base;
|
||||
end;
|
||||
if (Exponent < 0) then
|
||||
Result := 1 / Result;
|
||||
end;
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
function Power(Base, Exponent: Extended): Extended;
|
||||
begin
|
||||
if (Exponent = 0) then
|
||||
Result := 1
|
||||
else if (Base = 0) and (Exponent > 0) then
|
||||
Result := 0
|
||||
else if (Frac(Exponent) = 0) and (Abs(Exponent) <= MaxInt) then
|
||||
Result := IntPower(Base, Trunc(Exponent))
|
||||
else
|
||||
Result := Exp(Exponent * Ln(Base));
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
function StTan(A : Double) : Double;
|
||||
var
|
||||
C, S : Double;
|
||||
begin
|
||||
C := Cos(A);
|
||||
S := Sin(A);
|
||||
if (Abs(C) >= 5E-12) then
|
||||
Result := S / C
|
||||
else if (C < 0) then
|
||||
Result := 5.0e-324
|
||||
else
|
||||
Result := 1.7e+308;
|
||||
end;
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
function StInvTan2(X, Y : Double) : Double;
|
||||
begin
|
||||
if (Abs(X) < 5.0E-12) then begin
|
||||
if (X < 0) then
|
||||
Result := 3 * Pi / 2
|
||||
else
|
||||
Result := Pi / 2;
|
||||
end else begin
|
||||
Result := ArcTan(Y / X);
|
||||
if (X < 0) then
|
||||
Result := Result + Pi
|
||||
else if (Y < 0) then
|
||||
Result := Result + 2 * Pi;
|
||||
end;
|
||||
end;
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
function StInvSin(Y : Double): Double;
|
||||
begin
|
||||
if (Abs(Abs(Y) - 1) > 5.0E-12) then
|
||||
Result := ArcTan(Y / Sqrt(1 - Y * Y))
|
||||
else begin
|
||||
if (Y < 0) then
|
||||
Result := 3 * Pi / 2
|
||||
else
|
||||
Result := Pi / 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
{-------------------------------------------------------}
|
||||
|
||||
function StInvCos(X : Double): Double;
|
||||
begin
|
||||
if (Abs(Abs(X) - 1) > 5.0E-12) then
|
||||
Result := (90 / RadCor) - ArcTan(X / Sqrt(1 - X * X))
|
||||
else begin
|
||||
if ((X - Pi / 2) > 0) then
|
||||
Result := 0
|
||||
else
|
||||
Result := Pi;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
1530
components/systools/source/run/stmoney.pas
Normal file
1530
components/systools/source/run/stmoney.pas
Normal file
File diff suppressed because it is too large
Load Diff
3557
components/systools/source/run/ststrl.pas
Normal file
3557
components/systools/source/run/ststrl.pas
Normal file
File diff suppressed because it is too large
Load Diff
1424
components/systools/source/run/ststrms.pas
Normal file
1424
components/systools/source/run/ststrms.pas
Normal file
File diff suppressed because it is too large
Load Diff
3408
components/systools/source/run/ststrs.pas
Normal file
3408
components/systools/source/run/ststrs.pas
Normal file
File diff suppressed because it is too large
Load Diff
963
components/systools/source/run/sttohtml.pas
Normal file
963
components/systools/source/run/sttohtml.pas
Normal file
@@ -0,0 +1,963 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StToHTML.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: HTML Text Formatter *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
//{$I StDefine.inc}
|
||||
|
||||
unit StToHTML;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
||||
StStrms, StBase;
|
||||
|
||||
type
|
||||
TStOnProgressEvent = procedure(Sender : TObject; Percent : Word) of object;
|
||||
|
||||
TStStreamToHTML = class(TObject)
|
||||
protected {private}
|
||||
{ Private declarations }
|
||||
FCaseSensitive : Boolean;
|
||||
FCommentMarkers : TStringList;
|
||||
FEmbeddedHTML : TStringList;
|
||||
FInFileSize : Cardinal;
|
||||
FInFixedLineLen : integer;
|
||||
FInLineTermChar : Char;
|
||||
FInLineTerminator: TStLineTerminator;
|
||||
FInputStream : TStream;
|
||||
FInSize : Cardinal;
|
||||
FInTextStream : TStAnsiTextStream;
|
||||
FIsCaseSensitive : Boolean;
|
||||
FKeywords : TStringList;
|
||||
FOnProgress : TStOnProgressEvent;
|
||||
FOutputStream : TStream;
|
||||
FOutTextStream : TStAnsiTextStream;
|
||||
FPageFooter : TStringList;
|
||||
FPageHeader : TStringList;
|
||||
FStringMarkers : TStringList;
|
||||
FWordDelims : String;
|
||||
protected
|
||||
{ Protected declarations }
|
||||
|
||||
{internal methods}
|
||||
function ParseBuffer : Boolean;
|
||||
|
||||
procedure SetCommentMarkers(Value : TStringList);
|
||||
procedure SetEmbeddedHTML(Value : TStringList);
|
||||
procedure SetKeywords(Value : TStringList);
|
||||
procedure SetPageFooter(Value : TStringList);
|
||||
procedure SetPageHeader(Value : TStringList);
|
||||
procedure SetStringMarkers(Value : TStringList);
|
||||
|
||||
public
|
||||
{ Public declarations }
|
||||
|
||||
property CaseSensitive : Boolean
|
||||
read FCaseSensitive
|
||||
write FCaseSensitive;
|
||||
|
||||
property CommentMarkers : TStringList
|
||||
read FCommentMarkers
|
||||
write SetCommentMarkers;
|
||||
|
||||
property EmbeddedHTML : TStringList
|
||||
read FEmbeddedHTML
|
||||
write SetEmbeddedHTML;
|
||||
|
||||
property InFixedLineLength : integer
|
||||
read FInFixedLineLen
|
||||
write FInFixedLineLen;
|
||||
|
||||
property InLineTermChar : Char
|
||||
read FInLineTermChar
|
||||
write FInLineTermChar;
|
||||
|
||||
property InLineTerminator : TStLineTerminator
|
||||
read FInLineTerminator
|
||||
write FInLineTerminator;
|
||||
|
||||
property InputStream : TStream
|
||||
read FInputStream
|
||||
write FInputStream;
|
||||
|
||||
property Keywords : TStringList
|
||||
read FKeywords
|
||||
write SetKeywords;
|
||||
|
||||
property OnProgress : TStOnProgressEvent
|
||||
read FOnProgress
|
||||
write FOnProgress;
|
||||
|
||||
property OutputStream : TStream
|
||||
read FOutputStream
|
||||
write FOutputStream;
|
||||
|
||||
property PageFooter : TStringList
|
||||
read FPageFooter
|
||||
write SetPageFooter;
|
||||
|
||||
property PageHeader : TStringList
|
||||
read FPageHeader
|
||||
write SetPageHeader;
|
||||
|
||||
property StringMarkers : TStringList
|
||||
read FStringMarkers
|
||||
write SetStringMarkers;
|
||||
|
||||
property WordDelimiters : String
|
||||
read FWordDelims
|
||||
write FWordDelims;
|
||||
|
||||
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure GenerateHTML;
|
||||
end;
|
||||
|
||||
|
||||
TStFileToHTML = class(TStComponent)
|
||||
protected {private}
|
||||
{ Private declarations }
|
||||
|
||||
FCaseSensitive : Boolean;
|
||||
FCommentMarkers : TStringList;
|
||||
FEmbeddedHTML : TStringList;
|
||||
FInFile : TFileStream;
|
||||
FInFileName : String;
|
||||
FInLineLength : integer;
|
||||
FInLineTermChar : Char;
|
||||
FInLineTerminator : TStLineTerminator;
|
||||
FKeywords : TStringList;
|
||||
FOnProgress : TStOnProgressEvent;
|
||||
FOutFile : TFileStream;
|
||||
FOutFileName : String;
|
||||
FPageFooter : TStringList;
|
||||
FPageHeader : TStringList;
|
||||
FStream : TStStreamToHTML;
|
||||
FStringMarkers : TStringList;
|
||||
FWordDelims : String;
|
||||
|
||||
protected
|
||||
|
||||
procedure SetCommentMarkers(Value : TStringList);
|
||||
procedure SetEmbeddedHTML(Value : TStringList);
|
||||
procedure SetKeywords(Value : TStringList);
|
||||
procedure SetPageFooter(Value : TStringList);
|
||||
procedure SetPageHeader(Value : TStringList);
|
||||
procedure SetStringMarkers(Value : TStringList);
|
||||
|
||||
public
|
||||
constructor Create(AOwner : TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Execute;
|
||||
|
||||
published
|
||||
property CaseSensitive : Boolean
|
||||
read FCaseSensitive
|
||||
write FCaseSensitive default False;
|
||||
|
||||
property CommentMarkers : TStringList
|
||||
read FCommentMarkers
|
||||
write SetCommentMarkers;
|
||||
|
||||
property EmbeddedHTML : TStringList
|
||||
read FEmbeddedHTML
|
||||
write SetEmbeddedHTML;
|
||||
|
||||
property InFileName : String
|
||||
read FInFileName
|
||||
write FInFileName;
|
||||
|
||||
property InFixedLineLength : integer
|
||||
read FInLineLength
|
||||
write FInLineLength default 80;
|
||||
|
||||
property InLineTermChar : Char
|
||||
read FInLineTermChar
|
||||
write FInLineTermChar default #10;
|
||||
|
||||
property InLineTerminator : TStLineTerminator
|
||||
read FInLineTerminator
|
||||
write FInLineTerminator default ltCRLF;
|
||||
|
||||
property Keywords : TStringList
|
||||
read FKeywords
|
||||
write SetKeywords;
|
||||
|
||||
property OnProgress : TStOnProgressEvent
|
||||
read FOnProgress
|
||||
write FOnProgress;
|
||||
|
||||
property OutFileName : String
|
||||
read FOutFileName
|
||||
write FOutFileName;
|
||||
|
||||
property PageFooter : TStringList
|
||||
read FPageFooter
|
||||
write SetPageFooter;
|
||||
|
||||
property PageHeader : TStringList
|
||||
read FPageHeader
|
||||
write SetPageHeader;
|
||||
|
||||
property StringMarkers : TStringList
|
||||
read FStringMarkers
|
||||
write SetStringMarkers;
|
||||
|
||||
property WordDelimiters : String
|
||||
read FWordDelims
|
||||
write FWordDelims;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
StConst,
|
||||
StDict;
|
||||
|
||||
|
||||
(*****************************************************************************)
|
||||
(* TStStreamToHTML Implementation *)
|
||||
(*****************************************************************************)
|
||||
|
||||
constructor TStStreamToHTML.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
FCommentMarkers := TStringList.Create;
|
||||
FEmbeddedHTML := TStringList.Create;
|
||||
FKeywords := TStringList.Create;
|
||||
FPageFooter := TStringList.Create;
|
||||
FPageHeader := TStringList.Create;
|
||||
FStringMarkers := TStringList.Create;
|
||||
|
||||
FInputStream := nil;
|
||||
FOutputStream := nil;
|
||||
|
||||
FInFileSize := 0;
|
||||
FWordDelims := ',; .()';
|
||||
|
||||
FInLineTerminator := ltCRLF; {normal Windows text file terminator}
|
||||
FInLineTermChar := #10;
|
||||
FInFixedLineLen := 80;
|
||||
|
||||
with FEmbeddedHTML do begin
|
||||
Add('"="');
|
||||
Add('&=&');
|
||||
Add('<=<');
|
||||
Add('>=>');
|
||||
Add('�=¡');
|
||||
Add('�=¢');
|
||||
Add('�=£');
|
||||
Add('�=©');
|
||||
Add('�=®');
|
||||
Add('�=±');
|
||||
Add('�=¼');
|
||||
Add('�=½');
|
||||
Add('�=¾');
|
||||
Add('�=÷');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TStStreamToHTML.Destroy;
|
||||
begin
|
||||
FCommentMarkers.Free;
|
||||
FCommentMarkers := nil;
|
||||
|
||||
FEmbeddedHTML.Free;
|
||||
FEmbeddedHTML := nil;
|
||||
|
||||
FKeywords.Free;
|
||||
FKeywords := nil;
|
||||
|
||||
FPageFooter.Free;
|
||||
FPageFooter := nil;
|
||||
|
||||
FPageHeader.Free;
|
||||
FPageHeader := nil;
|
||||
|
||||
FStringMarkers.Free;
|
||||
FStringMarkers := nil;
|
||||
|
||||
FInTextStream.Free;
|
||||
FInTextStream := nil;
|
||||
|
||||
FOutTextStream.Free;
|
||||
FOutTextStream := nil;
|
||||
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.GenerateHTML;
|
||||
begin
|
||||
if not ((Assigned(FInputStream) and (Assigned(FOutputStream)))) then
|
||||
RaiseStError(EStToHTMLError, stscBadStream)
|
||||
else
|
||||
ParseBuffer;
|
||||
end;
|
||||
|
||||
|
||||
procedure DisposeString(Data : Pointer); far;
|
||||
begin
|
||||
Dispose(PString(Data));
|
||||
end;
|
||||
|
||||
|
||||
function TStStreamToHTML.ParseBuffer : Boolean;
|
||||
var
|
||||
I, J,
|
||||
P1,
|
||||
P2,
|
||||
BRead,
|
||||
PC : Longint;
|
||||
CloseStr,
|
||||
SStr,
|
||||
EStr,
|
||||
S,
|
||||
VS,
|
||||
AStr,
|
||||
TmpStr : String;
|
||||
P : Pointer;
|
||||
PS : PString;
|
||||
CommentDict : TStDictionary;
|
||||
HTMLDict : TStDictionary;
|
||||
KeywordsDict : TStDictionary;
|
||||
StringDict : TStDictionary;
|
||||
CommentPend : Boolean;
|
||||
|
||||
function ConvertEmbeddedHTML(const Str2 : String) : String;
|
||||
var
|
||||
L,
|
||||
J : Longint;
|
||||
PH : Pointer;
|
||||
begin
|
||||
Result := '';
|
||||
{avoid memory reallocations}
|
||||
SetLength(Result, 1024);
|
||||
J := 1;
|
||||
for L := 1 to Length(Str2) do begin
|
||||
if (not HTMLDict.Exists(Str2[L], PH)) then begin
|
||||
Result[J] := Str2[L];
|
||||
Inc(J);
|
||||
end else begin
|
||||
Move(String(PH^)[1], Result[J], Length(String(PH^)) * SizeOf(Char));
|
||||
Inc(J, Length(String(PH^)));
|
||||
end;
|
||||
end;
|
||||
Dec(J);
|
||||
SetLength(Result, J);
|
||||
end;
|
||||
|
||||
procedure CheckSubString(const Str1 : String);
|
||||
var
|
||||
S2 : String;
|
||||
begin
|
||||
if (KeywordsDict.Exists(Str1, P)) then begin
|
||||
VS := String(P^);
|
||||
S2 := Copy(VS, 1, pos(';', VS)-1)
|
||||
+ ConvertEmbeddedHTML(Str1)
|
||||
+ Copy(VS, pos(';', VS)+1, Length(VS));
|
||||
if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
|
||||
S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
|
||||
end else begin
|
||||
S2 := ConvertEmbeddedHTML(Str1);
|
||||
if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
|
||||
S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
|
||||
end;
|
||||
S := S + S2;
|
||||
end;
|
||||
|
||||
begin
|
||||
if (Length(FWordDelims) = 0) then
|
||||
RaiseStError(EStToHTMLError, stscWordDelimiters);
|
||||
|
||||
{create Dictionaries for lookups}
|
||||
CommentDict := TStDictionary.Create(FCommentMarkers.Count+1);
|
||||
KeywordsDict := TStDictionary.Create(FKeywords.Count+1);
|
||||
HTMLDict := TStDictionary.Create(FEmbeddedHTML.Count+1);
|
||||
StringDict := TStDictionary.Create(FStringMarkers.Count+1);
|
||||
|
||||
CommentDict.DisposeData := DisposeString;
|
||||
KeywordsDict.DisposeData := DisposeString;
|
||||
HTMLDict.DisposeData := DisposeString;
|
||||
StringDict.DisposeData := DisposeString;
|
||||
|
||||
FInTextStream := TStAnsiTextStream.Create(FInputStream);
|
||||
FInTextStream.LineTermChar := AnsiChar(FInLineTermChar);
|
||||
FInTextStream.LineTerminator := FInLineTerminator;
|
||||
FInTextStream.FixedLineLength := FInFixedLineLen;
|
||||
FInFileSize := FInTextStream.Size;
|
||||
|
||||
FOutTextStream := TStAnsiTextStream.Create(FOutputStream);
|
||||
FOutTextStream.LineTermChar := #10;
|
||||
FOutTextStream.LineTerminator := ltCRLF;
|
||||
FOutTextStream.FixedLineLength := 80;
|
||||
|
||||
FInLineTerminator := ltCRLF; {normal Windows text file terminator}
|
||||
FInLineTermChar := #10;
|
||||
FInFixedLineLen := 80;
|
||||
|
||||
try
|
||||
if (FCaseSensitive) then begin
|
||||
CommentDict.Hash := AnsiHashStr;
|
||||
CommentDict.Equal := AnsiCompareStr;
|
||||
HTMLDict.Hash := AnsiHashStr;
|
||||
HTMLDict.Equal := AnsiCompareStr;
|
||||
KeywordsDict.Hash := AnsiHashStr;
|
||||
KeywordsDict.Equal:= AnsiCompareStr;
|
||||
StringDict.Hash := AnsiHashStr;
|
||||
StringDict.Equal := AnsiCompareStr;
|
||||
end else begin
|
||||
CommentDict.Hash := AnsiHashText;
|
||||
CommentDict.Equal := AnsiCompareText;
|
||||
HTMLDict.Hash := AnsiHashText;
|
||||
HTMLDict.Equal := AnsiCompareText;
|
||||
KeywordsDict.Hash := AnsiHashText;
|
||||
KeywordsDict.Equal:= AnsiCompareText;
|
||||
StringDict.Hash := AnsiHashText;
|
||||
StringDict.Equal := AnsiCompareText;
|
||||
end;
|
||||
|
||||
{Add items from string lists to dictionaries}
|
||||
for I := 0 to pred(FKeywords.Count) do begin
|
||||
if (Length(FKeywords[I]) = 0) then
|
||||
continue;
|
||||
if (pos('=', FKeywords[I]) > 0) then begin
|
||||
New(PS);
|
||||
S := FKeywords.Names[I];
|
||||
PS^ := FKeywords.Values[S];
|
||||
if (not KeywordsDict.Exists(S, P)) then
|
||||
KeywordsDict.Add(S, PS)
|
||||
else
|
||||
Dispose(PS);
|
||||
end else
|
||||
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
|
||||
end;
|
||||
|
||||
for I := 0 to pred(FStringMarkers.Count) do begin
|
||||
if (Length(FStringMarkers[I]) = 0) then
|
||||
continue;
|
||||
if (pos('=', FStringMarkers[I]) > 0) then begin
|
||||
New(PS);
|
||||
S := FStringMarkers.Names[I];
|
||||
PS^ := FStringMarkers.Values[S];
|
||||
if (not StringDict.Exists(S, P)) then
|
||||
StringDict.Add(S, PS)
|
||||
else
|
||||
Dispose(PS);
|
||||
end else
|
||||
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
|
||||
end;
|
||||
|
||||
for I := 0 to pred(FCommentMarkers.Count) do begin
|
||||
if (Length(FCommentMarkers[I]) = 0) then
|
||||
continue;
|
||||
if (pos('=', FCommentMarkers[I]) > 0) then begin
|
||||
New(PS);
|
||||
S := FCommentMarkers.Names[I];
|
||||
if (Length(S) = 1) then
|
||||
PS^ := FCommentMarkers.Values[S]
|
||||
else begin
|
||||
PS^ := ':1' + S[2] + ';' + FCommentMarkers.Values[S];
|
||||
S := S[1];
|
||||
end;
|
||||
if (not CommentDict.Exists(S, P)) then
|
||||
CommentDict.Add(S, PS)
|
||||
else begin
|
||||
AStr := String(P^);
|
||||
AStr := AStr + PS^;
|
||||
String(P^) := AStr;
|
||||
CommentDict.Update(S, P);
|
||||
Dispose(PS);
|
||||
end;
|
||||
end else
|
||||
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
|
||||
end;
|
||||
|
||||
for I := 0 to pred(FEmbeddedHTML.Count) do begin
|
||||
if (pos('=', FEmbeddedHTML[I]) > 0) then begin
|
||||
New(PS);
|
||||
S := FEmbeddedHTML.Names[I];
|
||||
PS^ := FEmbeddedHTML.Values[S];
|
||||
if (not HTMLDict.Exists(S, P)) then
|
||||
HTMLDict.Add(S, PS)
|
||||
else
|
||||
Dispose(PS);
|
||||
end else
|
||||
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
|
||||
end;
|
||||
|
||||
BRead := 0;
|
||||
if (FPageHeader.Count > 0) then begin
|
||||
for I := 0 to pred(FPageHeader.Count) do
|
||||
FOutTextStream.WriteLine(FPageHeader[I]);
|
||||
end;
|
||||
FOutTextStream.WriteLine('<pre>');
|
||||
CommentPend := False;
|
||||
AStr := '';
|
||||
SStr := '';
|
||||
EStr := '';
|
||||
|
||||
{make sure buffer is at the start}
|
||||
FInTextStream.Position := 0;
|
||||
while not FInTextStream.AtEndOfStream do begin
|
||||
TmpStr := FInTextStream.ReadLine;
|
||||
Inc(BRead, Length(TmpStr) + Length(FInTextStream.LineTermChar));
|
||||
if (FInFileSize > 0) then begin
|
||||
PC := Round((BRead / FInFileSize * 100));
|
||||
if (Assigned(FOnProgress)) then
|
||||
FOnProgress(Self, PC);
|
||||
end;
|
||||
|
||||
if (TmpStr = '') then begin
|
||||
if (CommentPend) then
|
||||
FOutTextStream.WriteLine(EStr)
|
||||
else
|
||||
FOutTextStream.WriteLine(' ');
|
||||
continue;
|
||||
end;
|
||||
|
||||
if (CommentPend) then
|
||||
S := SStr
|
||||
else
|
||||
S := '';
|
||||
|
||||
P1 := 1;
|
||||
repeat
|
||||
if (not CommentPend) and (CommentDict.Exists(TmpStr[P1], P)) then begin
|
||||
VS := String(P^);
|
||||
if (Copy(VS, 1 , 2) = ':1') then begin
|
||||
while (Copy(VS, 1 , 2) = ':1') do begin
|
||||
System.Delete(VS, 1, 2);
|
||||
if (TmpStr[P1+1] = VS[1]) then begin
|
||||
System.Delete(VS, 1, 2);
|
||||
CloseStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
System.Delete(VS, 1, pos(';', VS));
|
||||
SStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
System.Delete(VS, 1, pos(';', VS));
|
||||
J := pos(':1', VS);
|
||||
if (J = 0) then
|
||||
EStr := Copy(VS, pos(';', VS)+1, Length(VS))
|
||||
else begin
|
||||
EStr := Copy(VS, 1, J-1);
|
||||
System.Delete(VS, 1, J+2);
|
||||
end;
|
||||
|
||||
if (CloseStr = '') then begin
|
||||
S := S + SStr;
|
||||
AStr := Copy(TmpStr, P1, Length(TmpStr));
|
||||
CheckSubString(AStr);
|
||||
S := S + EStr;
|
||||
CloseStr := '';
|
||||
SStr := '';
|
||||
EStr := '';
|
||||
TmpStr := '';
|
||||
continue;
|
||||
end else begin
|
||||
I := pos(CloseStr, TmpStr);
|
||||
if (I = 0) then begin
|
||||
CommentPend := True;
|
||||
S := SStr + S;
|
||||
end else begin
|
||||
S := S + SStr;
|
||||
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
CheckSubstring(AStr);
|
||||
S := S + EStr;
|
||||
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
J := pos(':1', VS);
|
||||
if (J > 0) then
|
||||
System.Delete(VS, 1, J-1);
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
{is it really the beginning of a comment?}
|
||||
CloseStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
System.Delete(VS, 1, pos(';', VS));
|
||||
SStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
EStr := Copy(VS, pos(';', VS)+1, Length(VS));
|
||||
I := pos(CloseStr, TmpStr);
|
||||
if (I > 0) and (I > P1) then begin
|
||||
{ending marker found}
|
||||
CommentPend := False;
|
||||
S := S + SStr;
|
||||
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
CheckSubstring(AStr);
|
||||
S := S + EStr;
|
||||
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
P1 := 1;
|
||||
CloseStr := '';
|
||||
SStr := '';
|
||||
EStr := '';
|
||||
if (TmpStr = '') then
|
||||
continue;
|
||||
end else begin {1}
|
||||
CommentPend := True;
|
||||
S := S + SStr;
|
||||
if (Length(TmpStr) > 1) then begin
|
||||
AStr := Copy(TmpStr, P1, Length(TmpStr));
|
||||
CheckSubstring(AStr);
|
||||
end else
|
||||
S := S + TmpStr;
|
||||
S := S + EStr;
|
||||
TmpStr := '';
|
||||
continue;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if (CommentPend) then begin
|
||||
I := pos(CloseStr, TmpStr);
|
||||
if (I < 1) then begin
|
||||
AStr := Copy(TmpStr, P1, Length(TmpStr));
|
||||
CheckSubstring(AStr);
|
||||
S := S + EStr;
|
||||
TmpStr := '';
|
||||
continue;
|
||||
end else begin {2}
|
||||
CommentPend := False;
|
||||
if (Length(TmpStr) > 1) then begin
|
||||
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
CheckSubstring(AStr);
|
||||
end else
|
||||
S := S + TmpStr;
|
||||
S := S + EStr;
|
||||
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
|
||||
CloseStr := '';
|
||||
SStr := '';
|
||||
EStr := '';
|
||||
if (TmpStr = '') then
|
||||
continue
|
||||
else
|
||||
P1 := 1;
|
||||
end;
|
||||
end else begin
|
||||
CloseStr := '';
|
||||
SStr := '';
|
||||
EStr := '';
|
||||
end;
|
||||
|
||||
if (TmpStr = '') then
|
||||
continue;
|
||||
|
||||
P := nil;
|
||||
while (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) = 0) and
|
||||
(not StringDict.Exists(TmpStr[P1], P)) do
|
||||
Inc(P1);
|
||||
if (Assigned(P)) then begin
|
||||
P2 := P1+1;
|
||||
VS := String(P^);
|
||||
CloseStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
System.Delete(VS, 1, pos(';', VS));
|
||||
SStr := Copy(VS, 1, pos(';', VS)-1);
|
||||
System.Delete(VS, 1, pos(';', VS));
|
||||
EStr := Copy(VS, pos(';', VS)+1, Length(VS));
|
||||
|
||||
while (TmpStr[P2] <> CloseStr) and (P2 <= Length(TmpStr)) do
|
||||
Inc(P2);
|
||||
S := S + SStr;
|
||||
AStr := Copy(TmpStr, P1, P2-P1+1);
|
||||
CheckSubString(AStr);
|
||||
S := S + EStr;
|
||||
|
||||
System.Delete(TmpStr, P1, P2);
|
||||
if (TmpStr = '') then
|
||||
continue
|
||||
else
|
||||
P1 := 1;
|
||||
P := nil;
|
||||
end else if (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) > 0) then begin
|
||||
if (P1 = 1) then begin
|
||||
S := S + ConvertEmbeddedHTML(TmpStr[1]);
|
||||
System.Delete(TmpStr, 1, 1);
|
||||
P1 := 1;
|
||||
end else begin
|
||||
AStr := Copy(TmpStr, 1, P1-1);
|
||||
if (Length(AStr) > 0) then
|
||||
CheckSubstring(AStr);
|
||||
System.Delete(TmpStr, 1, P1);
|
||||
P1 := 1;
|
||||
end;
|
||||
end else begin
|
||||
AStr := TmpStr;
|
||||
CheckSubString(AStr);
|
||||
TmpStr := '';
|
||||
end;
|
||||
until (Length(TmpStr) = 0);
|
||||
FOutTextStream.WriteLine(S);
|
||||
end;
|
||||
if (Assigned(FOnProgress)) then
|
||||
FOnProgress(Self, 0);
|
||||
|
||||
Result := True;
|
||||
FOutTextStream.WriteLine('</pre>');
|
||||
if (FPageFooter.Count > 0) then begin
|
||||
for I := 0 to pred(FPageFooter.Count) do
|
||||
FOutTextStream.WriteLine(FPageFooter[I]);
|
||||
end;
|
||||
finally
|
||||
CommentDict.Free;
|
||||
HTMLDict.Free;
|
||||
KeywordsDict.Free;
|
||||
StringDict.Free;
|
||||
|
||||
FInTextStream.Free;
|
||||
FInTextStream := nil;
|
||||
|
||||
FOutTextStream.Free;
|
||||
FOutTextStream := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetCommentMarkers(Value : TStringList);
|
||||
begin
|
||||
FCommentMarkers.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetEmbeddedHTML(Value : TStringList);
|
||||
begin
|
||||
FEmbeddedHTML.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetKeywords(Value : TStringList);
|
||||
begin
|
||||
FKeywords.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetPageFooter(Value : TStringList);
|
||||
begin
|
||||
FPageFooter.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetPageHeader(Value : TStringList);
|
||||
begin
|
||||
FPageHeader.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStStreamToHTML.SetStringMarkers(Value : TStringList);
|
||||
begin
|
||||
FStringMarkers.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
(*****************************************************************************)
|
||||
(* TStFileToHTML Implementation *)
|
||||
(*****************************************************************************)
|
||||
|
||||
|
||||
constructor TStFileToHTML.Create(AOwner : TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
FCommentMarkers := TStringList.Create;
|
||||
FEmbeddedHTML := TStringList.Create;
|
||||
FKeywords := TStringList.Create;
|
||||
FPageFooter := TStringList.Create;
|
||||
FPageHeader := TStringList.Create;
|
||||
FStringMarkers := TStringList.Create;
|
||||
|
||||
FWordDelims := ',; .()';
|
||||
|
||||
FInLineTerminator := ltCRLF;
|
||||
FInLineTermChar := #10;
|
||||
FInLineLength := 80;
|
||||
|
||||
with FEmbeddedHTML do begin
|
||||
Add('"="');
|
||||
Add('&=&');
|
||||
Add('<=<');
|
||||
Add('>=>');
|
||||
Add('�=¡');
|
||||
Add('�=¢');
|
||||
Add('�=£');
|
||||
Add('�=©');
|
||||
Add('�=®');
|
||||
Add('�=±');
|
||||
Add('�=¼');
|
||||
Add('�=½');
|
||||
Add('�=¾');
|
||||
Add('�=÷');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TStFileToHTML.Destroy;
|
||||
begin
|
||||
FCommentMarkers.Free;
|
||||
FCommentMarkers := nil;
|
||||
|
||||
FEmbeddedHTML.Free;
|
||||
FEmbeddedHTML := nil;
|
||||
|
||||
FKeywords.Free;
|
||||
FKeywords := nil;
|
||||
|
||||
FPageFooter.Free;
|
||||
FPageFooter := nil;
|
||||
|
||||
FPageHeader.Free;
|
||||
FPageHeader := nil;
|
||||
|
||||
FStringMarkers.Free;
|
||||
FStringMarkers := nil;
|
||||
|
||||
FInFile.Free;
|
||||
FInFile := nil;
|
||||
|
||||
FOutFile.Free;
|
||||
FOutFile := nil;
|
||||
|
||||
FStream.Free;
|
||||
FStream := nil;
|
||||
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.Execute;
|
||||
begin
|
||||
FStream := TStStreamToHTML.Create;
|
||||
try
|
||||
if (FInFileName = '') then
|
||||
RaiseStError(EStToHTMLError, stscNoInputFile)
|
||||
else if (FOutFileName = '') then
|
||||
RaiseStError(EStToHTMLError, stscNoOutputFile)
|
||||
else begin
|
||||
if (Assigned(FInFile)) then
|
||||
FInFile.Free;
|
||||
try
|
||||
FInFile := TFileStream.Create(FInFileName, fmOpenRead or fmShareDenyWrite);
|
||||
except
|
||||
RaiseStError(EStToHTMLError, stscInFileError);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if (Assigned(FOutFile)) then
|
||||
FOutFile.Free;
|
||||
try
|
||||
FOutFile := TFileStream.Create(FOutFileName, fmCreate);
|
||||
except
|
||||
RaiseStError(EStToHTMLError, stscOutFileError);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
try
|
||||
FStream.InputStream := FInFile;
|
||||
FStream.OutputStream := FOutFile;
|
||||
FStream.CaseSensitive := CaseSensitive;
|
||||
FStream.CommentMarkers := CommentMarkers;
|
||||
FStream.EmbeddedHTML := EmbeddedHTML;
|
||||
FStream.InFixedLineLength := InFixedLineLength;
|
||||
FStream.InLineTermChar := InLineTermChar;
|
||||
FStream.InLineTerminator := InLineTerminator;
|
||||
FStream.Keywords := Keywords;
|
||||
FStream.OnProgress := OnProgress;
|
||||
FStream.PageFooter := PageFooter;
|
||||
FStream.PageHeader := PageHeader;
|
||||
FStream.StringMarkers := StringMarkers;
|
||||
FStream.WordDelimiters := WordDelimiters;
|
||||
|
||||
FStream.GenerateHTML;
|
||||
finally
|
||||
FInFile.Free;
|
||||
FInFile := nil;
|
||||
FOutFile.Free;
|
||||
FOutFile := nil;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FStream.Free;
|
||||
FStream := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetCommentMarkers(Value : TStringList);
|
||||
begin
|
||||
FCommentMarkers.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetEmbeddedHTML(Value : TStringList);
|
||||
begin
|
||||
FEmbeddedHTML.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetKeywords(Value : TStringList);
|
||||
begin
|
||||
FKeywords.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetPageFooter(Value : TStringList);
|
||||
begin
|
||||
FPageFooter.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetPageHeader(Value : TStringList);
|
||||
begin
|
||||
FPageHeader.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
procedure TStFileToHTML.SetStringMarkers(Value : TStringList);
|
||||
begin
|
||||
FStringMarkers.Assign(Value);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
439
components/systools/source/run/stutils.pas
Normal file
439
components/systools/source/run/stutils.pas
Normal file
@@ -0,0 +1,439 @@
|
||||
// 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 ***** *)
|
||||
|
||||
{*********************************************************}
|
||||
{* SysTools: StUtils.pas 4.04 *}
|
||||
{*********************************************************}
|
||||
{* SysTools: Assorted utility routines *}
|
||||
{*********************************************************}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
// {$I StDefine.inc}
|
||||
|
||||
unit StUtils;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes,
|
||||
|
||||
StConst, StBase, StDate,
|
||||
StStrL; { long string routines }
|
||||
|
||||
function SignL(L : LongInt) : Integer;
|
||||
{-return sign of LongInt value}
|
||||
function SignF(F : Extended) : Integer;
|
||||
{-return sign of floating point value}
|
||||
|
||||
function MinWord(A, B : Word) : Word;
|
||||
{-Return the smaller of A and B}
|
||||
function MidWord(W1, W2, W3 : Word) : Word;
|
||||
{-return the middle of three Word values}
|
||||
function MaxWord(A, B : Word) : Word;
|
||||
{-Return the greater of A and B}
|
||||
|
||||
function MinLong(A, B : LongInt) : LongInt;
|
||||
{-Return the smaller of A and B}
|
||||
function MidLong(L1, L2, L3 : LongInt) : LongInt;
|
||||
{-return the middle of three LongInt values}
|
||||
function MaxLong(A, B : LongInt) : LongInt;
|
||||
{-Return the greater of A and B}
|
||||
|
||||
function MinFloat(F1, F2 : Extended) : Extended;
|
||||
{-return the lesser of two floating point values}
|
||||
function MidFloat(F1, F2, F3 : Extended) : Extended;
|
||||
{-return the middle of three floating point values}
|
||||
function MaxFloat(F1, F2 : Extended) : Extended;
|
||||
{-return the greater of two floating point values}
|
||||
|
||||
{-Assorted utility routines. }
|
||||
|
||||
function MakeInteger16(H, L : Byte): SmallInt;
|
||||
{-Construct an integer from two bytes}
|
||||
|
||||
function MakeWord(H, L : Byte) : Word;
|
||||
{-Construct a word from two bytes}
|
||||
|
||||
function SwapNibble(B : Byte) : Byte;
|
||||
{-Swap the high and low nibbles of a byte}
|
||||
|
||||
function SwapWord(L : LongInt) : LongInt;
|
||||
{-Swap the low- and high-order words of a long integer}
|
||||
|
||||
procedure SetFlag(var Flags : Word; FlagMask : Word);
|
||||
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
|
||||
|
||||
procedure ClearFlag(var Flags : Word; FlagMask : Word);
|
||||
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in Flagmask}
|
||||
|
||||
function FlagIsSet(Flags, FlagMask : Word) : Boolean;
|
||||
{-Return True if the bit specified by FlagMask is set in Flags}
|
||||
|
||||
procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
|
||||
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
|
||||
|
||||
procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
|
||||
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
|
||||
|
||||
function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
|
||||
{-Return True if the bit specified by FlagMask is set in the Flags parameter}
|
||||
|
||||
procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
|
||||
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
|
||||
|
||||
|
||||
procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
|
||||
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
|
||||
|
||||
|
||||
function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
|
||||
{-Return True if the bit specified by FlagMask is set in Flags}
|
||||
|
||||
procedure ExchangeBytes(var I, J : Byte);
|
||||
{-Exchange the values in two bytes}
|
||||
|
||||
procedure ExchangeWords(var I, J : Word);
|
||||
{-Exchange the values in two words}
|
||||
|
||||
procedure ExchangeLongInts(var I, J : LongInt);
|
||||
{-Exchange the values in two long integers}
|
||||
|
||||
procedure ExchangeStructs(var I, J; Size : Cardinal);
|
||||
{-Exchange the values in two structures}
|
||||
|
||||
|
||||
procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
|
||||
{-Fill memory with a word-sized filler}
|
||||
|
||||
procedure FillStruct(var Dest; Count : Cardinal; var Filler; FillerSize : Cardinal);
|
||||
{-Fill memory with a variable sized filler}
|
||||
|
||||
function AddWordToPtr(P : Pointer; W : Word) : Pointer;
|
||||
{-Add a word to a pointer.}
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
ecOutOfMemory = 8;
|
||||
|
||||
function MakeInteger16(H, L : Byte): SmallInt;
|
||||
begin
|
||||
Word(Result) := (H shl 8) or L; {!!.02}
|
||||
end;
|
||||
|
||||
function SwapNibble(B : Byte) : Byte;
|
||||
begin
|
||||
Result := (B shr 4) or (B shl 4);
|
||||
end;
|
||||
|
||||
function SwapWord(L : LongInt) : LongInt; register;
|
||||
asm
|
||||
ror eax,16;
|
||||
end;
|
||||
|
||||
procedure SetFlag(var Flags : Word; FlagMask : Word);
|
||||
begin
|
||||
Flags := Flags or FlagMask;
|
||||
end;
|
||||
|
||||
procedure ClearFlag(var Flags : Word; FlagMask : Word);
|
||||
begin
|
||||
Flags := Flags and (not FlagMask);
|
||||
end;
|
||||
|
||||
|
||||
function FlagIsSet(Flags, FlagMask : Word) : Boolean;
|
||||
begin
|
||||
Result := (FlagMask AND Flags <> 0);
|
||||
end;
|
||||
|
||||
procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
|
||||
begin
|
||||
Flags := Flags or FlagMask;
|
||||
end;
|
||||
|
||||
procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
|
||||
begin
|
||||
Flags := Flags and (not FlagMask);
|
||||
end;
|
||||
|
||||
function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
|
||||
begin
|
||||
Result := (FlagMask AND Flags <> 0);
|
||||
end;
|
||||
|
||||
procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
|
||||
begin
|
||||
Flags := Flags or FlagMask;
|
||||
end;
|
||||
|
||||
procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
|
||||
begin
|
||||
Flags := Flags and (not FlagMask);
|
||||
end;
|
||||
|
||||
function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
|
||||
begin
|
||||
Result := FlagMask = (Flags and FlagMask);
|
||||
end;
|
||||
|
||||
procedure ExchangeBytes(var I, J : Byte);
|
||||
register;
|
||||
asm
|
||||
mov cl, [eax]
|
||||
mov ch, [edx]
|
||||
mov [edx], cl
|
||||
mov [eax], ch
|
||||
end;
|
||||
|
||||
procedure ExchangeWords(var I, J : Word);
|
||||
register;
|
||||
asm
|
||||
mov cx, [eax]
|
||||
push ecx
|
||||
mov cx, [edx]
|
||||
mov [eax], cx
|
||||
pop ecx
|
||||
mov [edx], cx
|
||||
end;
|
||||
|
||||
procedure ExchangeLongInts(var I, J : LongInt);
|
||||
register;
|
||||
asm
|
||||
mov ecx, [eax]
|
||||
push ecx
|
||||
mov ecx, [edx]
|
||||
mov [eax], ecx
|
||||
pop ecx
|
||||
mov [edx], ecx
|
||||
end;
|
||||
|
||||
procedure ExchangeStructs(var I, J; Size : Cardinal);
|
||||
register;
|
||||
asm
|
||||
push edi
|
||||
push ebx
|
||||
push ecx
|
||||
shr ecx, 2
|
||||
jz @@LessThanFour
|
||||
|
||||
@@AgainDWords:
|
||||
mov ebx, [eax]
|
||||
mov edi, [edx]
|
||||
mov [edx], ebx
|
||||
mov [eax], edi
|
||||
add eax, 4
|
||||
add edx, 4
|
||||
dec ecx
|
||||
jnz @@AgainDWords
|
||||
|
||||
@@LessThanFour:
|
||||
pop ecx
|
||||
and ecx, $3
|
||||
jz @@Done
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
inc eax
|
||||
inc edx
|
||||
dec ecx
|
||||
jz @@Done
|
||||
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
inc eax
|
||||
inc edx
|
||||
dec ecx
|
||||
jz @@Done
|
||||
|
||||
mov bl, [eax]
|
||||
mov bh, [edx]
|
||||
mov [edx], bl
|
||||
mov [eax], bh
|
||||
|
||||
@@Done:
|
||||
pop ebx
|
||||
pop edi
|
||||
end;
|
||||
|
||||
procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
|
||||
asm
|
||||
push edi
|
||||
mov edi,Dest
|
||||
mov ax,Filler
|
||||
mov ecx,Count
|
||||
cld
|
||||
rep stosw
|
||||
pop edi
|
||||
end;
|
||||
|
||||
procedure FillStruct(var Dest; Count : Cardinal; var Filler;
|
||||
FillerSize : Cardinal);
|
||||
register;
|
||||
asm
|
||||
or edx, edx
|
||||
jz @@Exit
|
||||
|
||||
push edi
|
||||
push esi
|
||||
push ebx
|
||||
mov edi, eax
|
||||
mov ebx, ecx
|
||||
|
||||
@@NextStruct:
|
||||
mov esi, ebx
|
||||
mov ecx, FillerSize
|
||||
shr ecx, 1
|
||||
rep movsw
|
||||
adc ecx, ecx
|
||||
rep movsb
|
||||
dec edx
|
||||
jnz @@NextStruct
|
||||
|
||||
pop ebx
|
||||
pop esi
|
||||
pop edi
|
||||
|
||||
@@Exit:
|
||||
end;
|
||||
|
||||
function AddWordToPtr(P : Pointer; W : Word) : Pointer;
|
||||
begin
|
||||
Result := Pointer(LongInt(P)+W);
|
||||
end;
|
||||
|
||||
function MakeWord(H, L : Byte) : Word;
|
||||
begin
|
||||
Result := (Word(H) shl 8) or L;
|
||||
end;
|
||||
|
||||
function MinWord(A, B : Word) : Word;
|
||||
begin
|
||||
if A < B then
|
||||
Result := A
|
||||
else
|
||||
Result := B;
|
||||
end;
|
||||
|
||||
function MaxWord(A, B : Word) : Word;
|
||||
begin
|
||||
if A > B then
|
||||
Result := A
|
||||
else
|
||||
Result := B;
|
||||
end;
|
||||
|
||||
function MinLong(A, B : LongInt) : LongInt;
|
||||
begin
|
||||
if A < B then
|
||||
Result := A
|
||||
else
|
||||
Result := B;
|
||||
end;
|
||||
|
||||
function MaxLong(A, B : LongInt) : LongInt;
|
||||
begin
|
||||
if A > B then
|
||||
Result := A
|
||||
else
|
||||
Result := B;
|
||||
end;
|
||||
|
||||
function SignL(L : LongInt) : Integer;
|
||||
{-return sign of LongInt value}
|
||||
begin
|
||||
if L < 0 then
|
||||
Result := -1
|
||||
else if L = 0 then
|
||||
Result := 0
|
||||
else
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
function SignF(F : Extended) : Integer;
|
||||
{-return sign of floating point value}
|
||||
begin
|
||||
if F < 0 then
|
||||
Result := -1
|
||||
else if F = 0 then
|
||||
Result := 0
|
||||
else
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
function MidWord(W1, W2, W3 : Word) : Word;
|
||||
{return the middle of three Word values}
|
||||
begin
|
||||
Result := StUtils.MinWord(StUtils.MinWord(StUtils.MaxWord(W1, W2),
|
||||
StUtils.MaxWord(W2, W3)), StUtils.MaxWord(W1, W3));
|
||||
end;
|
||||
|
||||
function MidLong(L1, L2, L3 : LongInt) : LongInt;
|
||||
{return the middle of three LongInt values}
|
||||
begin
|
||||
Result := StUtils.MinLong(StUtils.MinLong(StUtils.MaxLong(L1, L2),
|
||||
StUtils.MaxLong(L2, L3)), StUtils.MaxLong(L1, L3));
|
||||
end;
|
||||
|
||||
function MidFloat(F1, F2, F3 : Extended) : Extended;
|
||||
{return the middle of three floating point values}
|
||||
begin
|
||||
Result := MinFloat(MinFloat(MaxFloat(F1, F2), MaxFloat(F2, F3)), MaxFloat(F1, F3));
|
||||
end;
|
||||
|
||||
function MinFloat(F1, F2 : Extended) : Extended;
|
||||
{-return the lesser of two floating point values}
|
||||
begin
|
||||
if F1 <= F2 then
|
||||
Result := F1
|
||||
else
|
||||
Result := F2;
|
||||
end;
|
||||
|
||||
function MaxFloat(F1, F2 : Extended) : Extended;
|
||||
{-return the greater of two floating point values}
|
||||
begin
|
||||
if F1 > F2 then
|
||||
Result := F1
|
||||
else
|
||||
Result := F2;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user