mirror-github-bspeice/apophysis7x
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ADMIN: migration complete

Browse Source 
git-svn-id: https://svn.code.sf.net/p/apophysis7x/svn/trunk@1 a5d1c0f9-a0e9-45c6-87dd-9d276e40c949
This commit is contained in:
xyrus02
2013-07-28 08:58:33 +00:00
commit 95a2f54683
258 changed files with 175238 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
System/AsmRandom.pas Normal file
View File

@ -0,0 +1,95 @@
{
Apophysis Copyright (C) 2001-2004 Mark Townsend
Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov
Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
This module is (c) Jed Kelsey and originally created for Apophysis JK 2.10.
}
unit AsmRandom;
interface
procedure AsmRandInt;
procedure AsmRandExt;
procedure AsmRandomize;
var
RandSeed: Longint = 0; { Base for random number generator }
implementation
const
advapi32 = 'advapi32.dll';
kernel = 'kernel32.dll';
function QueryPerformanceCounter(var lpPerformanceCount: Int64): LongBool; stdcall;
external kernel name 'QueryPerformanceCounter';
function GetTickCount: Cardinal;
external kernel name 'GetTickCount';
procedure AsmRandomize;
{$IFDEF LINUX}
begin
RandSeed := _time(nil);
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
var
Counter: Int64;
begin
if QueryPerformanceCounter(Counter) then
RandSeed := Counter
else
RandSeed := GetTickCount;
end;
{$ENDIF}
procedure AsmRandInt;
asm
{ ->EAX Range }
{ <-EAX Result }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
MUL EDX
MOV EAX,EDX
end;
procedure AsmRandExt;
const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32
asm
{ FUNCTION _RandExt: Extended; }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
FLD two2neg32
PUSH 0
PUSH EDX
FILD qword ptr [ESP]
ADD ESP,8
FMULP ST(1), ST(0)
end;
end.

23
System/CurvesControl.dfm Normal file
View File

@ -0,0 +1,23 @@
object CurvesControl: TCurvesControl
Left = 0
Top = 0
Width = 542
Height = 440
DoubleBuffered = True
Color = clBlack
ParentBackground = False
ParentColor = False
ParentDoubleBuffered = False
TabOrder = 0
object Host: TPanel
Left = 0
Top = 0
Width = 542
Height = 440
Align = alClient
BevelOuter = bvNone
Color = clBlack
ParentBackground = False
TabOrder = 0
end
end

384
System/CurvesControl.pas Normal file
View File

@ -0,0 +1,384 @@
unit CurvesControl;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Math, ControlPoint,
Graphics, Controls, Forms, Bezier, CustomDrawControl, Vcl.ExtCtrls;
const
point_size: double = 8;
accurancy: double = 3;
channel_count: integer = 4;
padding = 3;
const
MAX_CHANNEL = 3;
type
TCurvesChannel = (ccAll = 0, ccRed = 1, ccGreen = 2, ccBlue = 3);
TCurvesControl = class(TFrame)
Host: TPanel;
private
FRect: BezierRect;
FPoints: array [0..3] of BezierPoints;
FWeights: array [0..3] of BezierWeights;
FDragging: boolean;
FDragIndex: integer;
FActiveChannel : TCurvesChannel;
FChannelIndex : integer;
FFrame : TCustomDrawControl;
FCP: TControlPoint;
p: array [0..MAX_CHANNEL] of BezierPoints;
w: array [0..MAX_CHANNEL] of BezierWeights;
wsum: array [0..MAX_CHANNEL] of double;
procedure SetChannel(value: TCurvesChannel);
procedure SetWeightLeft(value: double);
procedure SetWeightRight(value: double);
function GetChannel: TCurvesChannel;
function GetWeightLeft: double;
function GetWeightRight: double;
procedure FrameMouseLeave(Sender: TObject);
procedure FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FrameResize(Sender: TObject);
procedure FramePaint(Sender: TObject);
procedure FrameCreate;
procedure PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property WeightLeft : double read GetWeightLeft write SetWeightLeft;
property WeightRight : double read GetWeightRight write SetWeightRight;
property ActiveChannel : TCurvesChannel read GetChannel write SetChannel;
procedure SetCp(cp: TControlPoint);
procedure UpdateFlame;
end;
implementation
{$R *.DFM}
uses Main, Editor, Mutate, Adjust;
constructor TCurvesControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFrame := TCustomDrawControl.Create(self);
FFrame.TabStop := True;
FFrame.TabOrder := 0;
FFrame.Parent := Host;
FFrame.Align := alClient;
FFrame.Visible := True;
FFrame.OnPaint := FramePaint;
FFrame.OnMouseDown := FrameMouseDown;
FFrame.OnMouseMove := FrameMouseMove;
FFrame.OnMouseUp := FrameMouseUp;
FFrame.OnMouseLeave := FrameMouseLeave;
FCP := TControlPoint.Create;
FrameCreate;
end;
destructor TCurvesControl.Destroy;
begin
FCP.Destroy;
inherited Destroy;
end;
procedure TCurvesControl.SetCp(cp: TControlPoint);
var i, j: integer;
begin
FCP.Copy(cp, true);
for i := 0 to 3 do
for j := 0 to 3 do begin
FWeights[i,j] := FCP.curveWeights[i,j];
FPoints[i,j].x := FCP.curvePoints[i,j].x;
FPoints[i,j].y := FCP.curvePoints[i,j].y;
end;
Invalidate;
FFrame.Invalidate;
end;
procedure TCurvesControl.UpdateFlame;
begin
MainForm.StopThread;
MainForm.UpdateUndo;
MainCp.Copy(FCP, true);
if EditForm.Visible then EditForm.UpdateDisplay;
if MutateForm.Visible then MutateForm.UpdateDisplay;
if AdjustForm.Visible then AdjustForm.UpdateDisplay(true);
MainForm.RedrawTimer.enabled := true;
end;
procedure TCurvesControl.FrameMouseLeave(Sender: TObject);
begin
FrameMouseUp(nil, mbLeft, [], 0, 0);
end;
procedure TCurvesControl.FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
ps_half: double;
i, n: integer;
p: BezierPoints;
begin
BezierCopy(FPoints[FChannelIndex], p);
BezierSetRect(p, true, FRect);
FDragIndex := -1;
FDragging := false;
n := Length(p);
for i := 1 to n - 2 do if
(X >= p[i].x - point_size) and (X <= p[i].x + point_size) and
(Y >= p[i].y - point_size) and (Y <= p[i].y + point_size) then
begin
FDragging := true;
FDragIndex := i;
Break;
end;
end;
procedure TCurvesControl.FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
m: BezierPoints;
tmp: BezierPoint;
i: Integer;
j: Integer;
begin
if (y < 0) then Exit;
if (x < 0) then Exit;
m[0].x := x; m[0].y := y;
BezierUnsetRect(m, true, FRect);
if FDragging then
begin
FPoints[FChannelIndex][FDragIndex] := m[0];
if (FPoints[FChannelIndex][FDragIndex].x <= 0)
then FPoints[FChannelIndex][FDragIndex].x := 0;
if (FPoints[FChannelIndex][FDragIndex].y <= 0)
then FPoints[FChannelIndex][FDragIndex].y := 0;
if (FPoints[FChannelIndex][FDragIndex].x >= 1)
then FPoints[FChannelIndex][FDragIndex].x := 1;
if (FPoints[FChannelIndex][FDragIndex].y >= 1)
then FPoints[FChannelIndex][FDragIndex].y := 1;
if (FPoints[FChannelIndex][1].x > FPoints[FChannelIndex][2].x) then
begin
tmp := FPoints[FChannelIndex][1];
FPoints[FChannelIndex][1] := FPoints[FChannelIndex][2];
FPoints[FChannelIndex][2] := tmp;
if (FDragIndex = 1) then FDragIndex := 2
else FDragIndex := 1;
end;
for i := 0 to 3 do
for j := 0 to 3 do begin
FCP.curveWeights[i,j] := FWeights[i,j];
FCP.curvePoints[i,j].x := FPoints[i,j].x;
FCP.curvePoints[i,j].y := FPoints[i,j].y;
end;
FFrame.Refresh;
end;
end;
procedure TCurvesControl.FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FDragIndex := -1;
FDragging := false;
if (sender <> nil) then UpdateFlame;
end;
procedure TCurvesControl.FrameCreate;
var i: integer;
begin
for i := 0 to channel_count - 1 do
begin
FPoints[i][0].x := 0.00; FPoints[i][0].y := 0.00; FWeights[i][0] := 1;
FPoints[i][1].x := 0.00; FPoints[i][1].y := 0.00; FWeights[i][1] := 1;
FPoints[i][2].x := 1.00; FPoints[i][2].y := 1.00; FWeights[i][2] := 1;
FPoints[i][3].x := 1.00; FPoints[i][3].y := 1.00; FWeights[i][3] := 1;
end;
FDragIndex := -1;
FDragging := false;
end;
procedure TCurvesControl.FrameResize(Sender: TObject);
begin
FRect.x0 := 0; FRect.y0 := 0;
FRect.x1 := self.Width - 1;
FRect.y1 := self.Height - 1;
end;
procedure TCurvesControl.FramePaint(Sender: TObject);
var
clientRect: TRect;
i, j, x, y, sx, sy: integer;
bitmap: TBitMap;
begin
if (FFrame.Width <= 0) or (FFrame.Height <= 0) then Exit;
FrameResize(Sender);
Bitmap := TBitmap.Create;
Bitmap.Width := FFrame.Width;
Bitmap.Height := FFrame.Height;
sx := Bitmap.Width;
sy := Bitmap.Height;
try
with Bitmap.Canvas do
begin
Brush.Color := $000000;
FillRect(Rect(0, 0, sx, sy));
Pen.Color := $555555;
Pen.Style := psSolid;
Pen.Width := 1;
for x := 1 to 7 do begin
MoveTo(Round(0.125 * x * FRect.x1), Round(FRect.y0));
LineTo(Round(0.125 * x * FRect.x1), Round(FRect.y1));
end;
for y := 1 to 3 do begin
MoveTo(Round(FRect.x0), Round(0.25 * y * FRect.y1));
LineTo(Round(FRect.x1), Round(0.25 * y * FRect.y1));
end;
for i := 0 to channel_count - 1 do begin
for j := 0 to 3 do
wsum[i] := wsum[i] + FWeights[i][j];
for j := 0 to 3 do
w[i][j] := FWeights[i][j] / wsum[i];
BezierCopy(FPoints[i], p[i]);
BezierSetRect(p[i], true, FRect);
if i <> FChannelIndex then PaintCurve(Bitmap, i, p[i], w[i], false);
end;
PaintCurve(Bitmap, FChannelIndex, p[FChannelIndex], w[FChannelIndex], true);
FFrame.Canvas.Draw(0, 0, Bitmap);
end;
finally
Bitmap.Free;
end;
end;
procedure TCurvesControl.PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean);
var
pos0, pos1: BezierPoint;
t, step: Double;
r, g, b: array [0 .. MAX_CHANNEL] of integer;
rgbv: integer;
begin
with Bitmap.Canvas do
begin
if c <> FChannelIndex then begin
r[0] := $aa; r[1] := $aa; r[2] := $40; r[3] := $40;
g[0] := $aa; g[1] := $40; g[2] := $aa; g[3] := $40;
b[0] := $aa; b[1] := $40; b[2] := $40; b[3] := $aa;
end else begin
r[0] := $ff; r[1] := $ff; r[2] := $80; r[3] := $80;
g[0] := $ff; g[1] := $80; g[2] := $ff; g[3] := $80;
b[0] := $ff; b[1] := $80; b[2] := $80; b[3] := $ff;
end;
rgbv := RGB(r[c], g[c], b[c]);
t := 0;
step := 0.001;
BezierSolve(0, p, w, pos1);
pos0.x := 0; pos0.y := pos1.y;
if widgets then begin
Pen.Color := $808080; Pen.Width := 1;
MoveTo(Round(p[1].x), Round(p[1].y));
LineTo(Round(p[2].x), Round(p[2].y));
MoveTo(Round(FRect.x0), Round(FRect.y1));
LineTo(Round(p[1].x), Round(p[1].y));
MoveTo(Round(FRect.x1), Round(FRect.y0));
LineTo(Round(p[2].x), Round(p[2].y));
end;
while t < 1 do begin
BezierSolve(t, p, w, pos1);
Pen.Color := rgbv;
Pen.Width := 1;
MoveTo(Round(pos0.x), Round(pos0.y));
LineTo(Round(pos1.x), Round(pos1.y));
t := t + step;
pos0 := pos1;
end;
MoveTo(Round(pos0.x), Round(pos0.y));
LineTo(Round(FRect.x1), Round(pos0.y));
if widgets then begin
Brush.Color := rgbv;
Ellipse(
Round(p[1].x - point_size / 2.0),
Round(p[1].y - point_size / 2.0),
Round(p[1].x + point_size / 2.0),
Round(p[1].y + point_size / 2.0)
);
Ellipse(
Round(p[2].x - point_size / 2.0),
Round(p[2].y - point_size / 2.0),
Round(p[2].x + point_size / 2.0),
Round(p[2].y + point_size / 2.0)
);
end;
end;
end;
procedure TCurvesControl.SetChannel(value: TCurvesChannel);
begin
FActiveChannel := value;
FChannelIndex := Integer(value);
FFrame.Refresh;
end;
procedure TCurvesControl.SetWeightLeft(value: double);
begin
FWeights[FChannelIndex][1] := value;
FCP.curveWeights[FChannelIndex][1] := value;
FFrame.Refresh;
end;
procedure TCurvesControl.SetWeightRight(value: double);
begin
FWeights[FChannelIndex][2] := value;
FCP.curveWeights[FChannelIndex][2] := value;
FFrame.Refresh;
end;
function TCurvesControl.GetChannel: TCurvesChannel;
begin
Result := FActiveChannel;
end;
function TCurvesControl.GetWeightLeft: double;
begin
Result := FWeights[FChannelIndex][1];
end;
function TCurvesControl.GetWeightRight: double;
begin
Result := FWeights[FChannelIndex][2];
end;
end.

99
System/CustomDrawControl.pas Normal file
View File

@ -0,0 +1,99 @@
{
Apophysis Copyright (C) 2001-2004 Mark Townsend
Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov
Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit CustomDrawControl;
interface
uses
Classes, Controls, Messages, Windows, Graphics;
type
TCustomDrawControl = class(TCustomControl)
private
FOnPaint: TNotifyEvent;
FOnLeave: TNotifyEvent;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
protected
public
procedure Paint; override;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property Canvas;
property OnDblClick;
property OnKeyDown;
// property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
// property OnMouseWheelDown;
// property OnMouseWheelUp;
property OnEnter;
property OnExit;
property OnMouseLeave: TNotifyEvent read FOnLeave write FOnLeave;
end;
implementation
procedure TCustomDrawControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TCustomDrawControl.WMSetFocus(var Message: TWMSetFocus);
begin
Invalidate;
end;
procedure TCustomDrawControl.WMKillFocus(var Message: TWMKillFocus);
begin
if assigned(OnExit) then OnExit(self);
Invalidate;
end;
procedure TCustomDrawControl.WMGetDlgCode(var Message: TMessage);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TCustomDrawControl.CMMouseLeave(var Message: TMessage);
begin
if Assigned(FOnLeave) then FOnLeave(Self);
end;
procedure TCustomDrawControl.Paint;
begin
if Assigned(FOnPaint) then FOnPaint(Self);
end;
end.

11170
System/FastMM4.pas Normal file
View File

File diff suppressed because it is too large Load Diff

135
System/FastMM4Messages.pas Normal file
View File

@ -0,0 +1,135 @@
{
Fast Memory Manager: Messages
English translation by Pierre le Riche.
}
unit FastMM4Messages;
interface
{$Include FastMM4Options.inc}
const
{The name of the debug info support DLL}
FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll';
FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll';
{Event log strings}
LogFileExtension = '_MemoryManager_EventLog.txt'#0;
CRLF = #13#10;
EventSeparator = '--------------------------------';
{Class name messages}
UnknownClassNameMsg = 'Unknown';
{Memory dump message}
MemoryDumpMsg = #13#10#13#10'Current memory dump of 256 bytes starting at pointer address ';
{Block Error Messages}
BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: ';
ErrorMsgHeader = 'FastMM has detected an error during a ';
GetMemMsg = 'GetMem';
FreeMemMsg = 'FreeMem';
ReallocMemMsg = 'ReallocMem';
BlockCheckMsg = 'free block scan';
OperationMsg = ' operation. ';
BlockHeaderCorruptedMsg = 'The block header has been corrupted. ';
BlockFooterCorruptedMsg = 'The block footer has been corrupted. ';
FreeModifiedErrorMsg = 'FastMM detected that a block has been modified after being freed. ';
FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): ';
DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.';
WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.';
PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: ';
CurrentBlockSizeMsg = #13#10#13#10'The block size is: ';
PreviousObjectClassMsg = #13#10#13#10'The block was previously used for an object of class: ';
CurrentObjectClassMsg = #13#10#13#10'The block is currently used for an object of class: ';
PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: ';
PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: ';
CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: ';
CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: ';
BlockErrorMsgTitle = 'Memory Error Detected';
VirtualMethodErrorHeader = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.';
InterfaceErrorHeader = 'FastMM has detected an attempt to use an interface of a freed object. An access violation will now be raised in order to abort the current operation.';
BlockHeaderCorruptedNoHistoryMsg = ' Unfortunately the block header has been corrupted so no history is available.';
FreedObjectClassMsg = #13#10#13#10'Freed object class: ';
VirtualMethodName = #13#10#13#10'Virtual method: ';
VirtualMethodOffset = 'Offset +';
VirtualMethodAddress = #13#10#13#10'Virtual method address: ';
{Stack trace messages}
CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x';
CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:';
ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x';
ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x';
ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x';
ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x';
ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x';
StackTraceMsg = ', and the stack trace (return addresses) at the time was:';
{Installation Messages}
AlreadyInstalledMsg = 'FastMM4 is already installed.';
AlreadyInstalledTitle = 'Already installed.';
OtherMMInstalledMsg = 'FastMM4 cannot be installed since another third party memory '
+ 'manager has already installed itself.'#13#10'If you want to use FastMM4, '
+ 'please make sure that FastMM4.pas is the very first unit in the "uses"'
+ #13#10'section of your project''s .dpr file.';
OtherMMInstalledTitle = 'Cannot install FastMM4 - Another memory manager is already installed';
MemoryAllocatedMsg = 'FastMM4 cannot install since memory has already been '
+ 'allocated through the default memory manager.'#13#10'FastMM4.pas MUST '
+ 'be the first unit in your project''s .dpr file, otherwise memory may '
+ 'be allocated'#13#10'through the default memory manager before FastMM4 '
+ 'gains control. '#13#10#13#10'If you are using an exception trapper '
+ 'like MadExcept (or any tool that modifies the unit initialization '
+ 'order),'#13#10'go into its configuration page and ensure that the '
+ 'FastMM4.pas unit is initialized before any other unit.';
MemoryAllocatedTitle = 'Cannot install FastMM4 - Memory has already been allocated';
{Leak checking messages}
LeakLogHeader = 'A memory block has been leaked. The size is: ';
LeakMessageHeader = 'This application has leaked memory. ';
SmallLeakDetail = 'The small block leaks are'
{$ifdef HideExpectedLeaksRegisteredByPointer}
+ ' (excluding expected leaks registered by pointer)'
{$endif}
+ ':'#13#10;
LargeLeakDetail = 'The sizes of leaked medium and large blocks are'
{$ifdef HideExpectedLeaksRegisteredByPointer}
+ ' (excluding expected leaks registered by pointer)'
{$endif}
+ ': ';
BytesMessage = ' bytes: ';
AnsiStringBlockMessage = 'AnsiString';
UnicodeStringBlockMessage = 'UnicodeString';
LeakMessageFooter = #13#10
{$ifndef HideMemoryLeakHintMessage}
+ #13#10'Note: '
{$ifdef RequireIDEPresenceForLeakReporting}
+ 'This memory leak check is only performed if Delphi is currently running on the same computer. '
{$endif}
{$ifdef FullDebugMode}
{$ifdef LogMemoryLeakDetailToFile}
+ 'Memory leak detail is logged to a text file in the same folder as this application. '
{$else}
+ 'Enable the "LogMemoryLeakDetailToFile" to obtain a log file containing detail on memory leaks. '
{$endif}
{$else}
+ 'To obtain a log file containing detail on memory leaks, enable the "FullDebugMode" and "LogMemoryLeakDetailToFile" conditional defines. '
{$endif}
+ 'To disable this memory leak check, undefine "EnableMemoryLeakReporting".'#13#10
{$endif}
+ #0;
LeakMessageTitle = 'Memory Leak Detected';
{$ifdef UseOutputDebugString}
FastMMInstallMsg = 'FastMM has been installed.';
FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.';
FastMMUninstallMsg = 'FastMM has been uninstalled.';
FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.';
{$endif}
{$ifdef DetectMMOperationsAfterUninstall}
InvalidOperationTitle = 'MM Operation after uninstall.';
InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.';
InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.';
InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.';
InvalidAllocMemMsg = 'FastMM has detected an AllocMem call after FastMM was uninstalled.';
{$endif}
implementation
end.

426
System/FastMM4Options.inc Normal file
View File

@ -0,0 +1,426 @@
{
Fast Memory Manager: Options Include File
Set the default options for FastMM here.
}
{---------------------------Miscellaneous Options-----------------------------}
{Enable this define to align all blocks on 16 byte boundaries so aligned SSE
instructions can be used safely. If this option is disabled then some of the
smallest block sizes will be 8-byte aligned instead which may result in a
reduction in memory usage. Medium and large blocks are always 16-byte aligned
irrespective of this setting.}
{.$define Align16Bytes}
{Enable to use faster fixed-size move routines when upsizing small blocks.
These routines are much faster than the Borland RTL move procedure since they
are optimized to move a fixed number of bytes. This option may be used
together with the FastMove library for even better performance.}
{$define UseCustomFixedSizeMoveRoutines}
{Enable this option to use an optimized procedure for moving a memory block of
an arbitrary size. Disable this option when using the Fastcode move
("FastMove") library. Using the Fastcode move library allows your whole
application to gain from faster move routines, not just the memory manager. It
is thus recommended that you use the Fastcode move library in conjunction with
this memory manager and disable this option.}
{$define UseCustomVariableSizeMoveRoutines}
{Enable this option to only install FastMM as the memory manager when the
application is running inside the Delphi IDE. This is useful when you want
to deploy the same EXE that you use for testing, but only want the debugging
features active on development machines. When this option is enabled and
the application is not being run inside the IDE debugger, then the default
Delphi memory manager will be used (which, since Delphi 2006, is FastMM
without FullDebugMode.}
{.$define InstallOnlyIfRunningInIDE}
{Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown code
of borlndmm.dll has been called"), FastMM cannot be uninstalled safely when
used inside a replacement borlndmm.dll for the IDE. Setting this option will
circumvent this problem by never uninstalling the memory manager.}
{.$define NeverUninstall}
{Set this option when you use runtime packages in this application or library.
This will automatically set the "AssumeMultiThreaded" option. Note that you
have to ensure that FastMM is finalized after all live pointers have been
freed - failure to do so will result in a large leak report followed by a lot
of A/Vs. (See the FAQ for more detail.) You may have to combine this option
with the NeverUninstall option.}
{.$define UseRuntimePackages}
{-----------------------Concurrency Management Options------------------------}
{Enable to always assume that the application is multithreaded. Enabling this
option will cause a significant performance hit with single threaded
applications. Enable if you are using multi-threaded third party tools that do
not properly set the IsMultiThread variable. Also set this option if you are
going to share this memory manager between a single threaded application and a
multi-threaded DLL.}
{.$define AssumeMultiThreaded}
{Enable this option to not call Sleep when a thread contention occurs. This
option will improve performance if the ratio of the number of active threads
to the number of CPU cores is low (typically < 2). With this option set a
thread will usually enter a "busy waiting" loop instead of relinquishing its
timeslice when a thread contention occurs, unless UseSwitchToThread is
also defined (see below) in which case it will call SwitchToThread instead of
Sleep.}
{.$define NeverSleepOnThreadContention}
{Set this option to call SwitchToThread instead of sitting in a "busy waiting"
loop when a thread contention occurs. This is used in conjunction with the
NeverSleepOnThreadContention option, and has no effect unless
NeverSleepOnThreadContention is also defined. This option may improve
performance with many CPU cores and/or threads of different priorities. Note
that the SwitchToThread API call is only available on Windows 2000 and later.}
{.$define UseSwitchToThread}
{-----------------------------Debugging Options-------------------------------}
{Enable this option to suppress the generation of debug info for the
FastMM4.pas unit. This will prevent the integrated debugger from stepping into
the memory manager code.}
{.$define NoDebugInfo}
{Enable this option to suppress the display of all message dialogs. This is
useful in service applications that should not be interrupted.}
{.$define NoMessageBoxes}
{Set this option to use the Windows API OutputDebugString procedure to output
debug strings on startup/shutdown and when errors occur.}
{.$define UseOutputDebugString}
{Set this option to use the assembly language version which is faster than the
pascal version. Disable only for debugging purposes. Setting the
CheckHeapForCorruption option automatically disables this option.}
{$define ASMVersion}
{FastMM always catches attempts to free the same memory block twice, however it
can also check for corruption of the memory heap (typically due to the user
program overwriting the bounds of allocated memory). These checks are
expensive, and this option should thus only be used for debugging purposes.
If this option is set then the ASMVersion option is automatically disabled.}
{.$define CheckHeapForCorruption}
{Enable this option to catch attempts to perform MM operations after FastMM has
been uninstalled. With this option set when FastMM is uninstalled it will not
install the previous MM, but instead a dummy MM handler that throws an error
if any MM operation is attempted. This will catch attempts to use the MM
after FastMM has been uninstalled.}
{$define DetectMMOperationsAfterUninstall}
{Set the following option to do extensive checking of all memory blocks. All
blocks are padded with both a header and trailer that are used to verify the
integrity of the heap. Freed blocks are also cleared to to ensure that they
cannot be reused after being freed. This option slows down memory operations
dramatically and should only be used to debug an application that is
overwriting memory or reusing freed pointers. Setting this option
automatically enables CheckHeapForCorruption and disables ASMVersion.
Very important: If you enable this option your application will require the
FastMM_FullDebugMode.dll library. If this library is not available you will
get an error on startup.}
{.$define FullDebugMode}
{Set this option to perform "raw" stack traces, i.e. check all entries on the
stack for valid return addresses. Note that this is significantly slower
than using the stack frame tracing method, but is usually more complete. Has
no effect unless FullDebugMode is enabled}
{$define RawStackTraces}
{Set this option to check for user code that uses an interface of a freed
object. Note that this will disable the checking of blocks modified after
being freed (the two are not compatible). This option has no effect if
FullDebugMode is not also enabled.}
{.$define CatchUseOfFreedInterfaces}
{Set this option to log all errors to a text file in the same folder as the
application. Memory errors (with the FullDebugMode option set) will be
appended to the log file. Has no effect if "FullDebugMode" is not set.}
{$define LogErrorsToFile}
{Set this option to log all memory leaks to a text file in the same folder as
the application. Memory leak reports (with the FullDebugMode option set)
will be appended to the log file. Has no effect if "LogErrorsToFile" and
"FullDebugMode" are not also set. Note that usually all leaks are always
logged, even if they are "expected" leaks registered through
AddExpectedMemoryLeaks. Expected leaks registered by pointer may be excluded
through the HideExpectedLeaksRegisteredByPointer option.}
{$define LogMemoryLeakDetailToFile}
{Deletes the error log file on startup. No effect if LogErrorsToFile is not
also set.}
{.$define ClearLogFileOnStartup}
{Loads the FASTMM_FullDebugMode.dll dynamically. If the DLL cannot be found
then stack traces will not be available. Note that this may cause problems
due to a changed DLL unload order when sharing the memory manager. Use with
care.}
{.$define LoadDebugDLLDynamically}
{.$define DoNotInstallIfDLLMissing}
{If the FastMM_FullDebugMode.dll file is not available then FastMM will not
install itself. No effect unless FullDebugMode and LoadDebugDLLDynamically
are also defined.}
{FastMM usually allocates large blocks from the topmost available address and
medium and small blocks from the lowest available address (This reduces
fragmentation somewhat). With this option set all blocks are always
allocated from the highest available address. If the process has a >2GB
address space and contains bad pointer arithmetic code, this option should
help to catch those errors sooner.}
{$define AlwaysAllocateTopDown}
{Disables the logging of memory dumps together with the other detail for
memory errors.}
{.$define DisableLoggingOfMemoryDumps}
{If FastMM encounters a problem with a memory block inside the FullDebugMode
FreeMem handler then an "invalid pointer operation" exception will usually
be raised. If the FreeMem occurs while another exception is being handled
(perhaps in the try.. finally code) then the original exception will be
lost. With this option set FastMM will ignore errors inside FreeMem when an
exception is being handled, thus allowing the original exception to
propagate.}
{$define SuppressFreeMemErrorsInsideException}
{Adds support for notification of memory manager events in FullDebugMode.
With this define set, the application may assign the OnDebugGetMemFinish,
OnDebugFreeMemStart, etc. callbacks in order to be notified when the
particular memory manager event occurs.}
{.$define FullDebugModeCallBacks}
{---------------------------Memory Leak Reporting-----------------------------}
{Set this option to enable reporting of memory leaks. Combine it with the two
options below for further fine-tuning.}
{.$define EnableMemoryLeakReporting}
{Set this option to suppress the display and logging of expected memory leaks
that were registered by pointer. Leaks registered by size or class are often
ambiguous, so these expected leaks are always logged to file (in
FullDebugMode with the LogMemoryLeakDetailToFile option set) and are never
hidden from the leak display if there are more leaks than are expected.}
{.$define HideExpectedLeaksRegisteredByPointer}
{Set this option to require the presence of the Delphi IDE to report memory
leaks. This option has no effect if the option "EnableMemoryLeakReporting"
is not also set.}
{.$define RequireIDEPresenceForLeakReporting}
{Set this option to require the program to be run inside the IDE debugger to
report memory leaks. This option has no effect if the option
"EnableMemoryLeakReporting" is not also set. Note that this option does not
work with libraries, only EXE projects.}
{.$define RequireDebuggerPresenceForLeakReporting}
{Set this option to require the presence of debug info ($D+ option) in the
compiled unit to perform memory leak checking. This option has no effect if
the option "EnableMemoryLeakReporting" is not also set.}
{.$define RequireDebugInfoForLeakReporting}
{Set this option to enable manual control of the memory leak report. When
this option is set the ReportMemoryLeaksOnShutdown variable (default = false)
may be changed to select whether leak reporting should be done or not. When
this option is selected then both the variable must be set to true and the
other leak checking options must be applicable for the leak checking to be
done.}
{.$define ManualLeakReportingControl}
{Set this option to disable the display of the hint below the memory leak
message.}
{.$define HideMemoryLeakHintMessage}
{--------------------------Instruction Set Options----------------------------}
{Set this option to enable the use of MMX instructions. Disabling this option
will result in a slight performance hit, but will enable compatibility with
AMD K5, Pentium I and earlier CPUs. MMX is currently only used in the variable
size move routines, so if UseCustomVariableSizeMoveRoutines is not set then
this option has no effect.}
{.$define EnableMMX}
{Set this option to force the use of MMX instructions without checking
whether the CPU supports it. If this option is disabled then the CPU will be
checked for compatibility first, and if MMX is not supported it will fall
back to the FPU move code. Has no effect unless EnableMMX is also set.}
{$define ForceMMX}
{-----------------------Memory Manager Sharing Options------------------------}
{Allow sharing of the memory manager between a main application and DLLs that
were also compiled with FastMM. This allows you to pass dynamic arrays and
long strings to DLL functions provided both are compiled to use FastMM.
Sharing will only work if the library that is supposed to share the memory
manager was compiled with the "AttemptToUseSharedMM" option set. Note that if
the main application is single threaded and the DLL is multi-threaded that you
have to set the IsMultiThread variable in the main application to true or it
will crash when a thread contention occurs. Note that statically linked DLL
files are initialized before the main application, so the main application may
well end up sharing a statically loaded DLL's memory manager and not the other
way around. }
{.$define ShareMM}
{Allow sharing of the memory manager by a DLL with other DLLs (or the main
application if this is a statically loaded DLL) that were also compiled with
FastMM. Set this option with care in dynamically loaded DLLs, because if the
DLL that is sharing its MM is unloaded and any other DLL is still sharing
the MM then the application will crash. This setting is only relevant for
DLL libraries and requires ShareMM to also be set to have any effect.
Sharing will only work if the library that is supposed to share the memory
manager was compiled with the "AttemptToUseSharedMM" option set. Note that
if DLLs are statically linked then they will be initialized before the main
application and then the DLL will in fact share its MM with the main
application. This option has no effect unless ShareMM is also set.}
{.$define ShareMMIfLibrary}
{Define this to attempt to share the MM of the main application or other loaded
DLLs in the same process that were compiled with ShareMM set. When sharing a
memory manager, memory leaks caused by the sharer will not be freed
automatically. Take into account that statically linked DLLs are initialized
before the main application, so set the sharing options accordingly.}
{.$define AttemptToUseSharedMM}
{Define this to enable backward compatibility for the memory manager sharing
mechanism used by Delphi 2006 and 2007, as well as older FastMM versions.}
{$define EnableBackwardCompatibleMMSharing}
{-----------------------Security Options------------------------}
{Windows clears physical memory before reusing it in another process. However,
it is not known how quickly this clearing is performed, so it is conceivable
that confidential data may linger in physical memory longer than absolutely
necessary. If you're paranoid about this kind of thing, enable this option to
clear all freed memory before returning it to the operating system. Note that
this incurs a noticeable performance hit.}
{.$define ClearMemoryBeforeReturningToOS}
{With this option enabled freed memory will immediately be cleared inside the
FreeMem routine. This incurs a big performance hit, but may be worthwhile for
additional peace of mind when working with highly sensitive data. This option
supersedes the ClearMemoryBeforeReturningToOS option.}
{.$define AlwaysClearFreedMemory}
{--------------------------------Option Grouping------------------------------}
{Enabling this option enables FullDebugMode, InstallOnlyIfRunningInIDE and
LoadDebugDLLDynamically. Consequently, FastMM will install itself in
FullDebugMode if the application is being debugged inside the Delphi IDE.
Otherwise the default Delphi memory manager will be used (which is equivalent
to the non-FullDebugMode FastMM since Delphi 2006.)}
{.$define FullDebugModeInIDE}
{Combines the FullDebugMode, LoadDebugDLLDynamically and
DoNotInstallIfDLLMissing options. Consequently FastMM will only be installed
(In FullDebugMode) when the FastMM_FullDebugMode.dll file is available. This
is useful when the same executable will be distributed for both debugging as
well as deployment.}
{.$define FullDebugModeWhenDLLAvailable}
{Group the options you use for release and debug versions below}
{$ifdef Release}
{Specify the options you use for release versions below}
{.$undef FullDebugMode}
{.$undef CheckHeapForCorruption}
{.$define ASMVersion}
{.$undef EnableMemoryLeakReporting}
{.$undef UseOutputDebugString}
{$else}
{Specify the options you use for debugging below}
{.$define FullDebugMode}
{.$define EnableMemoryLeakReporting}
{.$define UseOutputDebugString}
{$endif}
{--------------------Compilation Options For borlndmm.dll---------------------}
{If you're compiling the replacement borlndmm.dll, set the defines below
for the kind of dll you require.}
{Set this option when compiling the borlndmm.dll}
{.$define borlndmmdll}
{Set this option if the dll will be used by the Delphi IDE}
{.$define dllforide}
{Set this option if you're compiling a debug dll}
{.$define debugdll}
{Do not change anything below this line}
{$ifdef borlndmmdll}
{$define AssumeMultiThreaded}
{$undef HideExpectedLeaksRegisteredByPointer}
{$undef RequireDebuggerPresenceForLeakReporting}
{$undef RequireDebugInfoForLeakReporting}
{$define DetectMMOperationsAfterUninstall}
{$undef ManualLeakReportingControl}
{$undef ShareMM}
{$undef AttemptToUseSharedMM}
{$ifdef dllforide}
{$define NeverUninstall}
{$define HideMemoryLeakHintMessage}
{$undef RequireIDEPresenceForLeakReporting}
{$ifndef debugdll}
{$undef EnableMemoryLeakReporting}
{$endif}
{$else}
{$define EnableMemoryLeakReporting}
{$undef NeverUninstall}
{$undef HideMemoryLeakHintMessage}
{$define RequireIDEPresenceForLeakReporting}
{$endif}
{$ifdef debugdll}
{$define FullDebugMode}
{$define RawStackTraces}
{$undef CatchUseOfFreedInterfaces}
{$define LogErrorsToFile}
{$define LogMemoryLeakDetailToFile}
{$undef ClearLogFileOnStartup}
{$else}
{$undef FullDebugMode}
{$endif}
{$endif}
{Move BCB related definitions here, because CB2006/CB2007 can build borlndmm.dll
for tracing memory leaks in BCB applications with "Build with Dynamic RTL"
switched on}
{------------------------------Patch BCB Terminate----------------------------}
{To enable the patching for BCB to make uninstallation and leak reporting
possible, you may need to add "BCB" definition
in "Project Options->Pascal/Delphi Compiler->Defines".
(Thanks to JiYuan Xie for implementing this.)}
{$ifdef BCB}
{$ifdef CheckHeapForCorruption}
{$define PatchBCBTerminate}
{$else}
{$ifdef DetectMMOperationsAfterUninstall}
{$define PatchBCBTerminate}
{$else}
{$ifdef EnableMemoryLeakReporting}
{$define PatchBCBTerminate}
{$endif}
{$endif}
{$endif}
{$ifdef PatchBCBTerminate}
{$define CheckCppObjectType}
{$undef CheckCppObjectTypeEnabled}
{$ifdef CheckCppObjectType}
{$define CheckCppObjectTypeEnabled}
{$endif}
{Turn off "CheckCppObjectTypeEnabled" option if neither "CheckHeapForCorruption"
option or "EnableMemoryLeakReporting" option were defined.}
{$ifdef CheckHeapForCorruption}
{$else}
{$ifdef EnableMemoryLeakReporting}
{$else}
{$undef CheckCppObjectTypeEnabled}
{$endif}
{$endif}
{$endif}
{$endif}

BIN
System/LibXmlComps.dcr Normal file
View File

Binary file not shown.

122
System/LibXmlComps.pas Normal file
View File

@ -0,0 +1,122 @@
(**
===============================================================================================
Name : LibXmlComps
===============================================================================================
Project : All Projects processing XML documents
===============================================================================================
Subject : XML parser for Delphi's VCL toolbar
===============================================================================================
Dipl.-Ing. (FH) Stefan Heymann, Softwaresysteme, T<>bingen, Germany
===============================================================================================
Date Author Changes
-----------------------------------------------------------------------------------------------
2000-03-31 HeySt 1.0.0 Start
2000-07-27 HeySt 1.0.1 Added "TAttr" declaration
Moved GetNormalize/SetNormalize to PROTECTED section
2001-02-03 HeySt Changed prototype for the TExternalEvent callback function type
so that C++Builder users should get it compiled better.
2001-02-28 HeySt 1.0.2 Introduced the "StopParser" property. When you set this property to
TRUE in one of the Parser Events, parsing is stopped and the Execute
method returns.
Introduced Version numbers
2001-07-10 HeySt 1.0.3 Fixed a bug in TScannerXmlParser.DtdElementFound so that the
OnAttList event is correctly fired
2001-07-11 HeySt 1.1.0 Derived from the new TCustomXmlScanner class from LibXmlParser
2005-07-07 HeySt 1.1.1 Published new TranslateCharacter event property
*)
UNIT LibXmlComps;
INTERFACE
USES
Classes,
LibXmlParser;
TYPE
TXmlScanner = CLASS (TCustomXmlScanner)
PUBLIC
PROPERTY XmlParser;
PROPERTY StopParser;
PUBLISHED
PROPERTY Filename;
PROPERTY Normalize;
PROPERTY OnXmlProlog;
PROPERTY OnComment;
PROPERTY OnPI;
PROPERTY OnDtdRead;
PROPERTY OnStartTag;
PROPERTY OnEmptyTag;
PROPERTY OnEndTag;
PROPERTY OnContent;
PROPERTY OnCData;
PROPERTY OnElement;
PROPERTY OnAttList;
PROPERTY OnEntity;
PROPERTY OnNotation;
PROPERTY OnDtdError;
PROPERTY OnLoadExternal;
PROPERTY OnTranslateEncoding;
PROPERTY OnTranslateCharacter;
END;
// The "Easy" XML Scanner leaves out events and properties which you are unlikely to use
// for "normal" XML files.
// CDATA sections trigger "OnContent" events
TEasyXmlScanner = CLASS (TCustomXmlScanner)
PROTECTED
PROCEDURE WhenCData (Content : string); OVERRIDE;
PUBLIC
PROPERTY XmlParser;
PROPERTY StopParser;
PUBLISHED
PROPERTY Filename;
PROPERTY Normalize;
PROPERTY OnComment;
PROPERTY OnPI;
PROPERTY OnStartTag;
PROPERTY OnEmptyTag;
PROPERTY OnEndTag;
PROPERTY OnContent;
PROPERTY OnLoadExternal;
PROPERTY OnTranslateEncoding;
END;
PROCEDURE Register;
(*
===============================================================================================
IMPLEMENTATION
===============================================================================================
*)
IMPLEMENTATION
PROCEDURE Register;
BEGIN
RegisterComponents ('XML', [TXmlScanner, TEasyXmlScanner]);
END;
(*
===============================================================================================
TEasyXmlScanner
===============================================================================================
*)
PROCEDURE TEasyXmlScanner.WhenCData (Content : string);
BEGIN
INHERITED WhenContent (Content);
END;
(*
===============================================================================================
INITIALIZATION
===============================================================================================
*)
END.

2719
System/LibXmlParser.pas Normal file
View File

File diff suppressed because it is too large Load Diff

71
System/NativeXml.inc Normal file
View File

@ -0,0 +1,71 @@
{ unit NativeXml.inc
Nativexml a small-footprint implementation to read and write XML documents
natively from Delpi code. NativeXml has very fast parsing speeds.
Author: Nils Haeck M.Sc.
Copyright (c) 2007 - 2010 Simdesign B.V.
It is NOT allowed under ANY circumstances to publish, alter or copy this code
without accepting the license conditions in accompanying LICENSE.txt
first!
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
ANY KIND, either express or implied.
Please visit http://www.simdesign.nl/xml.html for more information.
}
// Delphi and BCB versions
// Freepascal (MK)
{$ifdef FPC}
{$MODE DELPHI}
{$define D7UP}
{$endif FPC}
//Delphi 7
{$ifdef VER150}
{$define D7UP}
{$endif}
//Delphi 8
{$ifdef VER160}
{$define D7UP}
{$endif}
// Delphi 2005
{$ifdef VER170}
{$define D7UP}
{$endif}
// Delphi 2006
{$ifdef VER180}
{$define D7UP}
{$endif}
// Delphi 2007 - NET
{$ifdef VER190}
{$define D7UP}
{$endif}
// Delphi 2009
{$ifdef VER200}
{$define D7UP}
{$define D12UP}
{$endif}
// Delphi 2010
{$ifdef VER210}
{$define D7UP}
{$define D12UP}
{$endif}
// Delphi XE
{$ifdef VER220}
{$define D7UP}
{$define D12UP}
{$define D15UP}
{$endif}
// Uncomment to save memory space for large documents if you don't need tags.
// Tags are an additional integer field that can be used by the application.
{$define USETAGS}
// uncomment if you do not want to include the Graphics unit.
{$define USEGRAPHICS}
// uncomment if you do not want line number/position info from the source file
{$define SOURCEPOS}

6372
System/NativeXml.pas Normal file
View File

File diff suppressed because it is too large Load Diff

243
System/NativeXmlAppend.pas Normal file
View File

@ -0,0 +1,243 @@
{
Unit NativeXmlAppend
This unit implements a method to add XML fragments to the end of an existing
XML file that resides on disk. The file is never loaded completely into memory,
the new data will be appended at the end.
This unit requires NativeXml.
Possible exceptions (apart from the regular ones for file access):
'Reverse read past beginning of stream':
The file provided in S is not an XML file or it is an XML file with not enough
levels. The XML file should have in its last tag at least ALevel levels of
elements. Literally this exception means that the algorithm went backwards
through the complete file and arrived at the beginning, without finding a
suitable position to insert the node data.
'Level cannot be found'
This exception will be raised when the last element does not contain enough
levels, so the algorithm encounters an opening tag where it would expect a
closing tag.
Example:
We try to add a node at level 3 in this XML file
<Root>
<Level1>
<Level2>
</Level2>
</Level1>
<Level1> <-- This last node does not have a level2, so the algorithm
</Level1> does not know where to add the data of level 3 under level2
</Root>
See Example4 for an implementation
Original Author: Nils Haeck M.Sc.
Copyright (c) 2003-2009 Simdesign B.V.
It is NOT allowed under ANY circumstances to publish or copy this code
without accepting the license conditions in accompanying LICENSE.txt
first!
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
ANY KIND, either express or implied.
Please visit http://www.simdesign.nl/xml.html for more information.
}
unit NativeXmlAppend;
interface
{$I NativeXml.inc}
uses
Classes, SysUtils, Dialogs, NativeXml;
type
ustring = UTF8String;
// With this routine we can add a single node (TXmlNode) to an existing XML file.
// The file will NOT be read in completely, the data will simply be appended at the
// end. In order to do this, the file is scanned from the end until the last node
// at ALevel levels deep is located.
// ALevel = 0 would add the new node at the very end. This is not wise, since XML
// does not allow more than one root node. Choose ALevel = 1 to add the new node
// at the first level under the root (default).
// <p>
// TIP: If you want to start with an empty (template) XmlDocument, make sure to
// set TsdXmlDocument.UseFullNodes to True before saving it. This ensures that
// the append function will work correctly on the root node.
// <p>
// NOTE 1: This method does not work for unicode files.
procedure XmlAppendToExistingFile(const AFilename: string; ANode: TXmlNode;
ALevel: integer {$IFDEF D4UP}= 1{$ENDIF});
implementation
type
// We need this class to get access to protected method WriteToString
THackNode = class(TXmlNode);
TTagType = record
FClose: string;
FStart: string;
end;
const
// Reversed tags, note: the record fields are also in reversed order. This
// is because we read backwards
cTagCount = 4;
cTags: array[0..cTagCount - 1] of TTagType = (
// The order is important here; the items are searched for in appearing order
(FClose: '>]]'; FStart: '[ATADC[!<'), // CDATA
(FClose: '>--'; FStart: '--!<'), // Comment
(FClose: '>?'; FStart: '?<'), // <?{something}?>
(FClose: '>'; FStart: '<') // Any other
);
function ScanBackwards(S: TStream): char;
begin
if S.Position = 0 then
raise Exception.Create('Reverse read past beginning of stream');
S.Seek(-1, soFromCurrent);
S.Read(Result, 1);
S.Seek(-1, soFromCurrent);
end;
function ReverseReadCloseTag(S: TStream): integer;
// Try to read the type of close tag from S, in reversed order
var
AIndex, i: integer;
Found: boolean;
Ch: char;
begin
Result := cTagCount - 1;
AIndex := 1;
repeat
Found := False;
inc(AIndex);
Ch := ScanBackwards(S);
for i := cTagCount - 1 downto 0 do begin
if length(cTags[i].FClose) >= AIndex then
if cTags[i].FClose[AIndex] = Ch then begin
Found := True;
Result := i;
break;
end;
end;
until Found = False;
// Increase position again because we read too far
S.Seek(1, soFromCurrent);
end;
procedure ReverseReadFromStreamUntil(S: TStream; const ASearch: string;
var AValue: string);
// Read the tag in reversed order. We are looking for the string in ASearch
// (in reversed order). AValue will contain the tag when done (in correct order).
var
AIndex: integer;
Ch: char;
begin
AIndex := 1;
AValue := '';
while AIndex <= length(ASearch) do begin
Ch := ScanBackwards(S);
AValue := Ch + AValue;
if ASearch[AIndex] = Ch then
inc(AIndex)
else
AIndex := 1;
end;
AValue := copy(AValue, Length(ASearch) + 1, length(AValue));
end;
function XmlScanNodeFromEnd(S: TStream; ALevel: integer): integer;
// Scan the stream S from the end and find the end of node at level ALevel
var
Ch: char;
ATagIndex: integer;
AValue: string;
begin
S.Seek(0, soFromEnd);
while ALevel > 0 do begin
Ch := ScanBackwards(S);
if Ch = '>' then begin
// Determine tag type from closing tag
ATagIndex := ReverseReadCloseTag(S);
// Try to find the start
ReverseReadFromStreamUntil(S, cTags[ATagIndex].FStart, AValue);
// We found the start, now decide what to do. We only decrease
// level if this is a closing tag. If it is an opening tag, we
// should raise an exception
if (ATagIndex = 3) then begin
if (Length(AValue) > 0) and (AValue[1] = '/') then
dec(ALevel)
else
raise Exception.Create('Level cannot be found');
end;
end;
end;
Result := S.Position;
end;
procedure StreamInsertString(S: TStream; APos: integer; Value: string);
// Insert Value into stream S at position APos. The stream S (if it is a disk
// file) should have write access!
var
ASize: integer;
M: TMemoryStream;
begin
// Nothing to do if no value
if Length(Value) = 0 then exit;
S.Position := APos;
ASize := S.Size - S.Position;
// Create intermediate memory stream that holds the new ending
M := TMemoryStream.Create;
try
// Create a copy into a memory stream that contains new insert + old last part
M.SetSize(ASize + Length(Value));
M.Write(Value[1], Length(Value));
M.CopyFrom(S, ASize);
// Now add this copy at the current position
M.Position := 0;
S.Position := APos;
S.CopyFrom(M, M.Size);
finally
M.Free;
end;
end;
procedure XmlAppendToExistingFile(const AFilename: string; ANode: TXmlNode;
ALevel: integer);
// With this routine we can add a single node (TXmlNode) to an existing XML file.
// The file will NOT be read in completely, the data will simply be appended at the
// end. In order to do this, the file is scanned from the end until the last node
// at ALevel levels deep is located.
// ALevel = 0 would add the new node at the very end. This is not wise, since XML
// does not allow more than one root node. Choose ALevel = 1 to add the new node
// at the first level under the root (default).
var
S: TStream;
APos: integer;
AInsert: ustring;
begin
// Open the file with Read/Write access
S := TFileStream.Create(AFilename, fmOpenReadWrite or fmShareDenyWrite);
try
// After a successful open, we can locate the correct end of node
APos := XmlScanNodeFromEnd(S, ALevel);
// Still no exceptions, this means we found a valid position.. now insert the
// new node in here.
AInsert := THackNode(ANode).WriteToString;
// Now we happily insert the string into the opened stream at the right position
StreamInsertString(S, APos, string(AInsert));
finally
// We're done, close the stream, this will save the modified filestream
S.Free;
end;
end;
end.

1273
System/NativeXmlObjectStorage.pas Normal file
View File

File diff suppressed because it is too large Load Diff

924
System/PerlRegEx.pas Normal file
View File

@ -0,0 +1,924 @@
{**************************************************************************************************}
{ }
{ Perl Regular Expressions VCL component }
{ }
{ 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 PerlRegEx.pas. }
{ }
{ The Initial Developer of the Original Code is Jan Goyvaerts. }
{ Portions created by Jan Goyvaerts are Copyright (C) 1999, 2005, 2008 Jan Goyvaerts. }
{ All rights reserved. }
{ }
{ Design & implementation, by Jan Goyvaerts, 1999, 2005, 2008 }
{ }
{ TPerlRegEx is available at http://www.regular-expressions.info/delphi.html }
{ }
{**************************************************************************************************}
unit PerlRegEx;
interface
uses
Windows, Messages, SysUtils, Classes,
pcre;
type
TPerlRegExOptions = set of (
preCaseLess, // /i -> Case insensitive
preMultiLine, // /m -> ^ and $ also match before/after a newline, not just at the beginning and the end of the PCREString
preSingleLine, // /s -> Dot matches any character, including \n (newline). Otherwise, it matches anything except \n
preExtended, // /x -> Allow regex to contain extra whitespace, newlines and Perl-style comments, all of which will be filtered out
preAnchored, // /A -> Successful match can only occur at the start of the subject or right after the previous match
preUnGreedy, // Repeat operators (+, *, ?) are not greedy by default (i.e. they try to match the minimum number of characters instead of the maximum)
preNoAutoCapture // (group) is a non-capturing group; only named groups capture
);
type
TPerlRegExState = set of (
preNotBOL, // Not Beginning Of Line: ^ does not match at the start of Subject
preNotEOL, // Not End Of Line: $ does not match at the end of Subject
preNotEmpty // Empty matches not allowed
);
const
// Maximum number of subexpressions (backreferences)
// Subexpressions are created by placing round brackets in the regex, and are referenced by \1, \2, ...
// In Perl, they are available as $1, $2, ... after the regex matched; with TPerlRegEx, use the Subexpressions property
// You can also insert \1, \2, ... in the Replacement PCREString; \0 is the complete matched expression
MAX_SUBEXPRESSIONS = 99;
{$IFDEF UNICODE}
// All implicit string casts have been verified to be correct
{$WARN IMPLICIT_STRING_CAST OFF}
// Use UTF-8 in Delphi 2009 and later, so Unicode strings are handled correctly.
// PCRE does not support UTF-16
type
PCREString = UTF8String;
{$ELSE UNICODE}
// Use AnsiString in Delphi 2007 and earlier
type
PCREString = AnsiString;
{$ENDIF UNICODE}
type
TPerlRegExReplaceEvent = procedure(Sender: TObject; var ReplaceWith: PCREString) of object;
type
TPerlRegEx = class(TComponent)
private // *** Property storage, getters and setters
FCompiled, FStudied: Boolean;
FOptions: TPerlRegExOptions;
FState: TPerlRegExState;
FRegEx, FReplacement, FSubject: PCREString;
FStart, FStop: Integer;
FOnMatch: TNotifyEvent;
FOnReplace: TPerlRegExReplaceEvent;
function GetMatchedExpression: PCREString;
function GetMatchedExpressionLength: Integer;
function GetMatchedExpressionOffset: Integer;
procedure SetOptions(Value: TPerlRegExOptions);
procedure SetRegEx(const Value: PCREString);
function GetSubExpressionCount: Integer;
function GetSubExpressions(Index: Integer): PCREString;
function GetSubExpressionLengths(Index: Integer): Integer;
function GetSubExpressionOffsets(Index: Integer): Integer;
procedure SetSubject(const Value: PCREString);
procedure SetStart(const Value: Integer);
procedure SetStop(const Value: Integer);
function GetFoundMatch: Boolean;
private // *** Variables used by pcrelib.dll
Offsets: array[0..(MAX_SUBEXPRESSIONS+1)*3] of Integer;
OffsetCount: Integer;
pcreOptions: Integer;
pattern, hints, chartable: Pointer;
FSubjectPChar: PAnsiChar;
FHasStoredSubExpressions: Boolean;
FStoredSubExpressions: array of PCREString;
function GetSubjectLeft: PCREString;
function GetSubjectRight: PCREString;
protected
procedure CleanUp;
// Dispose off whatever we created, so we can start over. Called automatically when needed, so it is not made public
procedure ClearStoredSubExpressions;
public
constructor Create(AOwner: TComponent); override;
// Come to life
destructor Destroy; override;
// Clean up after ourselves
class function EscapeRegExChars(const S: string): string;
// Escapes regex characters in S so that the regex engine can be used to match S as plain text
procedure Compile;
// Compile the regex. Called automatically by Match
procedure Study;
// Study the regex. Studying takes time, but will make the execution of the regex a lot faster.
// Call study if you will be using the same regex many times
function Match: Boolean;
// Attempt to match the regex
function MatchAgain: Boolean;
// Attempt to match the regex to the remainder of the string after the previous match
// To avoid problems (when using ^ in the regex), call MatchAgain only after a succesful Match()
function Replace: PCREString;
// Replace matched expression in Subject with ComputeReplacement. Returns the actual replacement text from ComputeReplacement
function ReplaceAll: Boolean;
// Repeat MatchAgain and Replace until you drop. Returns True if anything was replaced at all.
function ComputeReplacement: PCREString;
// Returns Replacement with backreferences filled in
procedure StoreSubExpressions;
// Stores duplicates of SubExpressions[] so they and ComputeReplacement will still return the proper strings
// even if FSubject is changed or cleared
function NamedSubExpression(const SEName: PCREString): Integer;
// Returns the index of the named group SEName
procedure Split(Strings: TStrings; Limit: Integer);
// Split Subject along regex matches. Items are appended to PCREStrings.
property Compiled: Boolean read FCompiled;
// True if the RegEx has already been compiled.
property FoundMatch: Boolean read GetFoundMatch;
// Returns True when MatchedExpression* and SubExpression* indicate a match
property Studied: Boolean read FStudied;
// True if the RegEx has already been studied
property MatchedExpression: PCREString read GetMatchedExpression;
// The matched PCREString
property MatchedExpressionLength: Integer read GetMatchedExpressionLength;
// Length of the matched PCREString
property MatchedExpressionOffset: Integer read GetMatchedExpressionOffset;
// Character offset in the Subject PCREString at which the matched subPCREString starts
property Start: Integer read FStart write SetStart;
// Starting position in Subject from which MatchAgain begins
property Stop: Integer read FStop write SetStop;
// Last character in Subject that Match and MatchAgain search through
property State: TPerlRegExState read FState write FState;
// State of Subject
property SubExpressionCount: Integer read GetSubExpressionCount;
// Number of matched subexpressions
property SubExpressions[Index: Integer]: PCREString read GetSubExpressions;
// Matched subexpressions after a regex has been matched
property SubExpressionLengths[Index: Integer]: Integer read GetSubExpressionLengths;
// Lengths of the subexpressions
property SubExpressionOffsets[Index: Integer]: Integer read GetSubExpressionOffsets;
// Character offsets in the Subject PCREString of the subexpressions
property Subject: PCREString read FSubject write SetSubject;
// The PCREString on which Match() will try to match RegEx
property SubjectLeft: PCREString read GetSubjectLeft;
// Part of the subject to the left of the match
property SubjectRight: PCREString read GetSubjectRight;
// Part of the subject to the right of the match
published
property Options: TPerlRegExOptions read FOptions write SetOptions;
// Options
property RegEx: PCREString read FRegEx write SetRegEx;
// The regular expression to be matched
property Replacement: PCREString read FReplacement write FReplacement;
// PCREString to replace matched expression with. \number backreferences will be substituted with SubExpressions
// TPerlRegEx supports the "JGsoft" replacement text flavor as explained at http://www.regular-expressions.info/refreplace.html
property OnMatch: TNotifyEvent read FOnMatch write FOnMatch;
// Triggered by Match and MatchAgain after a successful match
property OnReplace: TPerlRegExReplaceEvent read FOnReplace write FOnReplace;
// Triggered by Replace and ReplaceAll just before the replacement is done, allowing you to determine the new PCREString
end;
{
You can add TPerlRegEx components to a TPerlRegExList to match them all together on the same subject,
as if they were one regex regex1|regex2|regex3|...
TPerlRegExList does not own the TPerlRegEx components, just like a TList
If a TPerlRegEx has been added to a TPerlRegExList, it should not be used in any other situation
until it is removed from the list
}
type
TPerlRegExList = class
private
FList: TList;
FSubject: PCREString;
FMatchedRegEx: TPerlRegEx;
FStart, FStop: Integer;
function GetRegEx(Index: Integer): TPerlRegEx;
procedure SetRegEx(Index: Integer; Value: TPerlRegEx);
procedure SetSubject(const Value: PCREString);
procedure SetStart(const Value: Integer);
procedure SetStop(const Value: Integer);
function GetCount: Integer;
protected
procedure UpdateRegEx(ARegEx: TPerlRegEx);
public
constructor Create;
destructor Destroy; override;
public
function Add(ARegEx: TPerlRegEx): Integer;
procedure Clear;
procedure Delete(Index: Integer);
function IndexOf(ARegEx: TPerlRegEx): Integer;
procedure Insert(Index: Integer; ARegEx: TPerlRegEx);
public
function Match: Boolean;
function MatchAgain: Boolean;
property RegEx[Index: Integer]: TPerlRegEx read GetRegEx write SetRegEx;
property Count: Integer read GetCount;
property Subject: PCREString read FSubject write SetSubject;
property Start: Integer read FStart write SetStart;
property Stop: Integer read FStop write SetStop;
property MatchedRegEx: TPerlRegEx read FMatchedRegEx;
end;
procedure Register;
implementation
{ ********* Unit support routines ********* }
procedure Register;
begin
RegisterComponents('JGsoft', [TPerlRegEx]);
end;
function FirstCap(const S: string): string;
begin
if S = '' then Result := ''
else begin
Result := AnsiLowerCase(S);
{$IFDEF UNICODE}
CharUpperBuffW(@Result[1], 1);
{$ELSE}
CharUpperBuffA(@Result[1], 1);
{$ENDIF}
end
end;
function InitialCaps(const S: string): string;
var
I: Integer;
Up: Boolean;
begin
Result := AnsiLowerCase(S);
Up := True;
{$IFDEF UNICODE}
for I := 1 to Length(Result) do begin
case Result[I] of
#0..'&', '(', '*', '+', ',', '-', '.', '?', '<', '[', '{', #$00B7:
Up := True
else
if Up and (Result[I] <> '''') then begin
CharUpperBuffW(@Result[I], 1);
Up := False
end
end;
end;
{$ELSE UNICODE}
if SysLocale.FarEast then begin
I := 1;
while I <= Length(Result) do begin
if Result[I] in LeadBytes then begin
Inc(I, 2)
end
else begin
if Result[I] in [#0..'&', '('..'.', '?', '<', '[', '{'] then Up := True
else if Up and (Result[I] <> '''') then begin
CharUpperBuffA(@Result[I], 1);
Result[I] := UpperCase(Result[I])[1];
Up := False
end;
Inc(I)
end
end
end
else
for I := 1 to Length(Result) do begin
if Result[I] in [#0..'&', '('..'.', '?', '<', '[', '{', #$B7] then Up := True
else if Up and (Result[I] <> '''') then begin
CharUpperBuffA(@Result[I], 1);
Result[I] := AnsiUpperCase(Result[I])[1];
Up := False
end
end;
{$ENDIF UNICODE}
end;
{ ********* TPerlRegEx component ********* }
procedure TPerlRegEx.CleanUp;
begin
FCompiled := False; FStudied := False;
pcre_dispose(pattern, hints, nil);
pattern := nil;
hints := nil;
ClearStoredSubExpressions;
OffsetCount := 0;
end;
procedure TPerlRegEx.ClearStoredSubExpressions;
begin
FHasStoredSubExpressions := False;
FStoredSubExpressions := nil;
end;
procedure TPerlRegEx.Compile;
var
Error: PAnsiChar;
ErrorOffset: Integer;
begin
if FRegEx = '' then
raise Exception.Create('TPerlRegEx.Compile() - Please specify a regular expression in RegEx first');
CleanUp;
Pattern := pcre_compile(PAnsiChar(FRegEx), pcreOptions, @Error, @ErrorOffset, chartable);
if Pattern = nil then
raise Exception.Create(Format('TPerlRegEx.Compile() - Error in regex at offset %d: %s', [ErrorOffset, AnsiString(Error)]));
FCompiled := True
end;
(* Backreference overview:
Assume there are 13 backreferences:
Text TPerlRegex .NET Java ECMAScript
$17 $1 + "7" "$17" $1 + "7" $1 + "7"
$017 $1 + "7" "$017" $1 + "7" $1 + "7"
$12 $12 $12 $12 $12
$012 $1 + "2" $12 $12 $1 + "2"
${1}2 $1 + "2" $1 + "2" error "${1}2"
$$ "$" "$" error "$"
\$ "$" "\$" "$" "\$"
*)
function TPerlRegEx.ComputeReplacement: PCREString;
var
Mode: AnsiChar;
S: PCREString;
I, J, N: Integer;
procedure ReplaceBackreference(Number: Integer);
var
Backreference: PCREString;
begin
Delete(S, I, J-I);
if Number <= SubExpressionCount then begin
Backreference := SubExpressions[Number];
if Backreference <> '' then begin
// Ignore warnings; converting to UTF-8 does not cause data loss
case Mode of
'L', 'l': Backreference := AnsiLowerCase(Backreference);
'U', 'u': Backreference := AnsiUpperCase(Backreference);
'F', 'f': Backreference := FirstCap(Backreference);
'I', 'i': Backreference := InitialCaps(Backreference);
end;
if S <> '' then begin
Insert(Backreference, S, I);
I := I + Length(Backreference);
end
else begin
S := Backreference;
I := MaxInt;
end
end;
end
end;
procedure ProcessBackreference(NumberOnly, Dollar: Boolean);
var
Number, Number2: Integer;
Group: PCREString;
begin
Number := -1;
if (J <= Length(S)) and (S[J] in ['0'..'9']) then begin
// Get the number of the backreference
Number := Ord(S[J]) - Ord('0');
Inc(J);
if (J <= Length(S)) and (S[J] in ['0'..'9']) then begin
// Expand it to two digits only if that would lead to a valid backreference
Number2 := Number*10 + Ord(S[J]) - Ord('0');
if Number2 <= SubExpressionCount then begin
Number := Number2;
Inc(J)
end;
end;
end
else if not NumberOnly then begin
if Dollar and (J < Length(S)) and (S[J] = '{') then begin
// Number or name in curly braces
Inc(J);
case S[J] of
'0'..'9': begin
Number := Ord(S[J]) - Ord('0');
Inc(J);
while (J <= Length(S)) and (S[J] in ['0'..'9']) do begin
Number := Number*10 + Ord(S[J]) - Ord('0');
Inc(J)
end;
end;
'A'..'Z', 'a'..'z', '_': begin
Inc(J);
while (J <= Length(S)) and (S[J] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) do Inc(J);
if (J <= Length(S)) and (S[J] = '}') then begin
Group := Copy(S, I+2, J-I-2);
Number := NamedSubExpression(Group);
end
end;
end;
if (J > Length(S)) or (S[J] <> '}') then Number := -1
else Inc(J)
end
else if Dollar and (S[J] = '_') then begin
// $_ (whole subject)
Delete(S, I, J+1-I);
Insert(Subject, S, I);
I := I + Length(Subject);
Exit;
end
else case S[J] of
'&': begin
// \& or $& (whole regex match)
Number := 0;
Inc(J);
end;
'+': begin
// \+ or $+ (highest-numbered participating group)
Number := SubExpressionCount;
Inc(J);
end;
'`': begin
// \` or $` (backtick; subject to the left of the match)
Delete(S, I, J+1-I);
Insert(SubjectLeft, S, I);
I := I + Offsets[0] - 1;
Exit;
end;
'''': begin
// \' or $' (straight quote; subject to the right of the match)
Delete(S, I, J+1-I);
Insert(SubjectRight, S, I);
I := I + Length(Subject) - Offsets[1];
Exit;
end
end;
end;
if Number >= 0 then ReplaceBackreference(Number)
else Inc(I)
end;
begin
S := FReplacement;
I := 1;
while I < Length(S) do begin
case S[I] of
'\': begin
J := I + 1;
Assert(J <= Length(S), 'CHECK: We let I stop one character before the end, so J cannot point beyond the end of the PCREString here');
case S[J] of
'$', '\': begin
Delete(S, I, 1);
Inc(I);
end;
'g': begin
if (J < Length(S)-1) and (S[J+1] = '<') and (S[J+2] in ['A'..'Z', 'a'..'z', '_']) then begin
// Python-style named group reference \g<name>
J := J+3;
while (J <= Length(S)) and (S[J] in ['0'..'9', 'A'..'Z', 'a'..'z', '_']) do Inc(J);
if (J <= Length(S)) and (S[J] = '>') then begin
N := NamedSubExpression(Copy(S, I+3, J-I-3));
Inc(J);
Mode := #0;
if N > 0 then ReplaceBackreference(N)
else Delete(S, I, J-I)
end
else I := J
end
else I := I+2;
end;
'l', 'L', 'u', 'U', 'f', 'F', 'i', 'I': begin
Mode := S[J];
Inc(J);
ProcessBackreference(True, False);
end;
else begin
Mode := #0;
ProcessBackreference(False, False);
end;
end;
end;
'$': begin
J := I + 1;
Assert(J <= Length(S), 'CHECK: We let I stop one character before the end, so J cannot point beyond the end of the PCREString here');
if S[J] = '$' then begin
Delete(S, J, 1);
Inc(I);
end
else begin
Mode := #0;
ProcessBackreference(False, True);
end
end;
else Inc(I)
end
end;
Result := S
end;
constructor TPerlRegEx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FState := [preNotEmpty];
chartable := pcre_maketables;
{$IFDEF UNICODE}
pcreOptions := PCRE_UTF8 or PCRE_NEWLINE_ANY;
{$ELSE}
pcreOptions := PCRE_NEWLINE_ANY;
{$ENDIF}
end;
destructor TPerlRegEx.Destroy;
begin
pcre_dispose(pattern, hints, chartable);
inherited Destroy;
end;
class function TPerlRegEx.EscapeRegExChars(const S: string): string;
var
I: Integer;
begin
Result := S;
I := Length(Result);
while I > 0 do begin
case Result[I] of
'.', '[', ']', '(', ')', '?', '*', '+', '{', '}', '^', '$', '|', '\':
Insert('\', Result, I);
#0: begin
Result[I] := '0';
Insert('\', Result, I);
end;
end;
Dec(I);
end;
end;
function TPerlRegEx.GetFoundMatch: Boolean;
begin
Result := OffsetCount > 0;
end;
function TPerlRegEx.GetMatchedExpression: PCREString;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Result := GetSubExpressions(0);
end;
function TPerlRegEx.GetMatchedExpressionLength: Integer;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Result := GetSubExpressionLengths(0)
end;
function TPerlRegEx.GetMatchedExpressionOffset: Integer;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Result := GetSubExpressionOffsets(0)
end;
function TPerlRegEx.GetSubExpressionCount: Integer;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Result := OffsetCount-1
end;
function TPerlRegEx.GetSubExpressionLengths(Index: Integer): Integer;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Assert((Index >= 0) and (Index <= SubExpressionCount), 'REQUIRE: Index <= SubExpressionCount');
Result := Offsets[Index*2+1]-Offsets[Index*2]
end;
function TPerlRegEx.GetSubExpressionOffsets(Index: Integer): Integer;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
Assert((Index >= 0) and (Index <= SubExpressionCount), 'REQUIRE: Index <= SubExpressionCount');
Result := Offsets[Index*2]
end;
function TPerlRegEx.GetSubExpressions(Index: Integer): PCREString;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
if Index > SubExpressionCount then Result := ''
else if FHasStoredSubExpressions then Result := FStoredSubExpressions[Index]
else Result := Copy(FSubject, Offsets[Index*2], Offsets[Index*2+1]-Offsets[Index*2]);
end;
function TPerlRegEx.GetSubjectLeft: PCREString;
begin
Result := Copy(Subject, 1, Offsets[0]-1);
end;
function TPerlRegEx.GetSubjectRight: PCREString;
begin
Result := Copy(Subject, Offsets[1], MaxInt);
end;
function TPerlRegEx.Match: Boolean;
var
I, Opts: Integer;
begin
ClearStoredSubExpressions;
if not Compiled then Compile;
if preNotBOL in State then Opts := PCRE_NOTBOL else Opts := 0;
if preNotEOL in State then Opts := Opts or PCRE_NOTEOL;
if preNotEmpty in State then Opts := Opts or PCRE_NOTEMPTY;
OffsetCount := pcre_exec(Pattern, Hints, FSubjectPChar, FStop, 0, Opts, @Offsets[0], High(Offsets));
Result := OffsetCount > 0;
// Convert offsets into PCREString indices
if Result then begin
for I := 0 to OffsetCount*2-1 do
Inc(Offsets[I]);
FStart := Offsets[1];
if Offsets[0] = Offsets[1] then Inc(FStart); // Make sure we don't get stuck at the same position
if Assigned(OnMatch) then OnMatch(Self)
end;
end;
function TPerlRegEx.MatchAgain: Boolean;
var
I, Opts: Integer;
begin
ClearStoredSubExpressions;
if not Compiled then Compile;
if preNotBOL in State then Opts := PCRE_NOTBOL else Opts := 0;
if preNotEOL in State then Opts := Opts or PCRE_NOTEOL;
if preNotEmpty in State then Opts := Opts or PCRE_NOTEMPTY;
if FStart-1 > FStop then OffsetCount := -1
else OffsetCount := pcre_exec(Pattern, Hints, FSubjectPChar, FStop, FStart-1, Opts, @Offsets[0], High(Offsets));
Result := OffsetCount > 0;
// Convert offsets into PCREString indices
if Result then begin
for I := 0 to OffsetCount*2-1 do
Inc(Offsets[I]);
FStart := Offsets[1];
if Offsets[0] = Offsets[1] then Inc(FStart); // Make sure we don't get stuck at the same position
if Assigned(OnMatch) then OnMatch(Self)
end;
end;
function TPerlRegEx.NamedSubExpression(const SEName: PCREString): Integer;
begin
Result := pcre_get_stringnumber(Pattern, PAnsiChar(SEName));
end;
function TPerlRegEx.Replace: PCREString;
begin
Assert(FoundMatch, 'REQUIRE: There must be a successful match first');
// Substitute backreferences
Result := ComputeReplacement;
// Allow for just-in-time substitution determination
if Assigned(OnReplace) then OnReplace(Self, Result);
// Perform substitution
Delete(FSubject, MatchedExpressionOffset, MatchedExpressionLength);
if Result <> '' then Insert(Result, FSubject, MatchedExpressionOffset);
FSubjectPChar := PAnsiChar(FSubject);
// Position to continue search
FStart := FStart - MatchedExpressionLength + Length(Result);
FStop := FStop - MatchedExpressionLength + Length(Result);
// Replacement no longer matches regex, we assume
ClearStoredSubExpressions;
OffsetCount := 0;
end;
function TPerlRegEx.ReplaceAll: Boolean;
begin
if Match then begin
Result := True;
repeat
Replace
until not MatchAgain;
end
else Result := False;
end;
procedure TPerlRegEx.SetOptions(Value: TPerlRegExOptions);
begin
if (FOptions <> Value) then begin
FOptions := Value;
{$IFDEF UNICODE}
pcreOptions := PCRE_UTF8 or PCRE_NEWLINE_ANY;
{$ELSE}
pcreOptions := PCRE_NEWLINE_ANY;
{$ENDIF}
if (preCaseLess in Value) then pcreOptions := pcreOptions or PCRE_CASELESS;
if (preMultiLine in Value) then pcreOptions := pcreOptions or PCRE_MULTILINE;
if (preSingleLine in Value) then pcreOptions := pcreOptions or PCRE_DOTALL;
if (preExtended in Value) then pcreOptions := pcreOptions or PCRE_EXTENDED;
if (preAnchored in Value) then pcreOptions := pcreOptions or PCRE_ANCHORED;
if (preUnGreedy in Value) then pcreOptions := pcreOptions or PCRE_UNGREEDY;
if (preNoAutoCapture in Value) then pcreOptions := pcreOptions or PCRE_NO_AUTO_CAPTURE;
CleanUp
end
end;
procedure TPerlRegEx.SetRegEx(const Value: PCREString);
begin
if FRegEx <> Value then begin
FRegEx := Value;
CleanUp
end
end;
procedure TPerlRegEx.SetStart(const Value: Integer);
begin
if Value < 1 then FStart := 1
else FStart := Value;
// If FStart > Length(Subject), MatchAgain() will simply return False
end;
procedure TPerlRegEx.SetStop(const Value: Integer);
begin
if Value > Length(Subject) then FStop := Length(Subject)
else FStop := Value;
end;
procedure TPerlRegEx.SetSubject(const Value: PCREString);
begin
FSubject := Value;
FSubjectPChar := PAnsiChar(Value);
FStart := 1;
FStop := Length(Subject);
if not FHasStoredSubExpressions then OffsetCount := 0;
end;
procedure TPerlRegEx.Split(Strings: TStrings; Limit: Integer);
var
Offset, Count: Integer;
begin
Assert(Strings <> nil, 'REQUIRE: Strings');
if (Limit = 1) or not Match then Strings.Add(Subject)
else begin
Offset := 1;
Count := 1;
repeat
Strings.Add(Copy(Subject, Offset, MatchedExpressionOffset - Offset));
Inc(Count);
Offset := MatchedExpressionOffset + MatchedExpressionLength;
until ((Limit > 1) and (Count >= Limit)) or not MatchAgain;
Strings.Add(Copy(Subject, Offset, MaxInt));
end
end;
procedure TPerlRegEx.StoreSubExpressions;
var
I: Integer;
begin
if OffsetCount > 0 then begin
ClearStoredSubExpressions;
SetLength(FStoredSubExpressions, SubExpressionCount+1);
for I := SubExpressionCount downto 0 do
FStoredSubExpressions[I] := SubExpressions[I];
FHasStoredSubExpressions := True;
end
end;
procedure TPerlRegEx.Study;
var
Error: PAnsiChar;
begin
if not FCompiled then Compile;
Hints := pcre_study(Pattern, 0, @Error);
if Error <> nil then
raise Exception.Create('TPerlRegEx.Study() - Error studying the regex: ' + AnsiString(Error));
FStudied := True
end;
{ TPerlRegExList }
function TPerlRegExList.Add(ARegEx: TPerlRegEx): Integer;
begin
Result := FList.Add(ARegEx);
UpdateRegEx(ARegEx);
end;
procedure TPerlRegExList.Clear;
begin
FList.Clear;
end;
constructor TPerlRegExList.Create;
begin
inherited Create;
FList := TList.Create;
end;
procedure TPerlRegExList.Delete(Index: Integer);
begin
FList.Delete(Index);
end;
destructor TPerlRegExList.Destroy;
begin
FList.Free;
inherited
end;
function TPerlRegExList.GetCount: Integer;
begin
Result := FList.Count;
end;
function TPerlRegExList.GetRegEx(Index: Integer): TPerlRegEx;
begin
Result := TPerlRegEx(Pointer(FList[Index]));
end;
function TPerlRegExList.IndexOf(ARegEx: TPerlRegEx): Integer;
begin
Result := FList.IndexOf(ARegEx);
end;
procedure TPerlRegExList.Insert(Index: Integer; ARegEx: TPerlRegEx);
begin
FList.Insert(Index, ARegEx);
UpdateRegEx(ARegEx);
end;
function TPerlRegExList.Match: Boolean;
begin
SetStart(1);
FMatchedRegEx := nil;
Result := MatchAgain;
end;
function TPerlRegExList.MatchAgain: Boolean;
var
I, MatchStart, MatchPos: Integer;
ARegEx: TPerlRegEx;
begin
if FMatchedRegEx <> nil then
MatchStart := FMatchedRegEx.MatchedExpressionOffset + FMatchedRegEx.MatchedExpressionLength
else
MatchStart := FStart;
FMatchedRegEx := nil;
MatchPos := MaxInt;
for I := 0 to Count-1 do begin
ARegEx := RegEx[I];
if (not ARegEx.FoundMatch) or (ARegEx.MatchedExpressionOffset < MatchStart) then begin
ARegEx.Start := MatchStart;
ARegEx.MatchAgain;
end;
if ARegEx.FoundMatch and (ARegEx.MatchedExpressionOffset < MatchPos) then begin
MatchPos := ARegEx.MatchedExpressionOffset;
FMatchedRegEx := ARegEx;
end;
if MatchPos = MatchStart then Break;
end;
Result := MatchPos < MaxInt;
end;
procedure TPerlRegExList.SetRegEx(Index: Integer; Value: TPerlRegEx);
begin
FList[Index] := Value;
UpdateRegEx(Value);
end;
procedure TPerlRegExList.SetStart(const Value: Integer);
var
I: Integer;
begin
if FStart <> Value then begin
FStart := Value;
for I := Count-1 downto 0 do
RegEx[I].Start := Value;
FMatchedRegEx := nil;
end;
end;
procedure TPerlRegExList.SetStop(const Value: Integer);
var
I: Integer;
begin
if FStop <> Value then begin
FStop := Value;
for I := Count-1 downto 0 do
RegEx[I].Stop := Value;
FMatchedRegEx := nil;
end;
end;
procedure TPerlRegExList.SetSubject(const Value: PCREString);
var
I: Integer;
begin
if FSubject <> Value then begin
FSubject := Value;
for I := Count-1 downto 0 do
RegEx[I].Subject := Value;
FMatchedRegEx := nil;
end;
end;
procedure TPerlRegExList.UpdateRegEx(ARegEx: TPerlRegEx);
begin
ARegEx.Subject := FSubject;
ARegEx.Start := FStart;
end;
end.

90
System/RegexHelper.pas Normal file
View File

@ -0,0 +1,90 @@
unit RegexHelper;
interface
uses Global, SysUtils, StrUtils, RegularExpressionsCore;
type T2Int = record
i1, i2: integer;
end;
type T2Float = record
f1, f2: extended;
end;
type TRgb = record
r, g, b: integer;
end;
function GetStringPart(text, expression: string; group: integer; def: string): string;
function GetBoolPart(text, expression: string; group: integer; def: boolean): boolean;
function GetIntPart(text, expression: string; group: integer; def: integer): integer;
function GetFloatPart(text, expression: string; group: integer; def: extended): extended;
function Get2IntPart(text, expression: string; group: integer; def: integer): T2Int;
function Get2FloatPart(text, expression: string; group: integer; def: extended): T2Float;
function GetRGBPart(text, expression: string; group: integer; def: integer): TRGB;
implementation
(* ***************************** Extract functions ******************************* *)
function GetStringPart(text, expression: string; group: integer; def: string): string;
var Regex: TPerlRegEx;
begin
Regex := TPerlRegEx.Create;
Regex.RegEx := Utf8String(expression);
Regex.Options := [preSingleLine, preCaseless];
Regex.Subject := Utf8String(text);
if Regex.Match and (Regex.GroupCount >= group) then
Result := String(Regex.Groups[group])
else Result := def;
Regex.Free;
end;
function GetBoolPart(text, expression: string; group: integer; def: boolean): boolean;
begin
Result := GetFloatPart(text, expression, group, StrToFloat(IfThen(def, '1', '0'))) <> 0;
end;
function GetIntPart(text, expression: string; group: integer; def: integer): integer;
var str: string;
begin
str := GetStringPart(text, expression, group, '');
Result := StrToIntDef(str, def);
end;
function GetFloatPart(text, expression: string; group: integer; def: extended): extended;
var str: string;
begin
str := GetStringPart(text, expression, group, '');
Result := StrToFloatDef(str, def);
end;
function Get2IntPart(text, expression: string; group: integer; def: integer): T2Int;
const expr : string = '(\d+)\s+(\d+)';
var str, s1, s2: string;
begin
str := GetStringPart(text, expression, group, IntToStr(def) + ' ' + IntToStr(def));
s1 := GetStringPart(str, expr, 1, IntToStr(def));
s2 := GetStringPart(str, expr, 2, IntToStr(def));
Result.i1 := StrToIntDef(s1, def);
Result.i2 := StrToIntDef(s2, def);
end;
function Get2FloatPart(text, expression: string; group: integer; def: extended): T2Float;
const expr : string = '([\d.eE+-]+)\s+([\d.eE+-]+)';
var str, s1, s2: string;
begin
str := GetStringPart(text, expression, group, FloatToStr(def) + ' ' + FloatToStr(def));
s1 := GetStringPart(str, expr, 1, FloatToStr(def));
s2 := GetStringPart(str, expr, 2, FloatToStr(def));
Result.f1 := StrToFloatDef(s1, def);
Result.f2 := StrToFloatDef(s2, def);
end;
function GetRGBPart(text, expression: string; group: integer; def: integer): TRGB;
const expr : string = '(\d+)\s+(\d+)\s+(\d+)';
var str, s1, s2, s3: string;
begin
str := GetStringPart(text, expression, group, IntToStr(def) + ' ' + IntToStr(def) + ' ' + IntToStr(def));
s1 := GetStringPart(str, expr, 1, IntToStr(def));
s2 := GetStringPart(str, expr, 2, IntToStr(def));
s3 := GetStringPart(str, expr, 3, IntToStr(def));
Result.r := StrToIntDef(s1, def);
Result.g := StrToIntDef(s2, def);
Result.b := StrToIntDef(s3, def);
end;
end.

155
System/Windows7.pas Normal file
View File

@ -0,0 +1,155 @@
///////////////////////////////////////////////////////////////////////////////
// LameXP - Audio Encoder Front-End
// Copyright (C) 2004-2010 LoRd_MuldeR <MuldeR2@GMX.de>
//
// This program is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License along
// with this program; if not, write to the Free Software Foundation, Inc.,
// 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
//
// http://www.gnu.org/licenses/gpl-2.0.txt
///////////////////////////////////////////////////////////////////////////////
unit Windows7;
//////////////////////////////////////////////////////////////////////////////
interface
//////////////////////////////////////////////////////////////////////////////
uses
Forms, Types, Windows, SysUtils, ComObj, Controls, Graphics;
type
TTaskBarProgressState = (tbpsNone, tbpsIndeterminate, tbpsNormal, tbpsError, tbpsPaused);
function InitializeTaskbarAPI: Boolean;
function SetTaskbarProgressState(const AState: TTaskBarProgressState): Boolean;
function SetTaskbarProgressValue(const ACurrent:UInt64; const AMax: UInt64): Boolean;
//////////////////////////////////////////////////////////////////////////////
implementation
//////////////////////////////////////////////////////////////////////////////
const
TASKBAR_CID: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}';
const
TBPF_NOPROGRESS = 0;
TBPF_INDETERMINATE = 1;
TBPF_NORMAL = 2;
TBPF_ERROR = 4;
TBPF_PAUSED = 8;
type
ITaskBarList3 = interface(IUnknown)
['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}']
function HrInit(): HRESULT; stdcall;
function AddTab(hwnd: THandle): HRESULT; stdcall;
function DeleteTab(hwnd: THandle): HRESULT; stdcall;
function ActivateTab(hwnd: THandle): HRESULT; stdcall;
function SetActiveAlt(hwnd: THandle): HRESULT; stdcall;
function MarkFullscreenWindow(hwnd: THandle; fFullscreen: Boolean): HRESULT; stdcall;
function SetProgressValue(hwnd: THandle; ullCompleted: UInt64; ullTotal: UInt64): HRESULT; stdcall;
function SetProgressState(hwnd: THandle; tbpFlags: Cardinal): HRESULT; stdcall;
function RegisterTab(hwnd: THandle; hwndMDI: THandle): HRESULT; stdcall;
function UnregisterTab(hwndTab: THandle): HRESULT; stdcall;
function SetTabOrder(hwndTab: THandle; hwndInsertBefore: THandle): HRESULT; stdcall;
function SetTabActive(hwndTab: THandle; hwndMDI: THandle; tbatFlags: Cardinal): HRESULT; stdcall;
function ThumbBarAddButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall;
function ThumbBarUpdateButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall;
function ThumbBarSetImageList(hwnd: THandle; himl: THandle): HRESULT; stdcall;
function SetOverlayIcon(hwnd: THandle; hIcon: THandle; pszDescription: PChar): HRESULT; stdcall;
function SetThumbnailTooltip(hwnd: THandle; pszDescription: PChar): HRESULT; stdcall;
function SetThumbnailClip(hwnd: THandle; var prcClip: TRect): HRESULT; stdcall;
end;
//////////////////////////////////////////////////////////////////////////////
var
GlobalTaskBarInterface: ITaskBarList3;
function InitializeTaskbarAPI: Boolean;
var
Unknown: IInterface;
Temp: ITaskBarList3;
begin
if Assigned(GlobalTaskBarInterface) then
begin
Result := True;
Exit;
end;
try
Unknown := CreateComObject(TASKBAR_CID);
if Assigned(Unknown) then
begin
Temp := Unknown as ITaskBarList3;
if Temp.HrInit() = S_OK then
begin
GlobalTaskBarInterface := Temp;
end;
end;
except
GlobalTaskBarInterface := nil;
end;
Result := Assigned(GlobalTaskBarInterface);
end;
function CheckAPI:Boolean;
begin
Result := Assigned(GlobalTaskBarInterface);
end;
//////////////////////////////////////////////////////////////////////////////
function SetTaskbarProgressState(const AState: TTaskBarProgressState): Boolean;
var
Flag: Cardinal;
begin
Result := False;
if CheckAPI then
begin
case AState of
tbpsIndeterminate: Flag := TBPF_INDETERMINATE;
tbpsNormal: Flag := TBPF_NORMAL;
tbpsError: Flag := TBPF_ERROR;
tbpsPaused: Flag := TBPF_PAUSED;
else
Flag := TBPF_NOPROGRESS;
end;
Result := GlobalTaskBarInterface.SetProgressState(Application.Handle, Flag) = S_OK;
end;
end;
function SetTaskbarProgressValue(const ACurrent:UInt64; const AMax: UInt64): Boolean;
begin
Result := False;
if CheckAPI then
begin
Result := GlobalTaskBarInterface.SetProgressValue(Application.Handle, ACurrent, AMax) = S_OK;
end;
end;
//////////////////////////////////////////////////////////////////////////////
initialization
GlobalTaskBarInterface := nil;
finalization
GlobalTaskBarInterface := nil;
//////////////////////////////////////////////////////////////////////////////
end.

146
System/ZLibEx.inc Normal file
View File

@ -0,0 +1,146 @@
{*****************************************************************************
* ZLibEx.inc *
* copyright (c) 2006-2009 base2 technologies *
* *
* version information for delphi/c++ builder *
* *
* revision history *
* 2009.04.11 updated to use CONDITIONALEXPRESSIONS and CompilerVersion *
* 2009.01.28 updated for delphi 2009 *
* 2007.10.01 updated for delphi 2007 *
* 2005.11.29 created *
* *
* acknowledgments *
* iztok kacin *
* 2009.04.11 CONDITIONALEXPRESSIONS and CompilerVersion changes *
*****************************************************************************}
{$ifndef CONDITIONALEXPRESSIONS}
{** delphi ****************************************************************}
{$ifdef VER80} // delphi 1
{$define Delphi}
{$define Version1}
{$endif}
{$ifdef VER90} // delphi 2
{$define Delphi}
{$define Version2}
{$endif}
{$ifdef VER100} // delphi 3
{$define Delphi}
{$define Version3}
{$endif}
{$ifdef VER120} // delphi 4
{$define Delphi}
{$define Version4}
{$endif}
{** c++ builder ***********************************************************}
{$ifdef VER93} // c++ builder 1
{$define CBuilder}
{$define Version1}
{$endif}
{$ifdef VER110} // c++ builder 3
{$define CBuilder}
{$define Version3}
{$endif}
{$ifdef VER125} // c++ builder 4
{$define CBuilder}
{$define Version4}
{$endif}
{** delphi/c++ builder (common) *******************************************}
{$ifdef VER130} // delphi/c++ builder 5
{$ifdef BCB}
{$define CBuilder}
{$ELSE}
{$define Delphi}
{$endif}
{$define Version5}
{$define Version5Plus}
{$endif}
{$ELSE}
{$ifdef BCB}
{$define CBuilder}
{$ELSE}
{$define Delphi}
{$endif}
{$define Version5Plus}
{$if CompilerVersion >= 14.0} // delphi 6
{$ifdef VER140}
{$define Version6}
{$endif}
{$define Version6Plus}
{$ifend}
{$if CompilerVersion >= 15.0} // delphi 7
{$ifdef VER150}
{$define Version7}
{$endif}
{$define Version7Plus}
{$ifend}
{$if CompilerVersion >= 16.0} // delphi 8 (.net)
{$ifdef VER160}
{$define Version8}
{$endif}
{$define Version8Plus}
{$ifend}
{$if CompilerVersion >= 17.0} // delphi 2005
{$ifdef VER170}
{$define Version2005}
{$endif}
{$define Version2005Plus}
{$ifend}
{$if CompilerVersion >= 18.0} // bds 2006
{$ifdef VER180}
{$define Version2006}
{$endif}
{$define Version2006Plus}
{$ifend}
{$if CompilerVersion >= 18.5} // bds 2007
{$ifdef VER185}
{$define Version2007}
{$endif}
{$define Version2007Plus}
{$ifend}
{$if CompilerVersion >= 20.0} // bds 2009
{$ifdef VER200}
{$define Version2009}
{$endif}
{$define Version2009Plus}
{$ifend}
{$endif}

1159
System/pcre.pas Normal file
View File

File diff suppressed because it is too large Load Diff

353
System/pngextra.pas Normal file
View File

@ -0,0 +1,353 @@
unit pngextra;
interface
uses
Windows, Graphics, Messages, SysUtils, Classes, Controls, pngimage, Buttons,
ExtCtrls;
type
TPNGButtonStyle = (pbsDefault, pbsFlat, pbsNoFrame);
TPNGButtonLayout = (pbsImageAbove, pbsImageBellow, pbsImageLeft,
pbsImageRight);
TPNGButtonState = (pbsNormal, pbsDown, pbsDisabled);
TPNGButton = class(TGraphicControl)
private
{Holds the property values}
fButtonStyle: TPNGButtonStyle;
fMouseOverControl: Boolean;
FCaption: String;
FButtonLayout: TPNGButtonLayout;
FButtonState: TPNGButtonState;
FImageDown: TPNGObject;
fImageNormal: TPNGObject;
fImageDisabled: TPNGObject;
fImageOver: TPNGObject;
fOnMouseEnter, fOnMouseExit: TNotifyEvent;
{Procedures for setting the property values}
procedure SetButtonStyle(const Value: TPNGButtonStyle);
procedure SetCaption(const Value: String);
procedure SetButtonLayout(const Value: TPNGButtonLayout);
procedure SetButtonState(const Value: TPNGButtonState);
procedure SetImageNormal(const Value: TPNGObject);
procedure SetImageDown(const Value: TPNGObject);
procedure SetImageOver(const Value: TPNGObject);
published
{Published properties}
property Font;
property Visible;
property ButtonLayout: TPNGButtonLayout read FButtonLayout write SetButtonLayout;
property Caption: String read FCaption write SetCaption;
property ImageNormal: TPNGObject read fImageNormal write SetImageNormal;
property ImageDown: TPNGObject read FImageDown write SetImageDown;
property ImageOver: TPNGObject read FImageOver write SetImageOver;
property ButtonStyle: TPNGButtonStyle read fButtonStyle
write SetButtonStyle;
property Enabled;
property ParentShowHint;
property ShowHint;
{Default events}
property OnMouseDown;
property OnClick;
property OnMouseUp;
property OnMouseMove;
property OnDblClick;
property OnMouseEnter: TNotifyEvent read fOnMouseEnter write fOnMouseEnter;
property OnMouseExit: TNotifyEvent read fOnMouseExit write fOnMouseExit;
public
{Public properties}
property ButtonState: TPNGButtonState read FButtonState write SetButtonState;
protected
{Being painted}
procedure Paint; override;
{Clicked}
procedure Click; override;
{Mouse pressed}
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{Mouse entering or leaving}
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
{Being enabled or disabled}
procedure CMEnabledChanged(var Message: TMessage);
message CM_ENABLEDCHANGED;
public
{Returns if the mouse is over the control}
property IsMouseOver: Boolean read fMouseOverControl;
{Constructor and destructor}
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
procedure Register;
procedure MakeImageHalfTransparent(Source, Dest: TPNGObject);
implementation
procedure Register;
begin
RegisterComponents('Samples', [TPNGButton]);
end;
procedure MakeImageHalfTransparent(Source, Dest: TPNGObject);
var
i, j: Integer;
begin
Dest.Assign(Source);
Dest.CreateAlpha;
if (Dest.Header.ColorType <> COLOR_PALETTE) then
for j := 0 to Source.Height - 1 do
for i := 0 to Source.Width - 1 do
Dest.AlphaScanline[j]^[i] := Dest.AlphaScanline[j]^[i] div 3;
end;
{TPNGButton implementation}
{Being created}
constructor TPNGButton.Create(AOwner: TComponent);
begin
{Calls ancestor}
inherited Create(AOwner);
{Creates the TPNGObjects}
fImageNormal := TPNGObject.Create;
fImageDown := TPNGObject.Create;
fImageDisabled := TPNGObject.Create;
fImageOver := TPNGObject.Create;
{Initial properties}
ControlStyle := ControlStyle + [csCaptureMouse];
SetBounds(Left, Top, 23, 23);
fMouseOverControl := False;
fButtonLayout := pbsImageAbove;
fButtonState := pbsNormal
end;
destructor TPNGButton.Destroy;
begin
{Frees the TPNGObject}
fImageNormal.Free;
fImageDown.Free;
fImageDisabled.Free;
fImageOver.Free;
{Calls ancestor}
inherited Destroy;
end;
{Being enabled or disabled}
procedure TPNGButton.CMEnabledChanged(var Message: TMessage);
begin
if not Enabled then MakeImageHalfTransparent(fImageNormal, fImageDisabled);
if Enabled then ButtonState := pbsNormal else ButtonState := pbsDisabled
end;
{Returns the largest number}
function Max(A, B: Integer): Integer;
begin
if A > B then Result := A else Result := B
end;
{Button being painted}
procedure TPNGButton.Paint;
const
Slide: Array[false..true] of Integer = (0, 2);
var
Area: TRect;
TextSize, ImageSize: TSize;
TextPos, ImagePos: TPoint;
Image: TPNGObject;
Pushed: Boolean;
begin
{Prepares the canvas}
Canvas.Font.Assign(Font);
{Determines if the button is pushed}
Pushed := (ButtonState = pbsDown) and IsMouseOver;
{Determines the image to use}
if (Pushed) and not fImageDown.Empty then
Image := fImageDown
else if IsMouseOver and not fImageOver.Empty and Enabled then
Image := fImageOver
else if (ButtonState = pbsDisabled) and not fImageDisabled.Empty then
Image := fImageDisabled
else
Image := fImageNormal;
{Get the elements size}
ImageSize.cx := Image.Width;
ImageSize.cy := Image.Height;
Area := ClientRect;
if Caption <> '' then
begin
TextSize := Canvas.TextExtent(Caption);
ImageSize.cy := ImageSize.Cy + 4;
end else FillChar(TextSize, SizeOf(TextSize), #0);
{Set the elements position}
ImagePos.X := (Width - ImageSize.cx) div 2 + Slide[Pushed];
TextPos.X := (Width - TextSize.cx) div 2 + Slide[Pushed];
TextPos.Y := (Height - TextSize.cy) div 2;
ImagePos.Y := (Height - ImageSize.cy) div 2;
case ButtonLayout of
pbsImageAbove: begin
ImagePos.Y := (Height - ImageSize.cy - TextSize.cy) div 2;
TextPos.Y := ImagePos.Y + ImageSize.cy;
end;
pbsImageBellow: begin
TextPos.Y := (Height - ImageSize.cy - TextSize.cy) div 2;
ImagePos.Y := TextPos.Y + TextSize.cy;
end;
pbsImageLeft: begin
ImagePos.X := (Width - ImageSize.cx - TextSize.cx) div 2;
TextPos.X := ImagePos.X + ImageSize.cx + 5;
end;
pbsImageRight: begin
TextPos.X := (Width - ImageSize.cx - TextSize.cx) div 2;;
ImagePos.X := TextPos.X + TextSize.cx + 5;
end
end;
ImagePos.Y := ImagePos.Y + Slide[Pushed];
TextPos.Y := TextPos.Y + Slide[Pushed];
{Draws the border}
if ButtonStyle = pbsFlat then
begin
if ButtonState <> pbsDisabled then
if (Pushed) then
Frame3D(Canvas, Area, clBtnShadow, clBtnHighlight, 1)
else if IsMouseOver or (ButtonState = pbsDown) then
Frame3D(Canvas, Area, clBtnHighlight, clBtnShadow, 1)
end
else if ButtonStyle = pbsDefault then
DrawButtonFace(Canvas, Area, 1, bsNew, TRUE, Pushed, FALSE);
{Draws the elements}
Canvas.Brush.Style := bsClear;
Canvas.Draw(ImagePos.X, ImagePos.Y, Image);
if ButtonState = pbsDisabled then Canvas.Font.Color := clGrayText;
Canvas.TextRect(Area, TextPos.X, TextPos.Y, Caption)
end;
{Changing the button Layout property}
procedure TPNGButton.SetButtonLayout(const Value: TPNGButtonLayout);
begin
FButtonLayout := Value;
Repaint
end;
{Changing the button state property}
procedure TPNGButton.SetButtonState(const Value: TPNGButtonState);
begin
FButtonState := Value;
Repaint
end;
{Changing the button style property}
procedure TPNGButton.SetButtonStyle(const Value: TPNGButtonStyle);
begin
fButtonStyle := Value;
Repaint
end;
{Changing the caption property}
procedure TPNGButton.SetCaption(const Value: String);
begin
FCaption := Value;
Repaint
end;
{Changing the image property}
procedure TPNGButton.SetImageNormal(const Value: TPNGObject);
begin
fImageNormal.Assign(Value);
MakeImageHalfTransparent(fImageNormal, fImageDisabled);
Repaint
end;
{Setting the down image}
procedure TPNGButton.SetImageDown(const Value: TPNGObject);
begin
FImageDown.Assign(Value);
Repaint
end;
{Setting the over image}
procedure TPNGButton.SetImageOver(const Value: TPNGObject);
begin
fImageOver.Assign(Value);
Repaint
end;
{Mouse pressed}
procedure TPNGButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
{Changes the state and repaints}
if (ButtonState = pbsNormal) and (Button = mbLeft) then
ButtonState := pbsDown;
{Calls ancestor}
inherited
end;
{Being clicked}
procedure TPNGButton.Click;
begin
if ButtonState = pbsDown then ButtonState := pbsNormal;
inherited Click;
end;
{Mouse released}
procedure TPNGButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
{Changes the state and repaints}
if ButtonState = pbsDown then ButtonState := pbsNormal;
{Calls ancestor}
inherited
end;
{Mouse moving over the control}
procedure TPNGButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
{In case cursor is over the button}
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) and
(fMouseOverControl = False) and (ButtonState <> pbsDown) then
begin
fMouseOverControl := True;
Repaint;
end;
{Calls ancestor}
inherited;
end;
{Mouse is now over the control}
procedure TPNGButton.CMMouseEnter(var Message: TMessage);
begin
if Enabled then
begin
if Assigned(fOnMouseEnter) then fOnMouseEnter(Self);
fMouseOverControl := True;
Repaint
end
end;
{Mouse has left the control}
procedure TPNGButton.CMMouseLeave(var Message: TMessage);
begin
if Enabled then
begin
if Assigned(fOnMouseExit) then FOnMouseExit(Self);
fMouseOverControl := False;
Repaint
end
end;
end.

5824
System/pngimage.pas Normal file
View File

File diff suppressed because it is too large Load Diff

355
System/pnglang.pas Normal file
View File

@ -0,0 +1,355 @@
{Portable Network Graphics Delphi Language Info (24 July 2002)}
{Feel free to change the text bellow to adapt to your language}
{Also if you have a translation to other languages and want to}
{share it, send me: gubadaud@terra.com.br }
unit pnglang;
interface
{$DEFINE English}
{.$DEFINE Polish}
{.$DEFINE Portuguese}
{.$DEFINE German}
{.$DEFINE French}
{.$DEFINE Slovenian}
{Language strings for english}
resourcestring
{$IFDEF Polish}
EPngInvalidCRCText = 'Ten obraz "Portable Network Graphics" jest nieprawid<69>owy ' +
'poniewa<77> zawiera on nieprawid<69>owe cz<63><7A>ci danych (b<><62>d crc)';
EPNGInvalidIHDRText = 'Obraz "Portable Network Graphics" nie mo<6D>e zosta<74> ' +
'wgrany poniewa<77> jedna z cz<63><7A>ci danych (ihdr) mo<6D>e by<62> uszkodzona';
EPNGMissingMultipleIDATText = 'Obraz "Portable Network Graphics" jest ' +
'nieprawid<69>owy poniewa<77> brakuje w nim cz<63><7A>ci obrazu.';
EPNGZLIBErrorText = 'Nie mo<6D>na zdekompresowa<77> obrazu poniewa<77> zawiera ' +
'b<><62>dnie zkompresowane dane.'#13#10 + ' Opis b<><62>du: ';
EPNGInvalidPaletteText = 'Obraz "Portable Network Graphics" zawiera ' +
'niew<65>a<EFBFBD>ciw<69> palet<65>.';
EPNGInvalidFileHeaderText = 'Plik kt<6B>ry jest odczytywany jest nieprawid<69>owym '+
'obrazem "Portable Network Graphics" poniewa<77> zawiera nieprawid<69>owy nag<61><67>wek.' +
' Plik mo<6D><6F> by<62> uszkodzony, spr<70>buj pobra<72> go ponownie.';
EPNGIHDRNotFirstText = 'Obraz "Portable Network Graphics" nie jest ' +
'obs<62>ugiwany lub mo<6D>e by<62> niew<65>a<EFBFBD>ciwy.'#13#10 + '(stopka IHDR nie jest pierwsza)';
EPNGNotExistsText = 'Plik png nie mo<6D>e zosta<74> wgrany poniewa<77> nie ' +
'istnieje.';
EPNGSizeExceedsText = 'Obraz "Portable Network Graphics" nie jest ' +
'obs<62>ugiwany poniewa<77> jego szeroko<6B><6F> lub wysoko<6B><6F> przekracza maksimum ' +
'rozmiaru, kt<6B>ry wynosi 65535 pikseli d<>ugo<67>ci.';
EPNGUnknownPalEntryText = 'Nie znaleziono wpis<69>w palety.';
EPNGMissingPaletteText = 'Obraz "Portable Network Graphics" nie mo<6D>e zosta<74> ' +
'wgrany poniewa<77> u<>ywa tabeli kolor<6F>w kt<6B>rej brakuje.';
EPNGUnknownCriticalChunkText = 'Obraz "Portable Network Graphics" ' +
'zawiera nieznan<61> krytyczn<7A> cz<63><7A><EFBFBD> kt<6B>ra nie mo<6D>e zosta<74> odkodowana.';
EPNGUnknownCompressionText = 'Obraz "Portable Network Graphics" jest ' +
'skompresowany nieznanym schemat kt<6B>ry nie mo<6D>e zosta<74> odszyfrowany.';
EPNGUnknownInterlaceText = 'Obraz "Portable Network Graphics" u<>ywa ' +
'nie znany schamat przeplatania kt<6B>ry nie mo<6D>e zosta<74> odszyfrowany.';
EPNGCannotAssignChunkText = 'Stopka mysi by<62> kompatybilna aby zosta<74>a wyznaczona.';
EPNGUnexpectedEndText = 'Obraz "Portable Network Graphics" jest nieprawid<69>owy ' +
'poniewa<77> dekoder znalaz<61> niespodziewanie koniec pliku.';
EPNGNoImageDataText = 'Obraz "Portable Network Graphics" nie zawiera' +
'danych.';
EPNGCannotAddChunkText = 'Program pr<70>buje doda<64> krytyczn<7A> ' +
'stopk<70> do aktualnego obrazu co jest niedozwolone.';
EPNGCannotAddInvalidImageText = 'Nie mo<6D>na doda<64> nowej stopki ' +
'poniewa<77> aktualny obraz jest nieprawid<69>owy.';
EPNGCouldNotLoadResourceText = 'Obraz png nie mo<6D>e zosta<74> za<7A>adowany z' +
'zasob<6F>w o podanym ID.';
EPNGOutMemoryText = 'Niekt<6B>re operacje nie mog<6F> zosta<74> zrealizowane poniewa<77> ' +
'systemowi brakuje zasob<6F>w. Zamknij kilka okien i spr<70>buj ponownie.';
EPNGCannotChangeTransparentText = 'Ustawienie bitu przezroczystego koloru jest ' +
'zabronione dla obraz<61>w png zawieraj<61>cych warto<74><6F> alpha dla ka<6B>dego piksela ' +
'(COLOR_RGBALPHA i COLOR_GRAYSCALEALPHA)';
EPNGHeaderNotPresentText = 'Ta operacja jest niedozwolona poniewa<77> ' +
'aktualny obraz zawiera niew<65>a<EFBFBD>ciwy nag<61><67>wek.';
EInvalidNewSize = 'The new size provided for image resizing is invalid.';
EInvalidSpec = 'The "Portable Network Graphics" could not be created ' +
'because invalid image type parameters have being provided.';
{$ENDIF}
{$IFDEF English}
EPngInvalidCRCText = 'This "Portable Network Graphics" image is not valid ' +
'because it contains invalid pieces of data (crc error)';
EPNGInvalidIHDRText = 'The "Portable Network Graphics" image could not be ' +
'loaded because one of its main piece of data (ihdr) might be corrupted';
EPNGMissingMultipleIDATText = 'This "Portable Network Graphics" image is ' +
'invalid because it has missing image parts.';
EPNGZLIBErrorText = 'Could not decompress the image because it contains ' +
'invalid compressed data.'#13#10 + ' Description: ';
EPNGInvalidPaletteText = 'The "Portable Network Graphics" image contains ' +
'an invalid palette.';
EPNGInvalidFileHeaderText = 'The file being readed is not a valid '+
'"Portable Network Graphics" image because it contains an invalid header.' +
' This file may be corruped, try obtaining it again.';
EPNGIHDRNotFirstText = 'This "Portable Network Graphics" image is not ' +
'supported or it might be invalid.'#13#10 + '(IHDR chunk is not the first)';
EPNGNotExistsText = 'The png file could not be loaded because it does not ' +
'exists.';
EPNGSizeExceedsText = 'This "Portable Network Graphics" image is not ' +
'supported because either it''s width or height exceeds the maximum ' +
'size, which is 65535 pixels length.';
EPNGUnknownPalEntryText = 'There is no such palette entry.';
EPNGMissingPaletteText = 'This "Portable Network Graphics" could not be ' +
'loaded because it uses a color table which is missing.';
EPNGUnknownCriticalChunkText = 'This "Portable Network Graphics" image ' +
'contains an unknown critical part which could not be decoded.';
EPNGUnknownCompressionText = 'This "Portable Network Graphics" image is ' +
'encoded with an unknown compression scheme which could not be decoded.';
EPNGUnknownInterlaceText = 'This "Portable Network Graphics" image uses ' +
'an unknown interlace scheme which could not be decoded.';
EPNGCannotAssignChunkText = 'The chunks must be compatible to be assigned.';
EPNGUnexpectedEndText = 'This "Portable Network Graphics" image is invalid ' +
'because the decoder found an unexpected end of the file.';
EPNGNoImageDataText = 'This "Portable Network Graphics" image contains no ' +
'data.';
EPNGCannotAddChunkText = 'The program tried to add a existent critical ' +
'chunk to the current image which is not allowed.';
EPNGCannotAddInvalidImageText = 'It''s not allowed to add a new chunk ' +
'because the current image is invalid.';
EPNGCouldNotLoadResourceText = 'The png image could not be loaded from the ' +
'resource ID.';
EPNGOutMemoryText = 'Some operation could not be performed because the ' +
'system is out of resources. Close some windows and try again.';
EPNGCannotChangeTransparentText = 'Setting bit transparency color is not ' +
'allowed for png images containing alpha value for each pixel ' +
'(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)';
EPNGHeaderNotPresentText = 'This operation is not valid because the ' +
'current image contains no valid header.';
EInvalidNewSize = 'The new size provided for image resizing is invalid.';
EInvalidSpec = 'The "Portable Network Graphics" could not be created ' +
'because invalid image type parameters have being provided.';
{$ENDIF}
{$IFDEF Portuguese}
EPngInvalidCRCText = 'Essa imagem "Portable Network Graphics" n<>o <20> v<>lida ' +
'porque cont<6E>m chunks inv<6E>lidos de dados (erro crc)';
EPNGInvalidIHDRText = 'A imagem "Portable Network Graphics" n<>o pode ser ' +
'carregada porque um dos seus chunks importantes (ihdr) pode estar '+
'inv<6E>lido';
EPNGMissingMultipleIDATText = 'Essa imagem "Portable Network Graphics" <20> ' +
'inv<6E>lida porque tem chunks de dados faltando.';
EPNGZLIBErrorText = 'N<>o foi poss<73>vel descomprimir os dados da imagem ' +
'porque ela cont<6E>m dados inv<6E>lidos.'#13#10 + ' Descri<72><69>o: ';
EPNGInvalidPaletteText = 'A imagem "Portable Network Graphics" cont<6E>m ' +
'uma paleta inv<6E>lida.';
EPNGInvalidFileHeaderText = 'O arquivo sendo lido n<>o <20> uma imagem '+
'"Portable Network Graphics" v<>lida porque cont<6E>m um cabe<62>alho inv<6E>lido.' +
' O arquivo pode estar corrompida, tente obter ela novamente.';
EPNGIHDRNotFirstText = 'Essa imagem "Portable Network Graphics" n<>o <20> ' +
'suportada ou pode ser inv<6E>lida.'#13#10 + '(O chunk IHDR n<>o <20> o ' +
'primeiro)';
EPNGNotExistsText = 'A imagem png n<>o pode ser carregada porque ela n<>o ' +
'existe.';
EPNGSizeExceedsText = 'Essa imagem "Portable Network Graphics" n<>o <20> ' +
'suportada porque a largura ou a altura ultrapassam o tamanho m<>ximo, ' +
'que <20> de 65535 pixels de di<64>metro.';
EPNGUnknownPalEntryText = 'N<>o existe essa entrada de paleta.';
EPNGMissingPaletteText = 'Essa imagem "Portable Network Graphics" n<>o pode ' +
'ser carregada porque usa uma paleta que est<73> faltando.';
EPNGUnknownCriticalChunkText = 'Essa imagem "Portable Network Graphics" ' +
'cont<6E>m um chunk cr<63>tico desconhe<68>ido que n<>o pode ser decodificado.';
EPNGUnknownCompressionText = 'Essa imagem "Portable Network Graphics" est<73> ' +
'codificada com um esquema de compress<73>o desconhe<68>ido e n<>o pode ser ' +
'decodificada.';
EPNGUnknownInterlaceText = 'Essa imagem "Portable Network Graphics" usa um ' +
'um esquema de interlace que n<>o pode ser decodificado.';
EPNGCannotAssignChunkText = 'Os chunk devem ser compat<61>veis para serem ' +
'copiados.';
EPNGUnexpectedEndText = 'Essa imagem "Portable Network Graphics" <20> ' +
'inv<6E>lida porque o decodificador encontrou um fim inesperado.';
EPNGNoImageDataText = 'Essa imagem "Portable Network Graphics" n<>o cont<6E>m ' +
'dados.';
EPNGCannotAddChunkText = 'O programa tentou adicionar um chunk cr<63>tico ' +
'j<> existente para a imagem atual, oque n<>o <20> permitido.';
EPNGCannotAddInvalidImageText = 'N<>o <20> permitido adicionar um chunk novo ' +
'porque a imagem atual <20> inv<6E>lida.';
EPNGCouldNotLoadResourceText = 'A imagem png n<>o pode ser carregada apartir' +
' do resource.';
EPNGOutMemoryText = 'Uma opera<72><61>o n<>o pode ser completada porque o sistema ' +
'est<73> sem recursos. Fecha algumas janelas e tente novamente.';
EPNGCannotChangeTransparentText = 'Definir transpar<61>ncia booleana n<>o <20> ' +
'permitido para imagens png contendo informa<6D><61>o alpha para cada pixel ' +
'(COLOR_RGBALPHA e COLOR_GRAYSCALEALPHA)';
EPNGHeaderNotPresentText = 'Essa opera<72><61>o n<>o <20> v<>lida porque a ' +
'imagem atual n<>o cont<6E>m um cabe<62>alho v<>lido.';
EInvalidNewSize = 'O novo tamanho fornecido para o redimensionamento de ' +
'imagem <20> inv<6E>lido.';
EInvalidSpec = 'A imagem "Portable Network Graphics" n<>o pode ser criada ' +
'porque par<61>metros de tipo de imagem inv<6E>lidos foram usados.';
{$ENDIF}
{Language strings for German}
{$IFDEF German}
EPngInvalidCRCText = 'Dieses "Portable Network Graphics" Bild ist ' +
'ung<6E>ltig, weil Teile der Daten fehlerhaft sind (CRC-Fehler)';
EPNGInvalidIHDRText = 'Dieses "Portable Network Graphics" Bild konnte ' +
'nicht geladen werden, weil wahrscheinlich einer der Hauptdatenbreiche ' +
'(IHDR) besch<63>digt ist';
EPNGMissingMultipleIDATText = 'Dieses "Portable Network Graphics" Bild ' +
'ist ung<6E>ltig, weil Grafikdaten fehlen.';
EPNGZLIBErrorText = 'Die Grafik konnte nicht entpackt werden, weil Teile der ' +
'komprimierten Daten fehlerhaft sind.'#13#10 + ' Beschreibung: ';
EPNGInvalidPaletteText = 'Das "Portable Network Graphics" Bild enth<74>lt ' +
'eine ung<6E>ltige Palette.';
EPNGInvalidFileHeaderText = 'Die Datei, die gelesen wird, ist kein ' +
'g<>ltiges "Portable Network Graphics" Bild, da es keinen g<>ltigen ' +
'Header enth<74>lt. Die Datei k<>nnte besch<63>digt sein, versuchen Sie, ' +
'eine neue Kopie zu bekommen.';
EPNGIHDRNotFirstText = 'Dieses "Portable Network Graphics" Bild wird ' +
'nicht unterst<73>tzt oder ist ung<6E>ltig.'#13#10 +
'(Der IHDR-Abschnitt ist nicht der erste Abschnitt in der Datei).';
EPNGNotExistsText = 'Die PNG Datei konnte nicht geladen werden, da sie ' +
'nicht existiert.';
EPNGSizeExceedsText = 'Dieses "Portable Network Graphics" Bild wird nicht ' +
'unterst<73>tzt, weil entweder seine Breite oder seine H<>he das Maximum von ' +
'65535 Pixeln <20>berschreitet.';
EPNGUnknownPalEntryText = 'Es gibt keinen solchen Palettenwert.';
EPNGMissingPaletteText = 'Dieses "Portable Network Graphics" Bild konnte ' +
'nicht geladen werden, weil die ben<65>tigte Farbtabelle fehlt.';
EPNGUnknownCriticalChunkText = 'Dieses "Portable Network Graphics" Bild ' +
'enh<6E>lt einen unbekannten aber notwendigen Teil, welcher nicht entschl<68>sselt ' +
'werden kann.';
EPNGUnknownCompressionText = 'Dieses "Portable Network Graphics" Bild ' +
'wurde mit einem unbekannten Komprimierungsalgorithmus kodiert, welcher ' +
'nicht entschl<68>sselt werden kann.';
EPNGUnknownInterlaceText = 'Dieses "Portable Network Graphics" Bild ' +
'benutzt ein unbekanntes Interlace-Schema, welches nicht entschl<68>sselt ' +
'werden kann.';
EPNGCannotAssignChunkText = 'Die Abschnitte m<>ssen kompatibel sein, damit ' +
'sie zugewiesen werden k<>nnen.';
EPNGUnexpectedEndText = 'Dieses "Portable Network Graphics" Bild ist ' +
'ung<6E>ltig: Der Dekoder ist unerwartete auf das Ende der Datei gesto<74>en.';
EPNGNoImageDataText = 'Dieses "Portable Network Graphics" Bild enth<74>lt ' +
'keine Daten.';
EPNGCannotAddChunkText = 'Das Programm versucht einen existierenden und ' +
'notwendigen Abschnitt zum aktuellen Bild hinzuzuf<75>gen. Dies ist nicht ' +
'zul<75>ssig.';
EPNGCannotAddInvalidImageText = 'Es ist nicht zul<75>ssig, einem ung<6E>ltigen ' +
'Bild einen neuen Abschnitt hinzuzuf<75>gen.';
EPNGCouldNotLoadResourceText = 'Das PNG Bild konnte nicht aus den ' +
'Resourcendaten geladen werden.';
EPNGOutMemoryText = 'Es stehen nicht gen<65>gend Resourcen im System zur ' +
'Verf<72>gung, um die Operation auszuf<75>hren. Schlie<69>en Sie einige Fenster '+
'und versuchen Sie es erneut.';
EPNGCannotChangeTransparentText = 'Das Setzen der Bit-' +
'Transparent-Farbe ist f<>r PNG-Images die Alpha-Werte f<>r jedes ' +
'Pixel enthalten (COLOR_RGBALPHA und COLOR_GRAYSCALEALPHA) nicht ' +
'zul<75>ssig';
EPNGHeaderNotPresentText = 'Die Datei, die gelesen wird, ist kein ' +
'g<>ltiges "Portable Network Graphics" Bild, da es keinen g<>ltigen ' +
'Header enth<74>lt.';
EInvalidNewSize = 'The new size provided for image resizing is invalid.';
EInvalidSpec = 'The "Portable Network Graphics" could not be created ' +
'because invalid image type parameters have being provided.';
{$ENDIF}
{Language strings for French}
{$IFDEF French}
EPngInvalidCRCText = 'Cette image "Portable Network Graphics" n''est pas valide ' +
'car elle contient des donn<6E>es invalides (erreur crc)';
EPNGInvalidIHDRText = 'Cette image "Portable Network Graphics" n''a pu <20>tre ' +
'charg<72>e car l''une de ses principale donn<6E>e (ihdr) doit <20>tre corrompue';
EPNGMissingMultipleIDATText = 'Cette image "Portable Network Graphics" est ' +
'invalide car elle contient des parties d''image manquantes.';
EPNGZLIBErrorText = 'Impossible de d<>compresser l''image car elle contient ' +
'des donn<6E>es compress<73>es invalides.'#13#10 + ' Description: ';
EPNGInvalidPaletteText = 'L''image "Portable Network Graphics" contient ' +
'une palette invalide.';
EPNGInvalidFileHeaderText = 'Le fichier actuellement lu est une image '+
'"Portable Network Graphics" invalide car elle contient un en-t<>te invalide.' +
' Ce fichier doit <20>tre corrompu, essayer de l''obtenir <20> nouveau.';
EPNGIHDRNotFirstText = 'Cette image "Portable Network Graphics" n''est pas ' +
'support<72>e ou doit <20>tre invalide.'#13#10 + '(la partie IHDR n''est pas la premi<6D>re)';
EPNGNotExistsText = 'Le fichier png n''a pu <20>tre charg<72> car il n''<27>xiste pas.';
EPNGSizeExceedsText = 'Cette image "Portable Network Graphics" n''est pas support<72>e ' +
'car sa longueur ou sa largeur exc<78>de la taille maximale, qui est de 65535 pixels.';
EPNGUnknownPalEntryText = 'Il n''y a aucune entr<74>e pour cette palette.';
EPNGMissingPaletteText = 'Cette image "Portable Network Graphics" n''a pu <20>tre ' +
'charg<72>e car elle utilise une table de couleur manquante.';
EPNGUnknownCriticalChunkText = 'Cette image "Portable Network Graphics" ' +
'contient une partie critique inconnue qui n'' pu <20>tre d<>cod<6F>e.';
EPNGUnknownCompressionText = 'Cette image "Portable Network Graphics" est ' +
'encod<6F>e <20> l''aide d''un sch<63>mas de compression inconnu qui ne peut <20>tre d<>cod<6F>.';
EPNGUnknownInterlaceText = 'Cette image "Portable Network Graphics" utilise ' +
'un sch<63>mas d''entrelacement inconnu qui ne peut <20>tre d<>cod<6F>.';
EPNGCannotAssignChunkText = 'Ce morceau doit <20>tre compatible pour <20>tre assign<67>.';
EPNGUnexpectedEndText = 'Cette image "Portable Network Graphics" est invalide ' +
'car le decodeur est arriv<69> <20> une fin de fichier non attendue.';
EPNGNoImageDataText = 'Cette image "Portable Network Graphics" ne contient pas de ' +
'donn<6E>es.';
EPNGCannotAddChunkText = 'Le programme a essay<61> d''ajouter un morceau critique existant ' +
'<27> l''image actuelle, ce qui n''est pas autoris<69>.';
EPNGCannotAddInvalidImageText = 'Il n''est pas permis d''ajouter un nouveau morceau ' +
'car l''image actuelle est invalide.';
EPNGCouldNotLoadResourceText = 'L''image png n''a pu <20>tre charg<72>e depuis ' +
'l''ID ressource.';
EPNGOutMemoryText = 'Certaines op<6F>rations n''ont pu <20>tre effectu<74>e car le ' +
'syst<73>me n''a plus de ressources. Fermez quelques fen<65>tres et essayez <20> nouveau.';
EPNGCannotChangeTransparentText = 'D<>finir le bit de transparence n''est pas ' +
'permis pour des images png qui contiennent une valeur alpha pour chaque pixel ' +
'(COLOR_RGBALPHA et COLOR_GRAYSCALEALPHA)';
EPNGHeaderNotPresentText = 'Cette op<6F>ration n''est pas valide car l''image ' +
'actuelle ne contient pas de header valide.';
EPNGAlphaNotSupportedText = 'Le type de couleur de l''image "Portable Network Graphics" actuelle ' +
'contient d<>j<EFBFBD> des informations alpha ou il ne peut <20>tre converti.';
EInvalidNewSize = 'The new size provided for image resizing is invalid.';
EInvalidSpec = 'The "Portable Network Graphics" could not be created ' +
'because invalid image type parameters have being provided.';
{$ENDIF}
{Language strings for slovenian}
{$IFDEF Slovenian}
EPngInvalidCRCText = 'Ta "Portable Network Graphics" slika je neveljavna, ' +
'ker vsebuje neveljavne dele podatkov (CRC napaka).';
EPNGInvalidIHDRText = 'Slike "Portable Network Graphics" ni bilo mo<6D>no ' +
'nalo<6C>iti, ker je eden od glavnih delov podatkov (IHDR) verjetno pokvarjen.';
EPNGMissingMultipleIDATText = 'Ta "Portable Network Graphics" slika je ' +
'naveljavna, ker manjkajo deli slike.';
EPNGZLIBErrorText = 'Ne morem raztegniti slike, ker vsebuje ' +
'neveljavne stisnjene podatke.'#13#10 + ' Opis: ';
EPNGInvalidPaletteText = 'Slika "Portable Network Graphics" vsebuje ' +
'neveljavno barvno paleto.';
EPNGInvalidFileHeaderText = 'Datoteka za branje ni veljavna '+
'"Portable Network Graphics" slika, ker vsebuje neveljavno glavo.' +
' Datoteka je verjetno pokvarjena, poskusite jo ponovno nalo<6C>iti.';
EPNGIHDRNotFirstText = 'Ta "Portable Network Graphics" slika ni ' +
'podprta ali pa je neveljavna.'#13#10 + '(IHDR del datoteke ni prvi).';
EPNGNotExistsText = 'Ne morem nalo<6C>iti png datoteke, ker ta ne ' +
'obstaja.';
EPNGSizeExceedsText = 'Ta "Portable Network Graphics" slika ni ' +
'podprta, ker ali njena <20>irina ali vi<76>ina presega najvecjo mo<6D>no vrednost ' +
'65535 pik.';
EPNGUnknownPalEntryText = 'Slika nima vne<6E>ene take barvne palete.';
EPNGMissingPaletteText = 'Te "Portable Network Graphics" ne morem ' +
'nalo<6C>iti, ker uporablja manjkajoco barvno paleto.';
EPNGUnknownCriticalChunkText = 'Ta "Portable Network Graphics" slika ' +
'vsebuje neznan kriticni del podatkov, ki ga ne morem prebrati.';
EPNGUnknownCompressionText = 'Ta "Portable Network Graphics" slika je ' +
'kodirana z neznano kompresijsko shemo, ki je ne morem prebrati.';
EPNGUnknownInterlaceText = 'Ta "Portable Network Graphics" slika uporablja ' +
'neznano shemo za preliv, ki je ne morem prebrati.';
EPNGCannotAssignChunkText = Ko<EFBFBD>cki morajo biti med seboj kompatibilni za prireditev vrednosti.';
EPNGUnexpectedEndText = 'Ta "Portable Network Graphics" slika je neveljavna, ' +
'ker je bralnik pri<72>el do nepricakovanega konca datoteke.';
EPNGNoImageDataText = 'Ta "Portable Network Graphics" ne vsebuje nobenih ' +
'podatkov.';
EPNGCannotAddChunkText = 'Program je poskusil dodati obstojeci kriticni ' +
'kos podatkov k trenutni sliki, kar ni dovoljeno.';
EPNGCannotAddInvalidImageText = 'Ni dovoljeno dodati nov kos podatkov, ' +
'ker trenutna slika ni veljavna.';
EPNGCouldNotLoadResourceText = 'Ne morem nalo<6C>iti png slike iz ' +
'skladi<64>ca.';
EPNGOutMemoryText = 'Ne morem izvesti operacije, ker je ' +
'sistem ostal brez resorjev. Zaprite nekaj oken in poskusite znova.';
EPNGCannotChangeTransparentText = 'Ni dovoljeno nastaviti prosojnosti posamezne barve ' +
'za png slike, ki vsebujejo alfa prosojno vrednost za vsako piko ' +
'(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)';
EPNGHeaderNotPresentText = 'Ta operacija ni veljavna, ker ' +
'izbrana slika ne vsebuje veljavne glave.';
EInvalidNewSize = 'The new size provided for image resizing is invalid.';
EInvalidSpec = 'The "Portable Network Graphics" could not be created ' +
'because invalid image type parameters have being provided.';
{$ENDIF}
implementation
end.

633
System/sdStringTable.pas Normal file
View File

@ -0,0 +1,633 @@
{ unit sdStringTable
Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
Original Date: 28 May 2007
Version: 1.1
Copyright (c) 2007 - 2010 Simdesign BV
It is NOT allowed under ANY circumstances to publish or copy this code
without accepting the license conditions in accompanying LICENSE.txt
first!
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
ANY KIND, either express or implied.
Please visit http://www.simdesign.nl/xml.html for more information.
}
unit sdStringTable;
interface
{$i NativeXml.inc}
uses
Classes, SysUtils, Contnrs;
type
// A record describing a string by its first position and length (Count)
TsdStringRec = record
First: Pbyte;
Count: integer;
end;
// A string reference item used in string reference lists (do not use directly)
TsdRefString = class
private
FID: integer;
FFrequency: integer;
FFirst: Pbyte;
FCharCount: integer;
protected
procedure SetString(const SR: TsdStringRec);
function CompareToSR(const SR: TsdStringRec): integer;
function StringRec: TsdStringRec;
public
destructor Destroy; override;
function AsString: UTF8String;
property CharCount: integer read FCharCount;
property Frequency: integer read FFrequency;
end;
// A list of string reference items (do not use directly)
TsdRefStringList = class(TObjectList)
private
function GetItems(Index: integer): TsdRefString;
protected
// Assumes list is sorted by StringID
function IndexOfID(AID: integer; var Index: integer): boolean;
// Assumes list is sorted by string rec
function IndexOfSR(const AStringRec: TsdStringRec; var Index: integer): boolean;
public
property Items[Index: integer]: TsdRefString read GetItems; default;
end;
// A string table, holding a collection of unique strings, sorted in 2 ways
// for fast access. Strings can be added with AddString or AddStringRec,
// and should be updated with SetString. When a string is added or updated,
// an ID is returned which the application can use to retrieve the string,
// using GetString.
TsdStringTable = class(TPersistent)
private
FByID: TsdRefStringList;
FBySR: TsdRefStringList;
protected
procedure DecFrequency(AItem: TsdRefString; ByIdIndex: integer);
function NextUniqueID: integer;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
// Add a new string rec, return fresh ID or ID of existing item, and increase
// the existing item's ref count
function AddStringRec(const SR: TsdStringRec): integer;
// Add a new string S to the table, the function returns its ID.
function AddString(const S: UTF8String): integer;
// Get the refstring by ID
function ById(index: integer): TsdRefString;
// Delete refstring by ID
procedure Delete(ByIdIndex: integer);
// determine if the stringrec exists
function ExistStringRec(const SR: TsdStringRec): boolean;
// Get the string of refstring with ID
function GetString(ID: integer): UTF8String;
// Set the string value of refstring with ID.
procedure SetString(var ID: integer; const S: UTF8String);
// Number of refstrings
function StringCount: integer;
procedure SaveToFile(const AFileName: string);
procedure SaveToStream(S: TStream);
end;
{utility functions}
// convert a string into a string rec
function sdStringToSR(const S: Utf8String): TsdStringRec;
// convert a string rec into a string
function sdSRToString(const SR: TsdStringRec): Utf8String;
// compare two string recs. This is NOT an alphabetic compare. SRs are first
// compared by length, then by first byte, then last byte then second, then
// N-1, until all bytes are compared.
function sdCompareSR(const SR1, SR2: TsdStringRec): integer;
// compare 2 bytes
function sdCompareByte(Byte1, Byte2: byte): integer;
// compare 2 integers
function sdCompareInteger(Int1, Int2: integer): integer;
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
procedure sdStreamWrite(S: TStream; const AString: AnsiString);
procedure sdStreamWriteStringRec(S: TStream; const AStringRec: TsdStringRec);
procedure sdStreamWriteRefString(S: TStream; ARefString: TsdRefString);
implementation
{ TsdRefString }
function TsdRefString.AsString: UTF8String;
begin
Result := sdSRToString(StringRec);
end;
function TsdRefString.CompareToSR(const SR: TsdStringRec): integer;
begin
if SR.Count = 0 then
begin
// shortcut
Result := 1;
exit;
end;
Result := sdCompareSR(StringRec, SR);
end;
destructor TsdRefString.Destroy;
begin
FreeMem(FFirst);
inherited;
end;
procedure TsdRefString.SetString(const SR: TsdStringRec);
begin
FCharCount := SR.Count;
ReallocMem(FFirst, FCharCount);
Move(SR.First^, FFirst^, FCharCount);
end;
function TsdRefString.StringRec: TsdStringRec;
begin
Result.First := FFirst;
Result.Count := FCharCount;
end;
{ TsdRefStringList }
function TsdRefStringList.GetItems(Index: integer): TsdRefString;
begin
Result := Get(Index);
end;
function TsdRefStringList.IndexOfID(AID: integer; var Index: integer): boolean;
var
Min, Max: integer;
begin
Result := False;
// Find position - binary method
Index := 0;
Min := 0;
Max := Count;
while Min < Max do
begin
Index := (Min + Max) div 2;
case sdCompareInteger(Items[Index].FID, AID) of
-1: Min := Index + 1;
0: begin
Result := True;
exit;
end;
1: Max := Index;
end;
end;
Index := Min;
end;
function TsdRefStringList.IndexOfSR(const AStringRec: TsdStringRec; var Index: integer): boolean;
var
Min, Max: integer;
SR: TsdStringRec;
begin
Result := False;
// Find position - binary method
Index := 0;
Min := 0;
Max := Count;
while Min < Max do
begin
Index := (Min + Max) div 2;
SR := TsdRefString(Get(Index)).StringRec;
case sdCompareSR(SR, AStringRec) of
-1: Min := Index + 1;
0: begin
Result := True;
exit;
end;
1: Max := Index;
end;
end;
Index := Min;
end;
{ TsdStringTable }
function TsdStringTable.AddString(const S: UTF8String): integer;
var
SR: TsdStringRec;
begin
SR := sdStringToSR(S);
Result := AddStringRec(SR);
end;
function TsdStringTable.AddStringRec(const SR: TsdStringRec): integer;
var
BySRIndex: integer;
Item: TsdRefString;
NewSR: TsdStringRec;
Res: boolean;
begin
// zero-length string
if SR.Count = 0 then
begin
Result := 0;
exit;
end;
// Try to find the new string
if FBySR.IndexOfSR(SR, BySRIndex) then
begin
Item := FBySR.Items[BySRIndex];
inc(Item.FFrequency);
Result := Item.FID;
exit;
end;
// Not found.. must make new item
Item := TsdRefString.Create;
Item.SetString(SR);
NewSR := Item.StringRec;
Item.FID := NextUniqueID;
FById.Add(Item);
Item.FFrequency := 1;
// debug:
//SetLength(Item.FValue, Item.FCount);
//Move(Item.FirstPtr(FBase)^, Item.FValue[1], Item.FCount);
// Insert in BySR lists
Res := FBySR.IndexOfSR(NewSR, BySRIndex);
assert(Res = False);
FBySR.Insert(BySRIndex, Item);
Result := Item.FID;
end;
function TsdStringTable.ById(index: integer): TsdRefString;
begin
Result := FById[Index];
end;
procedure TsdStringTable.Clear;
begin
FByID.Clear;
FBySR.Clear;
end;
constructor TsdStringTable.Create;
begin
inherited Create;
FByID := TsdRefStringList.Create(False);
FBySR := TsdRefStringList.Create(True);
end;
procedure TsdStringTable.DecFrequency(AItem: TsdRefString; ByIdIndex: integer);
var
BySRIndex: integer;
Res: boolean;
begin
dec(AItem.FFrequency);
assert(AItem.FFrequency >= 0);
if AItem.FFrequency = 0 then
begin
// We must remove it
FById.Delete(ByIdIndex);
Res := FBySR.IndexOfSR(AItem.StringRec, BySRIndex);
assert(Res = True);
FBySR.Delete(BySRIndex);
end;
end;
procedure TsdStringTable.Delete(ByIdIndex: integer);
var
Item: TsdRefString;
BySRIndex: integer;
Res: boolean;
begin
Item := FById[ByIdIndex];
if Item = nil then
exit;
FById.Delete(ByIdIndex);
Res := FBySR.IndexOfSR(Item.StringRec, BySRIndex);
assert(Res = True);
FBySR.Delete(BySRIndex);
end;
destructor TsdStringTable.Destroy;
begin
FreeAndNil(FByID);
FreeAndNil(FBySR);
inherited;
end;
function TsdStringTable.ExistStringRec(const SR: TsdStringRec): boolean;
var
BySRIndex: integer;
begin
// zero-length string
if SR.Count = 0 then
begin
Result := False;
exit;
end;
// Try to find the new string
Result := FBySR.IndexOfSR(SR, BySRIndex);
end;
function TsdStringTable.GetString(ID: integer): UTF8String;
var
Index, Count: integer;
Item: TsdRefString;
begin
if ID = 0 then
begin
Result := '';
exit;
end;
// Find the ID
if FByID.IndexOfID(ID, Index) then
begin
Item := FById[Index];
Count := Item.FCharCount;
SetLength(Result, Count);
Move(Item.FFirst^, Result[1], Count);
exit;
end;
Result := '';
end;
function TsdStringTable.NextUniqueID: integer;
begin
if FById.Count = 0 then
Result := 1
else
Result := FByID[FByID.Count - 1].FID + 1;
end;
procedure TsdStringTable.SaveToFile(const AFileName: string);
var
F: TFileStream;
begin
F := TFileStream.Create(AFileName, fmCreate);
try
SaveToStream(F);
finally
F.Free;
end;
end;
procedure TsdStringTable.SaveToStream(S: TStream);
var
i: integer;
R: UTF8String;
begin
for i := 0 to FBySR.Count - 1 do
begin
R := FBySR[i].AsString + #13#10;
S.Write(R[1], length(R));
end;
end;
procedure TsdStringTable.SetString(var ID: integer; const S: UTF8String);
var
ByIdIndex: integer;
Item: TsdRefString;
SR: TsdStringRec;
begin
// Make temp string record
SR := sdStringtoSR(S);
// Do we have a ref string with this ID?
if (ID > 0) and FByID.IndexOfID(ID, ByIdIndex) then
begin
// Is the string still the same?
Item := FById[ByIdIndex];
if Item.CompareToSR(SR) = 0 then
exit;
// The string changed..
DecFrequency(Item, ByIdIndex);
end;
ID := AddStringRec(SR);
end;
{utility functions}
function TsdStringTable.StringCount: integer;
begin
Result := FBySR.Count;
end;
function sdStringToSR(const S: UTF8String): TsdStringRec;
begin
Result.Count := length(S);
if Result.Count = 0 then
Result.First := nil
else
Result.First := @S[1];
end;
function sdSRToString(const SR: TsdStringRec): UTF8String;
begin
SetLength(Result, SR.Count);
if SR.Count > 0 then
Move(SR.First^, Result[1], SR.Count);
end;
function sdCompareByte(Byte1, Byte2: byte): integer;
begin
if Byte1 < Byte2 then
Result := -1
else
if Byte1 > Byte2 then
Result := 1
else
Result := 0;
end;
function sdCompareInteger(Int1, Int2: integer): integer;
begin
if Int1 < Int2 then
Result := -1
else
if Int1 > Int2 then
Result := 1
else
Result := 0;
end;
function sdCompareSR(const SR1, SR2: TsdStringRec): integer;
var
Count: integer;
First1, First2, Last1, Last2: Pbyte;
begin
// Compare string length first
Result := sdCompareInteger(SR1.Count, SR2.Count);
if Result <> 0 then
exit;
// Compare first
Result := sdCompareByte(SR1.First^, SR2.First^);
if Result <> 0 then
exit;
Count := SR1.Count;
// Setup First & Last pointers
First1 := SR1.First;
First2 := SR2.First;
Last1 := First1; inc(Last1, Count);
Last2 := First2; inc(Last2, Count);
// Compare each time last ptrs then first ptrs, until they meet in the middle
repeat
dec(Last1);
dec(Last2);
if First1 = Last1 then
exit;
Result := sdCompareByte(Last1^, Last2^);
if Result <> 0 then
exit;
inc(First1); inc(First2);
if First1 = Last1 then
exit;
Result := sdCompareByte(First1^, First2^);
if Result <> 0 then
exit;
until False;
end;
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process
// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes).
// Therefore, the block at Dst must be at least 1.5 the size of the source block.
// The function returns the number of *bytes* written.
var
W: word;
DStart: Pbyte;
begin
DStart := Dst;
while Count > 0 do
begin
W := Src^;
inc(Src);
if W <= $7F then
begin
Dst^ := byte(W);
inc(Dst);
end else
begin
if W > $7FF then
begin
Dst^ := byte($E0 or (W shr 12));
inc(Dst);
Dst^ := byte($80 or ((W shr 6) and $3F));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end else
begin // $7F < W <= $7FF
Dst^ := byte($C0 or (W shr 6));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end;
end;
dec(Count);
end;
Result := integer(Dst) - integer(DStart);
end;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process
// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes).
// Therefore, the block at Dst must be at least 2 times the size of Count, since
// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The
// function returns the number of *wide chars* written. Note that the Src block must
// have an exact number of UTF8 characters in it, if Count doesn't match then
// the last character will be converted anyway (going past the block boundary!)
var
W: word;
C: byte;
DStart: Pword;
SClose: Pbyte;
begin
DStart := Dst;
SClose := Src;
inc(SClose, Count);
while integer(Src) < integer(SClose) do
begin
// 1st byte
W := Src^;
inc(Src);
if W and $80 <> 0 then
begin
W := W and $3F;
if W and $20 <> 0 then
begin
// 2nd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte or out of range char
Continue;
W := (W shl 6) or (C and $3F);
end;
// 2nd or 3rd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte
Continue;
Dst^ := (W shl 6) or (C and $3F);
inc(Dst);
end else
begin
Dst^ := W;
inc(Dst);
end;
end;
Result := (integer(Dst) - integer(DStart)) div 2;
end;
procedure sdStreamWrite(S: TStream; const AString: AnsiString);
var
L: integer;
begin
L := Length(AString);
if L > 0 then
begin
S.Write(AString[1], L);
end;
end;
procedure sdStreamWriteStringRec(S: TStream; const AStringRec: TsdStringRec);
begin
S.Write(PAnsiChar(AStringRec.First)^, AStringRec.Count);
end;
procedure sdStreamWriteRefString(S: TStream; ARefString: TsdRefString);
begin
if ARefString = nil then
exit;
S.Write(PAnsiChar(ARefString.FFirst)^, ARefString.FCharCount);
end;
end.

156
System/zlibpas.pas Normal file
View File

@ -0,0 +1,156 @@
{Portable Network Graphics Delphi ZLIB linking (16 May 2002) }
{This unit links ZLIB to pngimage unit in order to implement }
{the library. It's now using the new ZLIB version, 1.1.4 }
{Note: The .obj files must be located in the subdirectory \obj}
unit zlibpas;
interface
type
TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
TFree = procedure (AppData, Block: Pointer);
// Internal structure. Ignore.
TZStreamRec = packed record
next_in: PChar; // next input byte
avail_in: Integer; // number of bytes available at next_in
total_in: Integer; // total nb of input bytes read so far
next_out: PChar; // next output byte should be put here
avail_out: Integer; // remaining free space at next_out
total_out: Integer; // total nb of bytes output so far
msg: PChar; // last error message, NULL if no error
internal: Pointer; // not visible by applications
zalloc: TAlloc; // used to allocate the internal state
zfree: TFree; // used to free the internal state
AppData: Pointer; // private data object passed to zalloc and zfree
data_type: Integer; // best guess about the data type: ascii or binary
adler: Integer; // adler32 value of the uncompressed data
reserved: Integer; // reserved for future use
end;
function inflateInit_(var strm: TZStreamRec; version: PChar;
recsize: Integer): Integer; forward;
function inflate(var strm: TZStreamRec; flush: Integer): Integer; forward;
function inflateEnd(var strm: TZStreamRec): Integer; forward;
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
recsize: Integer): Integer; forward;
function deflate(var strm: TZStreamRec; flush: Integer): Integer; forward;
function deflateEnd(var strm: TZStreamRec): Integer; forward;
const
zlib_version = '1.2.3';
const
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_SYNC_FLUSH = 2;
Z_FULL_FLUSH = 3;
Z_FINISH = 4;
Z_OK = 0;
Z_STREAM_END = 1;
Z_NEED_DICT = 2;
Z_ERRNO = (-1);
Z_STREAM_ERROR = (-2);
Z_DATA_ERROR = (-3);
Z_MEM_ERROR = (-4);
Z_BUF_ERROR = (-5);
Z_VERSION_ERROR = (-6);
Z_NO_COMPRESSION = 0;
Z_BEST_SPEED = 1;
Z_BEST_COMPRESSION = 9;
Z_DEFAULT_COMPRESSION = (-1);
Z_FILTERED = 1;
Z_HUFFMAN_ONLY = 2;
Z_DEFAULT_STRATEGY = 0;
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
_z_errmsg: array[0..9] of PChar = (
'need dictionary', // Z_NEED_DICT (2)
'stream end', // Z_STREAM_END (1)
'', // Z_OK (0)
'file error', // Z_ERRNO (-1)
'stream error', // Z_STREAM_ERROR (-2)
'data error', // Z_DATA_ERROR (-3)
'insufficient memory', // Z_MEM_ERROR (-4)
'buffer error', // Z_BUF_ERROR (-5)
'incompatible version', // Z_VERSION_ERROR (-6)
''
);
implementation
{$L obj\adler32.obj}
{$L obj\deflate.obj}
{$L obj\infback.obj}
{$L obj\inffast.obj}
{$L obj\inflate.obj}
{$L obj\inftrees.obj}
{$L obj\trees.obj}
{$L obj\compress.obj}
{$L obj\crc32.obj}
function adler32(adler: LongInt; const buf: PChar; len: Integer): LongInt; external;
procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
begin
FillChar(P^, count, B);
end;
procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
begin
Move(source^, dest^, count);
end;
// deflate compresses data
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
recsize: Integer): Integer; external;
function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function deflateEnd(var strm: TZStreamRec): Integer; external;
// inflate decompresses data
function inflateInit_(var strm: TZStreamRec; version: PChar;
recsize: Integer): Integer; external;
function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function inflateEnd(var strm: TZStreamRec): Integer; external;
function inflateReset(var strm: TZStreamRec): Integer; external;
function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer;
begin
GetMem(Result, Items*Size);
end;
procedure zcfree(AppData, Block: Pointer);
begin
FreeMem(Block);
end;
end.