From 76c17fa12659c976bf0546fe910fd8e6850edf8f Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 10:05:24 +0400 Subject: [PATCH 01/12] Removing from Hash makes all the numbers above decrement, thus generating dangling references for upper part of hash list --- jcl/source/common/JclSimpleXml.pas | 8789 ++++++++++++++-------------- 1 file changed, 4395 insertions(+), 4394 deletions(-) diff --git a/jcl/source/common/JclSimpleXml.pas b/jcl/source/common/JclSimpleXml.pas index 88dbc09fce..a55b2c5fea 100644 --- a/jcl/source/common/JclSimpleXml.pas +++ b/jcl/source/common/JclSimpleXml.pas @@ -1,4394 +1,4395 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 JvSimpleXML.PAS, released on 2002-06-03. } -{ } -{ The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]. } -{ Portions created by Sébastien Buysse are Copyright (C) 2001 Sébastien Buysse. } -{ All Rights Reserved. } -{ } -{ Contributor(s): } -{ Christophe Paris, } -{ Florent Ouchet (move from the JVCL to the JCL) } -{ Teträm } -{ } -{**************************************************************************************************} -{ } -{ This unit contains Xml parser and writter classes } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -// Known Issues: This component does not parse the !DOCTYPE tags but preserves them - -unit JclSimpleXml; - -interface - -{$I jcl.inc} - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF HAS_UNIT_RTLCONSTS} - System.RTLConsts, - {$ENDIF HAS_UNIT_RTLCONSTS} - {$IFDEF MSWINDOWS} - Winapi.Windows, // Delphi 2005 inline - {$ENDIF MSWINDOWS} - System.SysUtils, System.Classes, - System.Variants, - System.IniFiles, - System.Contnrs, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF HAS_UNIT_RTLCONSTS} - RTLConsts, - {$ENDIF HAS_UNIT_RTLCONSTS} - {$IFDEF MSWINDOWS} - Windows, // Delphi 2005 inline - {$ENDIF MSWINDOWS} - SysUtils, Classes, - Variants, - IniFiles, - Contnrs, - {$ENDIF ~HAS_UNITSCOPE} - JclBase, JclStreams; - -type - TJclSimpleItem = class(TObject) - private - FName: string; - protected - procedure SetName(const Value: string); virtual; - public - property Name: string read FName write SetName; - end; - -type - TJclSimpleItemHashedList = class(TObjectList) - private - FNameHash: TStringHash; - FCaseSensitive: Boolean; - function GetSimpleItemByName(const Name: string): TJclSimpleItem; - function GetSimpleItem(Index: Integer): TJclSimpleItem; - procedure SetCaseSensitive(const Value: Boolean); - protected - procedure Notify(Ptr: Pointer; Action: TListNotification); override; - public - constructor Create(ACaseSensitive: Boolean); - destructor Destroy; override; - function Add(Item: TJclSimpleItem): Integer; - procedure Clear; override; - function IndexOfSimpleItem(Item: TJclSimpleItem): Integer; - function IndexOfName(const Name: string): Integer; - procedure Insert(Index: Integer; Item: TJclSimpleItem); - procedure InvalidateHash; - procedure Move(CurIndex, NewIndex: Integer); - property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; - property SimpleItemByNames[const Name: string]: TJclSimpleItem read GetSimpleItemByName; - property SimpleItems[Index: Integer]: TJclSimpleItem read GetSimpleItem; - end; - -type - TJclSimpleData = class(TJclSimpleItem) - private - FValue: string; - FData: Pointer; - protected - function GetBoolValue: Boolean; - procedure SetBoolValue(const Value: Boolean); - function GetFloatValue: Extended; - procedure SetFloatValue(const Value: Extended); - function GetAnsiValue: AnsiString; - procedure SetAnsiValue(const Value: AnsiString); - function GetIntValue: Int64; - procedure SetIntValue(const Value: Int64); - public - constructor Create; overload; virtual; - constructor Create(const AName: string); overload; - constructor Create(const AName, AValue: string); overload; - property Value: string read FValue write FValue; - property AnsiValue: AnsiString read GetAnsiValue write SetAnsiValue; - property IntValue: Int64 read GetIntValue write SetIntValue; - property BoolValue: Boolean read GetBoolValue write SetBoolValue; - property FloatValue: Extended read GetFloatValue write SetFloatValue; - - property Data: Pointer read FData write FData; - end; - -type - TJclSimpleXMLData = class(TJclSimpleData) - private - FNameSpace: string; - public - function FullName:string; - property NameSpace: string read FNameSpace write FNameSpace; - end; - -type - TJclSimpleXML = class; - EJclSimpleXMLError = class(EJclError); - {$TYPEINFO ON} // generate RTTI for published properties - TJclSimpleXMLElem = class; - {$IFNDEF TYPEINFO_ON} - {$TYPEINFO OFF} - {$ENDIF ~TYPEINFO_ON} - TJclSimpleXMLElems = class; - TJclSimpleXMLProps = class; - TJclSimpleXMLElemsProlog = class; - TJclSimpleXMLNamedElems = class; - TJclSimpleXMLElemComment = class; - TJclSimpleXMLElemClassic = class; - TJclSimpleXMLElemCData = class; - TJclSimpleXMLElemDocType = class; - TJclSimpleXMLElemText = class; - TJclSimpleXMLElemHeader = class; - TJclSimpleXMLElemSheet = class; - TJclSimpleXMLElemMSOApplication = class; - TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object; - TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object; - TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; - - //Those hash stuffs are for future use only - //Plans are to replace current hash by this mechanism - TJclHashKind = (hkList, hkDirect); - PJclHashElem = ^TJclHashElem; - TJclHashElem = packed record - Next: PJclHashElem; - Obj: TObject; - end; - PJclHashRecord = ^TJclHashRecord; - TJclHashList = array [0..25] of PJclHashRecord; - PJclHashList = ^TJclHashList; - TJclHashRecord = packed record - Count: Byte; - case Kind: TJclHashKind of - hkList: (List: PJclHashList); - hkDirect: (FirstElem: PJclHashElem); - end; - - TJclSimpleXMLProp = class(TJclSimpleXMLData) - private - FParent: TJclSimpleXMLElem; - protected - function GetSimpleXML: TJclSimpleXML; - procedure SetName(const Value: string); override; - public - constructor Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); - procedure SaveToStringStream(StringStream: TJclStringStream); - property Parent: TJclSimpleXMLElem read FParent; - property SimpleXML: TJclSimpleXML read GetSimpleXML; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLPropsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLProps; - public - constructor Create(AList: TJclSimpleXMLProps); - function GetCurrent: TJclSimpleXMLProp; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLProp read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLProps = class(TObject) - private - FProperties: TStringList; - FParent: TJclSimpleXMLElem; - function GetCount: Integer; - function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; - function GetItemNamed(const Name: string): TJclSimpleXMLProp; - protected - function GetSimpleXML: TJclSimpleXML; - function GetItem(const Index: Integer): TJclSimpleXMLProp; - procedure DoItemRename(Value: TJclSimpleXMLProp; const Name: string); - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - constructor Create(AParent: TJclSimpleXMLElem); - destructor Destroy; override; - function Add(const Name, Value: string): TJclSimpleXMLProp; overload; - {$IFDEF SUPPORTS_UNICODE} - function Add(const Name: string; const Value: AnsiString): TJclSimpleXMLProp; overload; - {$ENDIF SUPPORTS_UNICODE} - function Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; - function Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; - procedure Clear; virtual; - procedure Delete(const Index: Integer); overload; - procedure Delete(const Name: string); overload; - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLPropsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - function Value(const Name: string; const Default: string = ''): string; - function IntValue(const Name: string; const Default: Int64 = -1): Int64; - function BoolValue(const Name: string; Default: Boolean = True): Boolean; - function FloatValue(const Name: string; const Default: Extended = 0): Extended; - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream); - property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default; - property ItemNamed[const Name: string]: TJclSimpleXMLProp read GetItemNamed; - property Count: Integer read GetCount; - property Parent: TJclSimpleXMLElem read FParent; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLElemsPrologEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLElemsProlog; - public - constructor Create(AList: TJclSimpleXMLElemsProlog); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLElemsProlog = class(TObject) - private - FElems: TJclSimpleItemHashedList; - function GetCount: Integer; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - function GetEncoding: string; - function GetStandAlone: Boolean; - function GetVersion: string; - procedure SetEncoding(const Value: string); - procedure SetStandAlone(const Value: Boolean); - procedure SetVersion(const Value: string); - protected - FSimpleXML: TJclSimpleXML; - function FindHeader: TJclSimpleXMLElem; - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - constructor Create(ASimpleXML: TJclSimpleXML); - destructor Destroy; override; - function AddComment(const AValue: string): TJclSimpleXMLElemComment; - function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; - procedure Clear; - function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; - function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream); - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property Count: Integer read GetCount; - property Encoding: string read GetEncoding write SetEncoding; - property SimpleXML: TJclSimpleXML read FSimpleXML; - property StandAlone: Boolean read GetStandAlone write SetStandAlone; - property Version: string read GetVersion write SetVersion; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLNamedElemsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLNamedElems; - public - constructor Create(AList: TJclSimpleXMLNamedElems); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLNamedElems = class(TJclSimpleItem) - private - FElems: TJclSimpleXMLElems; - function GetCount: Integer; - protected - FItems: TList; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - procedure SetName(const Value: string); override; - public - constructor Create(AElems: TJclSimpleXMLElems; const AName: string); - destructor Destroy; override; - - function Add: TJclSimpleXMLElemClassic; overload; - function Add(const Value: string): TJclSimpleXMLElemClassic; overload; - function Add(const Value: Int64): TJclSimpleXMLElemClassic; overload; - function Add(const Value: Boolean): TJclSimpleXMLElemClassic; overload; - function Add(Value: TStream): TJclSimpleXMLElemClassic; overload; - function AddFirst: TJclSimpleXMLElemClassic; - function AddComment(const Value: string): TJclSimpleXMLElemComment; - function AddCData(const Value: string): TJclSimpleXMLElemCData; - function AddText(const Value: string): TJclSimpleXMLElemText; - procedure Clear; virtual; - procedure Delete(const Index: Integer); - procedure Move(const CurIndex, NewIndex: Integer); - function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; - function IndexOf(const Value: string): Integer; overload; - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - - property Elems: TJclSimpleXMLElems read FElems; - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property Count: Integer read GetCount; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLElemsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLElems; - public - constructor Create(AList: TJclSimpleXMLElems); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLElemCompare = function(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer of object; - TJclSimpleXMLElems = class(TObject) - private - FParent: TJclSimpleXMLElem; - function GetCount: Integer; - function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; - function GetItemNamed(const Name: string): TJclSimpleXMLElem; - function GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; - protected - FElems: TJclSimpleItemHashedList; - FCompare: TJclSimpleXMLElemCompare; - FNamedElems: TJclSimpleItemHashedList; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - procedure AddChild(const Value: TJclSimpleXMLElem); - procedure AddChildFirst(const Value: TJclSimpleXMLElem); - procedure InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); - procedure DoItemRename(Value: TJclSimpleXMLElem; const Name: string); - procedure CreateElems; - function SimpleCompare(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer; - public - constructor Create(AParent: TJclSimpleXMLElem); - destructor Destroy; override; - - // Use notify to indicate to a list that the given element is removed - // from the list so that it doesn't delete it as well as the one - // that insert it in itself. This method is automatically called - // by AddChild and AddChildFirst if the Container property of the - // given element is set. - procedure Notify(Value: TJclSimpleXMLElem; Operation: TOperation); - - function Add(const Name: string): TJclSimpleXMLElemClassic; overload; - function Add(const Name, Value: string): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; overload; - function Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; - function AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; - function AddFirst(const Name: string): TJclSimpleXMLElemClassic; overload; - function AddComment(const Name: string; const Value: string): TJclSimpleXMLElemComment; - function AddCData(const Name: string; const Value: string): TJclSimpleXMLElemCData; - function AddText(const Name: string; const Value: string): TJclSimpleXMLElemText; - function Insert(Value: TJclSimpleXMLElem; Index: Integer): TJclSimpleXMLElem; overload; - function Insert(const Name: string; Index: Integer): TJclSimpleXMLElemClassic; overload; - procedure Clear; virtual; - procedure Delete(const Index: Integer); overload; - procedure Delete(const Name: string); overload; - function Remove(Value: TJclSimpleXMLElem): Integer; - procedure Move(const CurIndex, NewIndex: Integer); - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLElemsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; - function IndexOf(const Name: string): Integer; overload; - function Value(const Name: string; const Default: string = ''): string; - function IntValue(const Name: string; const Default: Int64 = -1): Int64; - function FloatValue(const Name: string; const Default: Extended = 0): Extended; - function BoolValue(const Name: string; Default: Boolean = True): Boolean; - procedure BinaryValue(const Name: string; Stream: TStream); - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); - procedure Sort; - procedure CustomSort(AFunction: TJclSimpleXMLElemCompare); - property Parent: TJclSimpleXMLElem read FParent; - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property ItemNamed[const Name: string]: TJclSimpleXMLElem read GetItemNamed; - property Count: Integer read GetCount; - property NamedElems[const Name: string]: TJclSimpleXMLNamedElems read GetNamedElems; - end; - - {$TYPEINFO ON} - TJclSimpleXMLElem = class(TJclSimpleXMLData) - private - FParent: TJclSimpleXMLElem; - FSimpleXML: TJclSimpleXML; - function GetHasItems: Boolean; - function GetHasProperties: Boolean; - function GetItemCount: Integer; - function GetPropertyCount: Integer; - protected - FItems: TJclSimpleXMLElems; - FProps: TJclSimpleXMLProps; - function GetChildsCount: Integer; - function GetProps: TJclSimpleXMLProps; - procedure SetName(const Value: string); override; - function GetItems: TJclSimpleXMLElems; - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - //constructor Create; overload; - //constructor Create(const AName: string); overload; - //constructor Create(const AName, AValue: string); overload; - constructor Create(ASimpleXML: TJclSimpleXML); overload; - destructor Destroy; override; - procedure Assign(Value: TJclSimpleXMLElem); virtual; - procedure Clear; virtual; - procedure LoadFromStringStream(StringStream: TJclStringStream); virtual; abstract; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); virtual; - abstract; - procedure LoadFromString(const Value: string); - function SaveToString: string; - procedure GetBinaryValue(Stream: TStream); - function GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; - function GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; - - property SimpleXML: TJclSimpleXML read FSimpleXML; - published - property Parent: TJclSimpleXMLElem read FParent; - property ChildsCount: Integer read GetChildsCount; - property HasItems: Boolean read GetHasItems; - property HasProperties: Boolean read GetHasProperties; - property ItemCount: Integer read GetItemCount; - property PropertyCount: Integer read GetPropertyCount; - property Items: TJclSimpleXMLElems read GetItems; - property Properties: TJclSimpleXMLProps read GetProps; - end; - {$IFNDEF TYPEINFO_ON} - {$TYPEINFO OFF} - {$ENDIF ~TYPEINFO_ON} - TJclSimpleXMLElemClass = class of TJclSimpleXMLElem; - - TJclSimpleXMLElemComment = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemClassic = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemCData = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemText = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemProcessingInstruction = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemHeader = class(TJclSimpleXMLElemProcessingInstruction) - private - function GetEncoding: string; - function GetStandalone: Boolean; - function GetVersion: string; - procedure SetEncoding(const Value: string); - procedure SetStandalone(const Value: Boolean); - procedure SetVersion(const Value: string); - public - constructor Create; override; - - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - property Version: string read GetVersion write SetVersion; - property StandAlone: Boolean read GetStandalone write SetStandalone; - property Encoding: string read GetEncoding write SetEncoding; - end; - - // for backward compatibility - TJclSimpleXMLElemSheet = class(TJclSimpleXMLElemProcessingInstruction) - end; - - // for backward compatibility - TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElemProcessingInstruction) - end; - - TJclSimpleXMLElemDocType = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue, - sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace, - sxoTrimFollowingTextWhitespace, sxoKeepWhitespace, sxoDoNotSaveBOM, sxoCaseSensitive); - TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object; - TJclSimpleXMLEncodeStreamEvent = procedure(Sender: TObject; InStream, OutStream: TStream) of object; - - TJclSimpleXML = class(TObject) - protected - FEncoding: TJclStringEncoding; - FCodePage: Word; - FFileName: TFileName; - FOptions: TJclSimpleXMLOptions; - FRoot: TJclSimpleXMLElemClassic; - FOnTagParsed: TJclOnSimpleXMLParsed; - FOnValue: TJclOnValueParsed; - FOnLoadProg: TJclOnSimpleProgress; - FOnSaveProg: TJclOnSimpleProgress; - FProlog: TJclSimpleXMLElemsProlog; - FSaveCount: Integer; - FSaveCurrent: Integer; - FIndentString: string; - FBaseIndentString: string; - FOnEncodeValue: TJclSimpleXMLEncodeEvent; - FOnDecodeValue: TJclSimpleXMLEncodeEvent; - FOnDecodeStream: TJclSimpleXMLEncodeStreamEvent; - FOnEncodeStream: TJclSimpleXMLEncodeStreamEvent; - procedure SetIndentString(const Value: string); - procedure SetBaseIndentString(const Value: string); - procedure SetRoot(const Value: TJclSimpleXMLElemClassic); - procedure SetFileName(const Value: TFileName); - protected - procedure DoLoadProgress(const APosition, ATotal: Integer); - procedure DoSaveProgress; - procedure DoTagParsed(const AName: string); - procedure DoValueParsed(const AName, AValue: string); - procedure DoEncodeValue(var Value: string); virtual; - procedure DoDecodeValue(var Value: string); virtual; - procedure GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); - public - constructor Create; - destructor Destroy; override; - procedure LoadFromString(const Value: string); - procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure LoadFromResourceName(Instance: THandle; const ResName: string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToStringStream(StringStream: TJclStringStream); - function SaveToString: string; - function SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word = CP_ACP): string; - property CodePage: Word read FCodePage; - property Prolog: TJclSimpleXMLElemsProlog read FProlog write FProlog; - property Root: TJclSimpleXMLElemClassic read FRoot write SetRoot; - property XMLData: string read SaveToString write LoadFromString; - property FileName: TFileName read FFileName write SetFileName; - property IndentString: string read FIndentString write SetIndentString; - property BaseIndentString: string read FBaseIndentString write SetBaseIndentString; - property Options: TJclSimpleXMLOptions read FOptions write FOptions; - property OnSaveProgress: TJclOnSimpleProgress read FOnSaveProg write FOnSaveProg; - property OnLoadProgress: TJclOnSimpleProgress read FOnLoadProg write FOnLoadProg; - property OnTagParsed: TJclOnSimpleXMLParsed read FOnTagParsed write FOnTagParsed; - property OnValueParsed: TJclOnValueParsed read FOnValue write FOnValue; - property OnEncodeValue: TJclSimpleXMLEncodeEvent read FOnEncodeValue write FOnEncodeValue; - property OnDecodeValue: TJclSimpleXMLEncodeEvent read FOnDecodeValue write FOnDecodeValue; - property OnEncodeStream: TJclSimpleXMLEncodeStreamEvent read FOnEncodeStream write FOnEncodeStream; - property OnDecodeStream: TJclSimpleXMLEncodeStreamEvent read FOnDecodeStream write FOnDecodeStream; - end; - - TXMLVariant = class(TInvokeableVariantType) - public - procedure Clear(var V: TVarData); override; - function IsClear(const V: TVarData): Boolean; override; - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - procedure CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); override; - - function DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; override; - function GetProperty(var Dest: TVarData; const V: TVarData; - const Name: string): Boolean; override; - function SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - end; - -procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); -function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; overload; -function XMLCreate: Variant; overload; -function VarXML: TVarType; - -// Encodes a string into an internal format: -// any character TAB,LF,CR,#32..#127 is preserved -// all other characters are converted to hex notation except -// for some special characters that are converted to XML entities -function SimpleXMLEncode(const S: string): string; -// Decodes a string encoded with SimpleXMLEncode: -// any character TAB,LF,CR,#32..#127 is preserved -// all other characters and substrings are converted from -// the special XML entities to characters or from hex to characters -// NB! Setting TrimBlanks to true will slow down the process considerably -procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); - -function XMLEncode(const S: string): string; -function XMLDecode(const S: string): string; - -// Encodes special characters (', ", <, > and &) into XML entities (@apos;, ", <, > and &) -function EntityEncode(const S: string): string; -// Decodes XML entities (@apos;, ", <, > and &) into special characters (', ", <, > and &) -function EntityDecode(const S: string): string; - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNITSCOPE} - System.Types, - {$ENDIF HAS_UNITSCOPE} - JclCharsets, - JclStrings, - JclUnicode, - JclStringConversions, - JclResources; - -const - cBufferSize = 8192; - -var - GlobalXMLVariant: TXMLVariant = nil; - - PreparedNibbleCharMapping: Boolean = False; - NibbleCharMapping: array [Low(Char)..High(Char)] of Byte; - -function XMLVariant: TXMLVariant; -begin - if not Assigned(GlobalXMLVariant) then - GlobalXMLVariant := TXMLVariant.Create; - Result := GlobalXMLVariant; -end; - -procedure AddEntity(var Res: string; var ResIndex, ResLen: Integer; const Entity: string); -var - EntityIndex, EntityLen: Integer; -begin - EntityLen := Length(Entity); - if (ResIndex + EntityLen) > ResLen then - begin - if ResLen <= EntityLen then - ResLen := ResLen * EntityLen - else - ResLen := ResLen * 2; - SetLength(Res, ResLen); - end; - for EntityIndex := 1 to EntityLen do - begin - Res[ResIndex] := Entity[EntityIndex]; - Inc(ResIndex); - end; -end; - -function EntityEncode(const S: string): string; -var - C: Char; - SIndex, SLen, RIndex, RLen: Integer; - Tmp: string; -begin - SLen := Length(S); - RLen := SLen; - RIndex := 1; - SetLength(Tmp, RLen); - for SIndex := 1 to SLen do - begin - C := S[SIndex]; - case C of - '"': - AddEntity(Tmp, RIndex, RLen, '"'); - '&': - AddEntity(Tmp, RIndex, RLen, '&'); - #39: - AddEntity(Tmp, RIndex, RLen, '''); - '<': - AddEntity(Tmp, RIndex, RLen, '<'); - '>': - AddEntity(Tmp, RIndex, RLen, '>'); - else - if RIndex > RLen then - begin - RLen := RLen * 2; - SetLength(Tmp, RLen); - end; - Tmp[RIndex] := C; - Inc(RIndex); - end; - end; - if RIndex > 1 then - SetLength(Tmp, RIndex - 1); - - Result := Tmp; -end; - -function EntityDecode(const S: string): string; -var - I, J, L: Integer; -begin - Result := S; - I := 1; - J := 1; - L := Length(Result); - - while I <= L do - begin - if Result[I] = '&' then - begin - if StrSame(Copy(Result, I, 5), '&') then - begin - Result[J] := '&'; - Inc(J); - Inc(I, 4); - end - else - if StrSame(Copy(Result, I, 4), '<') then - begin - Result[J] := '<'; - Inc(J); - Inc(I, 3); - end - else - if StrSame(Copy(Result, I, 4), '>') then - begin - Result[J] := '>'; - Inc(J); - Inc(I, 3); - end - else - if StrSame(Copy(Result, I, 6), ''') then - begin - Result[J] := #39; - Inc(J); - Inc(I, 5); - end - else - if StrSame(Copy(Result, I, 6), '"') then - begin - Result[J] := '"'; - Inc(J); - Inc(I, 5); - end - else - begin - Result[J] := Result[I]; - Inc(J); - end; - end - else - begin - Result[J] := Result[I]; - Inc(J); - end; - Inc(I); - end; - if J > 1 then - SetLength(Result, J - 1) - else - SetLength(Result, 0); -end; - -function SimpleXMLEncode(const S: string): string; -var - C: Char; - SIndex, SLen, RIndex, RLen: Integer; - Tmp: string; -begin - SLen := Length(S); - RLen := SLen; - RIndex := 1; - SetLength(Tmp, RLen); - for SIndex := 1 to SLen do - begin - C := S[SIndex]; - case C of - '"': - AddEntity(Tmp, RIndex, RLen, '"'); - '&': - AddEntity(Tmp, RIndex, RLen, '&'); - #39: - AddEntity(Tmp, RIndex, RLen, '''); - '<': - AddEntity(Tmp, RIndex, RLen, '<'); - '>': - AddEntity(Tmp, RIndex, RLen, '>'); - NativeNull..NativeBackspace, // NativeTab, NativeLineFeed - NativeVerticalTab..NativeFormFeed, // NativeCarriageReturn - NativeSo..NativeUs, - Char(128)..Char(255): - AddEntity(Tmp, RIndex, RLen, Format('&#x%.2x;', [Ord(C)])); - {$IFDEF SUPPORTS_UNICODE} - Char(256)..High(Char): - AddEntity(Tmp, RIndex, RLen, Format('&#x%.4x;', [Ord(C)])); - {$ENDIF SUPPORTS_UNICODE} - else - if RIndex > RLen then - begin - RLen := RLen * 2; - SetLength(Tmp, RLen); - end; - Tmp[RIndex] := C; - Inc(RIndex); - end; - end; - if RIndex > 1 then - SetLength(Tmp, RIndex - 1); - - Result := Tmp; -end; - -procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); - procedure DecodeEntity(var S: string; StringLength: Cardinal; - var ReadIndex, WriteIndex: Cardinal); - const - cHexPrefix: array [Boolean] of string = ('', '$'); - var - I: Cardinal; - Value: Integer; - IsHex: Boolean; - begin - Inc(ReadIndex, 2); - IsHex := (ReadIndex <= StringLength) and ((S[ReadIndex] = 'x') or (S[ReadIndex] = 'X')); - Inc(ReadIndex, Ord(IsHex)); - I := ReadIndex; - while ReadIndex <= StringLength do - begin - if S[ReadIndex] = ';' then - begin - Value := StrToIntDef(cHexPrefix[IsHex] + Copy(S, I, ReadIndex - I), -1); // no characters are less than 0 - if Value >= 0 then - S[WriteIndex] := Chr(Value) - else - ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start - Exit; - end; - Inc(ReadIndex); - end; - ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start - end; - - procedure SkipBlanks(var S: string; StringLength: Cardinal; var ReadIndex: Cardinal); - begin - while ReadIndex < StringLength do - begin - if S[ReadIndex] = NativeCarriageReturn then - S[ReadIndex] := NativeLineFeed - else - if S[ReadIndex + 1] = NativeCarriageReturn then - S[ReadIndex + 1] := NativeLineFeed; - if (S[ReadIndex] < #33) and (S[ReadIndex] = S[ReadIndex + 1]) then - Inc(ReadIndex) - else - Exit; - end; - end; - -var - StringLength, ReadIndex, WriteIndex: Cardinal; -begin - // NB! This procedure replaces the text inplace to speed up the conversion. This - // works because when decoding, the string can only become shorter. This is - // accomplished by keeping track of the current read and write points. - // In addition, the original string length is read only once and passed to the - // inner procedures to speed up conversion as much as possible - ReadIndex := 1; - WriteIndex := 1; - StringLength := Length(S); - while ReadIndex <= StringLength do - begin - // this call lowers conversion speed by ~30%, ie 21MB/sec -> 15MB/sec (repeated tests, various inputs) - if TrimBlanks then - SkipBlanks(S, StringLength, ReadIndex); - if S[ReadIndex] = '&' then - begin - if (ReadIndex < StringLength) and (S[ReadIndex + 1] = '#') then - begin - DecodeEntity(S, StringLength, ReadIndex, WriteIndex); - Inc(WriteIndex); - end - else - if StrSame(Copy(S, ReadIndex, 5), '&') then - begin - S[WriteIndex] := '&'; - Inc(WriteIndex); - Inc(ReadIndex, 4); - end - else - if StrSame(Copy(S, ReadIndex, 4), '<') then - begin - S[WriteIndex] := '<'; - Inc(WriteIndex); - Inc(ReadIndex, 3); - end - else - if StrSame(Copy(S, ReadIndex, 4), '>') then - begin - S[WriteIndex] := '>'; - Inc(WriteIndex); - Inc(ReadIndex, 3); - end - else - if StrSame(Copy(S, ReadIndex, 6), ''') then - begin - S[WriteIndex] := #39; - Inc(WriteIndex); - Inc(ReadIndex, 5); - end - else - if StrSame(Copy(S, ReadIndex, 6), '"') then - begin - S[WriteIndex] := '"'; - Inc(WriteIndex); - Inc(ReadIndex, 5); - end - else - begin - S[WriteIndex] := S[ReadIndex]; - Inc(WriteIndex); - end; - end - else - begin - S[WriteIndex] := S[ReadIndex]; - Inc(WriteIndex); - end; - Inc(ReadIndex); - end; - if WriteIndex > 0 then - SetLength(S, WriteIndex - 1) - else - SetLength(S, 0); - // this call lowers conversion speed by ~65%, ie 21MB/sec -> 7MB/sec (repeated tests, various inputs) -// if TrimBlanks then -// S := AdjustLineBreaks(S); -end; - -function XMLEncode(const S: string): string; -begin - Result := SimpleXMLEncode(S); -end; - -function XMLDecode(const S: string): string; -begin - Result := S; - SimpleXMLDecode(Result, False); -end; - -//=== { TJclSimpleItem } ===================================================== - -procedure TJclSimpleItem.SetName(const Value: string); -begin - FName := Value; -end; - -//=== { TJclSimpleItemHashedList } =========================================== - -procedure TJclSimpleItemHashedList.Clear; -begin - InvalidateHash; - inherited Clear; -end; - -constructor TJclSimpleItemHashedList.Create(ACaseSensitive: Boolean); -begin - inherited Create(True); - FCaseSensitive := ACaseSensitive; -end; - -destructor TJclSimpleItemHashedList.Destroy; -begin - FreeAndNil(FNameHash); - inherited Destroy; -end; - -function TJclSimpleItemHashedList.Add(Item: TJclSimpleItem): Integer; -begin - Result := inherited Add(Item); - if FNameHash <> nil then - begin - if FCaseSensitive then - FNameHash.Add(Item.Name, Result) - else - FNameHash.Add(UpperCase(Item.Name), Result); - end; -end; - -function TJclSimpleItemHashedList.GetSimpleItem(Index: Integer): TJclSimpleItem; -begin - Result := TJclSimpleItem(GetItem(Index)); -end; - -function TJclSimpleItemHashedList.GetSimpleItemByName(const Name: string): TJclSimpleItem; -var - I: Integer; -begin - I := IndexOfName(Name); - if I >= 0 then - Result := TJclSimpleItem(Items[I]) - else - Result := nil; -end; - -function TJclSimpleItemHashedList.IndexOfSimpleItem(Item: TJclSimpleItem): Integer; -begin - Result := IndexOf(Item); -end; - -function TJclSimpleItemHashedList.IndexOfName(const Name: string): Integer; -var - I: Integer; -begin - if FCaseSensitive then - begin - if FNameHash = nil then - begin - FNameHash := TStringHash.Create(8); - for I := 0 to Count - 1 do - FNameHash.Add(TJclSimpleData(Items[I]).Name, I); - end; - Result := FNameHash.ValueOf(Name); - end - else - begin - if FNameHash = nil then - begin - FNameHash := TStringHash.Create(8); - for I := 0 to Count - 1 do - FNameHash.Add(UpperCase(TJclSimpleData(Items[I]).Name), I); - end; - Result := FNameHash.ValueOf(UpperCase(Name)); - end; -end; - -procedure TJclSimpleItemHashedList.Insert(Index: Integer; Item: TJclSimpleItem); -begin - InvalidateHash; - inherited Insert(Index, Item); -end; - -procedure TJclSimpleItemHashedList.InvalidateHash; -begin - FreeAndNil(FNameHash); -end; - -procedure TJclSimpleItemHashedList.Move(CurIndex, NewIndex: Integer); -begin - InvalidateHash; - inherited Move(CurIndex, NewIndex); -end; - -procedure TJclSimpleItemHashedList.Notify(Ptr: Pointer; Action: TListNotification); -begin - if (Action = lnDeleted) and (FNameHash <> nil) then - begin - if FCaseSensitive then - FNameHash.Remove(TJclSimpleItem(Ptr).Name) - else - FNameHash.Remove(UpperCase(TJclSimpleItem(Ptr).Name)); - end; - inherited Notify(Ptr, Action); -end; - -procedure TJclSimpleItemHashedList.SetCaseSensitive(const Value: Boolean); -begin - if FCaseSensitive <> Value then - begin - InvalidateHash; - FCaseSensitive := Value; - end; -end; - -//=== { TJclSimpleData } ===================================================== - -constructor TJclSimpleData.Create; -begin - inherited Create; -end; - -constructor TJclSimpleData.Create(const AName: string); -begin - inherited Create; - FName := AName; -end; - -constructor TJclSimpleData.Create(const AName, AValue: string); -begin - inherited Create; - FName := AName; - FValue := AValue; -end; - -function TJclSimpleData.GetAnsiValue: AnsiString; -begin - Result := AnsiString(Value); -end; - -function TJclSimpleData.GetBoolValue: Boolean; -begin - Result := StrToBoolDef(Value, False); -end; - -function TJclSimpleData.GetFloatValue: Extended; -begin - Result := 0.0; - if not TryStrToFloat(Value, Result) then - Result := 0.0; -end; - -function TJclSimpleData.GetIntValue: Int64; -begin - Result := StrToInt64Def(Value, -1); -end; - -procedure TJclSimpleData.SetAnsiValue(const Value: AnsiString); -begin - Self.Value := string(Value); -end; - -procedure TJclSimpleData.SetBoolValue(const Value: Boolean); -begin - FValue := BoolToStr(Value); -end; - -procedure TJclSimpleData.SetFloatValue(const Value: Extended); -begin - FValue := FloatToStr(Value); -end; - -procedure TJclSimpleData.SetIntValue(const Value: Int64); -begin - FValue := IntToStr(Value); -end; - -//=== { TJclSimpleXMLData } ================================================== - -function TJclSimpleXMLData.FullName: string; -begin - if NameSpace <> '' then - Result := NameSpace + ':' + Name - else - Result := Name; -end; - -//=== { TJclSimpleXML } ====================================================== - -constructor TJclSimpleXML.Create; -begin - inherited Create; - FRoot := TJclSimpleXMLElemClassic.Create(Self); - FProlog := TJclSimpleXMLElemsProlog.Create(Self); - FOptions := [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity]; - FIndentString := ' '; -end; - -destructor TJclSimpleXML.Destroy; -begin - FreeAndNil(FRoot); - FreeAndNil(FProlog); - inherited Destroy; -end; - -procedure TJclSimpleXML.DoDecodeValue(var Value: string); -begin - if sxoAutoEncodeValue in Options then - SimpleXMLDecode(Value, False) - else - if sxoAutoEncodeEntity in Options then - Value := EntityDecode(Value); - if Assigned(FOnDecodeValue) then - FOnDecodeValue(Self, Value); -end; - -procedure TJclSimpleXML.DoEncodeValue(var Value: string); -begin - if Assigned(FOnEncodeValue) then - FOnEncodeValue(Self, Value); - if sxoAutoEncodeValue in Options then - Value := SimpleXMLEncode(Value) - else - if sxoAutoEncodeEntity in Options then - Value := EntityEncode(Value); -end; - -procedure TJclSimpleXML.DoLoadProgress(const APosition, ATotal: Integer); -begin - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, APosition, ATotal); -end; - -procedure TJclSimpleXML.DoSaveProgress; -begin - if Assigned(FOnSaveProg) then - begin - Inc(FSaveCount); - FOnSaveProg(Self, FSaveCurrent, FSaveCount); - end; -end; - -procedure TJclSimpleXML.DoTagParsed(const AName: string); -begin - if Assigned(FOnTagParsed) then - FOnTagParsed(Self, AName); -end; - -procedure TJclSimpleXML.DoValueParsed(const AName, AValue: string); -begin - if Assigned(FOnValue) then - FOnValue(Self, AName, AValue); -end; - -procedure TJclSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); -var - Stream: TMemoryStream; -begin - Stream := TMemoryStream.Create; - try - Stream.LoadFromFile(FileName); - LoadFromStream(Stream, Encoding, CodePage); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromResourceName(Instance: THandle; const ResName: string; - Encoding: TJclStringEncoding; CodePage: Word); -{$IFNDEF MSWINDOWS} -const - RT_RCDATA = PChar(10); -{$ENDIF !MSWINDOWS} -var - Stream: TResourceStream; -begin - Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); - try - LoadFromStream(Stream, Encoding, CodePage); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); -var - AOutStream: TStream; - AStringStream: TJclStringStream; - DoFree: Boolean; -begin - FRoot.Clear; - FProlog.Clear; - AOutStream := nil; - DoFree := False; - try - if Assigned(FOnDecodeStream) then - begin - AOutStream := TMemoryStream.Create; - DoFree := True; - FOnDecodeStream(Self, Stream, AOutStream); - AOutStream.Seek(0, soBeginning); - end - else - AOutStream := Stream; - - case Encoding of - seAnsi: - begin - AStringStream := TJclAnsiStream.Create(AOutStream, False); - TJclAnsiStream(AStringStream).CodePage := CodePage; - end; - seUTF8: - AStringStream := TJclUTF8Stream.Create(AOutStream, False); - seUTF16: - AStringStream := TJclUTF16Stream.Create(AOutStream, False); - else - AStringStream := TJclAutoStream.Create(AOutStream, False); - if CodePage <> CP_ACP then - TJclAutoStream(AStringStream).CodePage := CodePage; - end; - try - AStringStream.SkipBOM; - - LoadFromStringStream(AStringStream); - - // save codepage and encoding for future saves - if AStringStream is TJclAutoStream then - begin - FCodePage := TJclAutoStream(AStringStream).CodePage; - FEncoding := TJclAutoStream(AStringStream).Encoding; - end - else - if AStringStream is TJclAnsiStream then - begin - FCodePage := TJclAnsiStream(AStringStream).CodePage; - FEncoding := Encoding; - end - else - begin - FCodePage := CodePage; - FEncoding := Encoding; - end; - finally - AStringStream.Free; - end; - finally - if DoFree then - AOutStream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromStringStream(StringStream: TJclStringStream); -var - BufferSize: Integer; -begin - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); - - BufferSize := StringStream.BufferSize; - StringStream.BufferSize := 1; - - // Read doctype and so on - FProlog.LoadFromStringStream(StringStream); - - StringStream.BufferSize := BufferSize; - - // Read elements - FRoot.LoadFromStringStream(StringStream); - - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); -end; - -procedure TJclSimpleXML.LoadFromString(const Value: string); -var - Stream: TStringStream; -begin - Stream := TStringStream.Create(Value {$IFDEF SUPPORTS_UNICODE}, TEncoding.Unicode{$ENDIF}); - try - LoadFromStream(Stream {$IFDEF SUPPORTS_UNICODE}, seUTF16, CP_UTF16LE{$ENDIF}); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); -var - XMLHeader: TJclSimpleXMLElemHeader; - I: Integer; -begin - XMLHeader := nil; - for I := 0 to Prolog.Count - 1 do - if Prolog.Item[I] is TJclSimpleXMLElemHeader then - begin - XMLHeader := TJclSimpleXMLElemHeader(Prolog.Item[I]); - Break; - end; - if Assigned(XMLHeader) then - begin - CodePage := CodePageFromCharsetName(XMLHeader.Encoding); - case CodePage of - CP_UTF8: - Encoding := seUTF8; - CP_UTF16LE: - Encoding := seUTF16; - else - Encoding := seAnsi; - end; - end - else - begin - // restore from previous load - Encoding := FEncoding; - CodePage := FCodePage; - end; -end; - -procedure TJclSimpleXML.SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); -var - Stream: TMemoryStream; -begin - Stream := TMemoryStream.Create; - try - SaveToStream(Stream, Encoding, CodePage); - Stream.SaveToFile(FileName); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); -var - AOutStream: TStream; - AStringStream: TJclStringStream; - DoFree: Boolean; -begin - if Assigned(FOnEncodeStream) then - begin - AOutStream := TMemoryStream.Create; - DoFree := True; - end - else - begin - AOutStream := Stream; - DoFree := False; - end; - try - if Encoding = seAuto then - GetEncodingFromXMLHeader(Encoding, CodePage); - - case Encoding of - seUTF8: - begin - AStringStream := TJclUTF8Stream.Create(AOutStream, False); - FCodePage := CP_UTF8; - end; - seUTF16: - begin - AStringStream := TJclUTF16Stream.Create(AOutStream, False); - FCodePage := CP_UTF16LE; - end - else - AStringStream := TJclAnsiStream.Create(AOutStream); - TJclAnsiStream(AStringStream).CodePage := CodePage; - end; - try - if not (sxoDoNotSaveBOM in Options) then - AStringStream.WriteBOM; - SaveToStringStream(AStringStream); - AStringStream.Flush; - finally - AStringStream.Free; - end; - if Assigned(FOnEncodeStream) then - begin - AOutStream.Seek(0, soBeginning); - FOnEncodeStream(Self, AOutStream, Stream); - end; - finally - if DoFree then - AOutStream.Free; - end; -end; - -procedure TJclSimpleXML.SaveToStringStream(StringStream: TJclStringStream); -var - lCount: Integer; -begin - lCount := Root.ChildsCount + Prolog.Count; - FSaveCount := lCount; - FSaveCurrent := 0; - - if Assigned(FOnSaveProg) then - FOnSaveProg(Self, 0, lCount); - - if not (sxoDoNotSaveProlog in FOptions) then - Prolog.SaveToStringStream(StringStream); - - Root.SaveToStringStream(StringStream, BaseIndentString); - - if Assigned(FOnSaveProg) then - FOnSaveProg(Self, lCount, lCount); -end; - -function TJclSimpleXML.SaveToString: string; -begin - Result := SaveToStringEncoding(seAuto, CP_ACP); -end; - -function TJclSimpleXML.SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word): string; -var - Stream: TStringStream; -begin - {$IFDEF SUPPORTS_UNICODE} - // Use the same logic for seAuto as in SaveToStream for creating the TStringStream. - // Otherwise a Unicode-TStringStream is written to from a TJclAnsiStream proxy. - if Encoding = seAuto then - GetEncodingFromXMLHeader(Encoding, CodePage); - - case Encoding of - seAnsi: - Stream := TStringStream.Create('', TEncoding.{$IFDEF COMPILER16_UP}ANSI{$ELSE}Default{$ENDIF}); - seUTF8: - Stream := TStringStream.Create('', TEncoding.UTF8); - else - //seUTF16: - Stream := TStringStream.Create('', TEncoding.Unicode); - end; - {$ELSE ~SUPPORTS_UNICODE} - Stream := TStringStream.Create(''); - {$ENDIF ~SUPPORTS_UNICODE} - try - SaveToStream(Stream, Encoding, CodePage); - Result := Stream.DataString; - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.SetBaseIndentString(const Value: string); -begin - // test if the new value is only made of spaces or tabs - if not StrContainsChars(Value, CharIsWhiteSpace, True) then - Exit; - - FBaseIndentString := Value; -end; - -procedure TJclSimpleXML.SetFileName(const Value: TFileName); -begin - FFileName := Value; - LoadFromFile(Value); -end; - -//=== { TJclSimpleXMLElem } ================================================== - -procedure TJclSimpleXMLElem.Assign(Value: TJclSimpleXMLElem); -var - Elems: TJclSimpleXMLElem; - SrcElem, DestElem: TJclSimpleXMLElem; - I: Integer; - SrcProps, DestProps: TJclSimpleXMLProps; - SrcProp: TJclSimpleXMLProp; - SrcElems, DestElems: TJclSimpleXMLElems; -begin - Clear; - if Value = nil then - Exit; - Elems := TJclSimpleXMLElem(Value); - Name := Elems.Name; - Self.Value := Elems.Value; - SrcProps := Elems.FProps; - if Assigned(SrcProps) then - begin - DestProps := Properties; - for I := 0 to SrcProps.Count - 1 do - begin - SrcProp := SrcProps.Item[I]; - DestProps.Add(SrcProp.Name, SrcProp.Value); - end; - end; - - SrcElems := Elems.FItems; - if Assigned(SrcElems) then - begin - DestElems := Items; - for I := 0 to SrcElems.Count - 1 do - begin - // Create from the class type, so that the virtual constructor is called - // creating an element of the correct class type. - SrcElem := SrcElems.Item[I]; - DestElem := TJclSimpleXMLElemClass(SrcElem.ClassType).Create(SrcElem.Name, SrcElem.Value); - DestElem.Assign(SrcElem); - DestElems.Add(DestElem); - end; - end; -end; - -procedure TJclSimpleXMLElem.Clear; -begin - if FItems <> nil then - FItems.Clear; - if FProps <> nil then - FProps.Clear; -end; - -constructor TJclSimpleXMLElem.Create(ASimpleXML: TJclSimpleXML); -begin - Create; - FSimpleXML := ASimpleXML; -end; - -destructor TJclSimpleXMLElem.Destroy; -begin - FSimpleXML := nil; - FParent := nil; - Clear; - FreeAndNil(FItems); - FreeAndNil(FProps); - inherited Destroy; -end; - -procedure TJclSimpleXMLElem.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -procedure TJclSimpleXMLElem.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -procedure TJclSimpleXMLElem.GetBinaryValue(Stream: TStream); -var - I, J, ValueLength, RequiredStreamSize: Integer; - Buf: array [0..cBufferSize - 1] of Byte; - N1, N2: Byte; - - function NibbleCharToNibble(const AChar: Char): Byte; - begin - case AChar of - '0': Result := 0; - '1': Result := 1; - '2': Result := 2; - '3': Result := 3; - '4': Result := 4; - '5': Result := 5; - '6': Result := 6; - '7': Result := 7; - '8': Result := 8; - '9': Result := 9; - 'a', 'A': Result := 10; - 'b', 'B': Result := 11; - 'c', 'C': Result := 12; - 'd', 'D': Result := 13; - 'e', 'E': Result := 14; - 'f', 'F': Result := 15; - else - Result := 16; - end; - end; - - procedure PrepareNibbleCharMapping; - var - C: Char; - begin - if not PreparedNibbleCharMapping then - begin - for C := Low(Char) to High(Char) do - NibbleCharMapping[C] := NibbleCharToNibble(C); - PreparedNibbleCharMapping := True; - end; - end; - -var - CurrentStreamPosition: Integer; -begin - PrepareNibbleCharMapping; - I := 1; - J := 0; - ValueLength := Length(Value); - RequiredStreamSize := Stream.Position + ValueLength div 2; - if Stream.Size < RequiredStreamSize then - begin - CurrentStreamPosition := Stream.Position; - Stream.Size := RequiredStreamSize; - Stream.Seek(CurrentStreamPosition, soBeginning); - end; - while I < ValueLength do - begin - //faster replacement for St := '$' + Value[I] + Value[I + 1]; Buf[J] := StrToIntDef(St, 0); - N1 := NibbleCharMapping[Value[I]]; - N2 := NibbleCharMapping[Value[I + 1]]; - Inc(I, 2); - if (N1 > 15) or (N2 > 15) then - Buf[J] := 0 - else - Buf[J] := (N1 shl 4) or N2; - Inc(J); - if J = cBufferSize - 1 then //Buffered write to speed up the process a little - begin - Stream.Write(Buf, J); - J := 0; - end; - end; - Stream.Write(Buf, J); -end; - -function TJclSimpleXMLElem.GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; -begin - if FItems = nil then - Result := -1 - else - Result := FItems.FElems.IndexOfSimpleItem(AChild); -end; - -function TJclSimpleXMLElem.GetChildsCount: Integer; -var - I: Integer; -begin - Result := 1; - if FItems <> nil then - for I := 0 to FItems.Count - 1 do - Result := Result + FItems[I].ChildsCount; -end; - -function TJclSimpleXMLElem.GetHasItems: Boolean; -begin - Result := Assigned(FItems) and (FItems.Count > 0); -end; - -function TJclSimpleXMLElem.GetHasProperties: Boolean; -begin - Result := Assigned(FProps) and (FProps.Count > 0); -end; - -function TJclSimpleXMLElem.GetItemCount: Integer; -begin - Result := 0; - if Assigned(FItems) then - Result := FItems.Count; -end; - -function TJclSimpleXMLElem.GetItems: TJclSimpleXMLElems; -begin - if FItems = nil then - FItems := TJclSimpleXMLElems.Create(Self); - Result := FItems; -end; - -function TJclSimpleXMLElem.GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; -begin - Result := Items.NamedElems[AChild.Name].IndexOf(AChild); -end; - -function TJclSimpleXMLElem.GetPropertyCount: Integer; -begin - Result := 0; - if Assigned(FProps) then - Result := FProps.Count; -end; - -function TJclSimpleXMLElem.GetProps: TJclSimpleXMLProps; -begin - if FProps = nil then - FProps := TJclSimpleXMLProps.Create(Self); - Result := FProps; -end; - -procedure TJclSimpleXMLElem.LoadFromString(const Value: string); -var - Stream: TJclStringStream; - StrStream: TStringStream; -begin - StrStream := TStringStream.Create(Value); - try - Stream := TJclAutoStream.Create(StrStream); - try - LoadFromStringStream(Stream); - finally - Stream.Free; - end; - finally - StrStream.Free; - end; -end; - -function TJclSimpleXMLElem.SaveToString: string; -var - Stream: TJclStringStream; - StrStream: TStringStream; -begin - StrStream := TStringStream.Create(''); - try - Stream := TJclAutoStream.Create(StrStream); - try - SaveToStringStream(Stream); - Stream.Flush; - finally - Stream.Free; - end; - Result := StrStream.DataString; - finally - StrStream.Free; - end; -end; - -procedure TJclSimpleXMLElem.SetName(const Value: string); -begin - if (Value <> Name) and (Value <> '') then - begin - if (Parent <> nil) and (Name <> '') then - Parent.Items.DoItemRename(Self, Value); - inherited SetName(Value); - end; -end; - -//=== { TJclSimpleXMLNamedElemsEnumerator } ================================== - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLNamedElemsEnumerator.Create(AList: TJclSimpleXMLNamedElems); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLNamedElemsEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLNamedElemsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLNamedElems } ============================================ - -constructor TJclSimpleXMLNamedElems.Create(AElems: TJclSimpleXMLElems; const AName: string); -begin - inherited Create; - FElems := AElems; - FName := AName; - FItems := TList.Create; -end; - -destructor TJclSimpleXMLNamedElems.Destroy; -begin - FItems.Free; - inherited Destroy; -end; - -function TJclSimpleXMLNamedElems.Add(const Value: Int64): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add(Value: TStream): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add(const Value: Boolean): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add: TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name); -end; - -function TJclSimpleXMLNamedElems.Add(const Value: string): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddCData(const Value: string): TJclSimpleXMLElemCData; -begin - Result := Elems.AddCData(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddComment(const Value: string): TJclSimpleXMLElemComment; -begin - Result := Elems.AddComment(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddFirst: TJclSimpleXMLElemClassic; -begin - Result := Elems.AddFirst(Name); -end; - -function TJclSimpleXMLNamedElems.AddText(const Value: string): TJclSimpleXMLElemText; -begin - Result := Elems.AddText(Name, Value); -end; - -procedure TJclSimpleXMLNamedElems.Clear; -var - Index: Integer; -begin - for Index := FItems.Count - 1 downto 0 do - Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); -end; - -procedure TJclSimpleXMLNamedElems.Delete(const Index: Integer); -begin - if (Index >= 0) and (Index < FItems.Count) then - Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); -end; - -function TJclSimpleXMLNamedElems.GetCount: Integer; -begin - Result := FItems.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLNamedElems.GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; -begin - Result := TJclSimpleXMLNamedElemsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLNamedElems.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - if (Index >= 0) then - begin - While (Index >= Count) do - if Assigned(Elems.Parent) and Assigned(Elems.Parent.SimpleXML) and - (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then - Add - else - break; - if Index < Count then - Result := TJclSimpleXMLElem(FItems.Items[Index]) - else - Result := nil; - end - else - Result := nil; -end; - -function TJclSimpleXMLNamedElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; -begin - Result := FItems.IndexOf(Value); -end; - -function TJclSimpleXMLNamedElems.IndexOf(const Value: string): Integer; -var - Index: Integer; - NewItem: TJclSimpleXMLElem; -begin - Result := -1; - for Index := 0 to FItems.Count - 1 do - if TJclSimpleXMLElem(FItems.Items[Index]).Value = Value then - begin - Result := Index; - Break; - end; - if (Result = -1) and (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then - begin - NewItem := Elems.Add(Name, Value); - Result := FItems.IndexOf(NewItem); - end; -end; - -procedure TJclSimpleXMLNamedElems.Move(const CurIndex, NewIndex: Integer); -var - ElemsCurIndex, ElemsNewIndex: Integer; -begin - ElemsCurIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[CurIndex])); - ElemsNewIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[NewIndex])); - Elems.Move(ElemsCurIndex, ElemsNewIndex); - FItems.Move(CurIndex, NewIndex); -end; - -procedure TJclSimpleXMLNamedElems.SetName(const Value: string); -begin - raise EJclSimpleXMLError.CreateRes(@SReadOnlyProperty); -end; - -//=== { TJclSimpleXMLElemsEnumerator } ======================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLElemsEnumerator.Create(AList: TJclSimpleXMLElems); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLElemsEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLElemsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLElems } ================================================= - -function TJclSimpleXMLElems.Add(const Name: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name, Value: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, IntToStr(Value)); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; -begin - if Value <> nil then - AddChild(Value); - Result := Value; -end; - -function TJclSimpleXMLElems.Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, BoolToStr(Value)); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; -var - Stream: TStringStream; - Buf: array [0..cBufferSize - 1] of Byte; - St: string; - I, Count: Integer; -begin - Stream := TStringStream.Create(''); - try - Buf[0] := 0; - repeat - Count := Value.Read(Buf, Length(Buf)); - St := ''; - for I := 0 to Count - 1 do - St := St + IntToHex(Buf[I], 2); - Stream.WriteString(St); - until Count = 0; - Result := TJclSimpleXMLElemClassic.Create(Name, Stream.DataString); - AddChild(Result); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXMLElems.AddChild(const Value: TJclSimpleXMLElem); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Add(Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; - - Notify(Value, opInsert); -end; - -procedure TJclSimpleXMLElems.AddChildFirst(const Value: TJclSimpleXMLElem); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Insert(0, Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Insert(0, Value); - end; - - Notify(Value, opInsert); -end; - -function TJclSimpleXMLElems.AddFirst(const Name: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - AddChildFirst(Result); -end; - -function TJclSimpleXMLElems.AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; -begin - if Value <> nil then - AddChildFirst(Value); - Result := Value; -end; - -function TJclSimpleXMLElems.AddComment(const Name, - Value: string): TJclSimpleXMLElemComment; -begin - Result := TJclSimpleXMLElemComment.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.AddCData(const Name, Value: string): TJclSimpleXMLElemCData; -begin - Result := TJclSimpleXMLElemCData.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.AddText(const Name, Value: string): TJclSimpleXMLElemText; -begin - Result := TJclSimpleXMLElemText.Create(Name, Value); - AddChild(Result); -end; - -procedure TJclSimpleXMLElems.BinaryValue(const Name: string; Stream: TStream); -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamed(Name); - if Elem <> nil then - Elem.GetBinaryValue(Stream); -end; - -function TJclSimpleXMLElems.BoolValue(const Name: string; Default: Boolean): Boolean; -var - Elem: TJclSimpleXMLElem; -begin - try - Elem := GetItemNamedDefault(Name, BoolToStr(Default)); - if (Elem = nil) or (Elem.Value = '') then - Result := Default - else - Result := Elem.BoolValue; - except - Result := Default; - end; -end; - -procedure TJclSimpleXMLElems.Clear; -begin - if FElems <> nil then - FElems.Clear; - if FNamedElems <> nil then - FNamedElems.Clear; -end; - -constructor TJclSimpleXMLElems.Create(AParent: TJclSimpleXMLElem); -begin - inherited Create; - FParent := AParent; -end; - -procedure TJclSimpleXMLElems.CreateElems; -var - CaseSensitive: Boolean; -begin - if FElems = nil then - begin - CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) - and (sxoCaseSensitive in Parent.SimpleXML.Options); - FElems := TJclSimpleItemHashedList.Create(CaseSensitive); - end; -end; - -procedure TJclSimpleXMLElems.Delete(const Index: Integer); -var - Elem: TJclSimpleXMLElem; - NamedIndex: Integer; -begin - if (FElems <> nil) and (Index >= 0) and (Index < FElems.Count) then - begin - Elem := TJclSimpleXMLElem(FElems.SimpleItems[Index]); - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Elem.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Elem); - end; - FElems.Delete(Index); - end; -end; - -procedure TJclSimpleXMLElems.Delete(const Name: string); -begin - if FElems <> nil then - Delete(FElems.IndexOfName(Name)); -end; - -destructor TJclSimpleXMLElems.Destroy; -begin - FParent := nil; - Clear; - FreeAndNil(FElems); - FreeAndNil(FNamedElems); - inherited Destroy; -end; - -procedure TJclSimpleXMLElems.DoItemRename(Value: TJclSimpleXMLElem; const Name: string); -var - NamedIndex: Integer; -begin - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); - - NamedIndex := FNamedElems.IndexOfName(Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; -end; - -function TJclSimpleXMLElems.FloatValue(const Name: string; - const Default: Extended): Extended; -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamedDefault(Name, FloatToStr(Default)); - if Elem = nil then - Result := Default - else - Result := Elem.FloatValue; -end; - -function TJclSimpleXMLElems.GetCount: Integer; -begin - if FElems = nil then - Result := 0 - else - Result := FElems.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLElems.GetEnumerator: TJclSimpleXMLElemsEnumerator; -begin - Result := TJclSimpleXMLElemsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLElems.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - if (FElems = nil) or (Index > FElems.Count) then - Result := nil - else - Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); -end; - -function TJclSimpleXMLElems.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; -var - I: Integer; -begin - Result := nil; - if FElems <> nil then - begin - I := FElems.IndexOfName(Name); - if I <> -1 then - Result := TJclSimpleXMLElem(FElems.SimpleItems[I]) - else - if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then - Result := Add(Name, Default); - end - else - if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then - Result := Add(Name, Default); -end; - -function TJclSimpleXMLElems.GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; -var - NamedIndex: Integer; - CaseSensitive: Boolean; -begin - if FNamedElems = nil then - begin - CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) - and (sxoCaseSensitive in Parent.SimpleXML.Options); - FNamedElems := TJclSimpleItemHashedList.Create(CaseSensitive); - end; - NamedIndex := FNamedElems.IndexOfName(Name); - if NamedIndex = -1 then - begin - Result := TJclSimpleXMLNamedElems.Create(Self, Name); - FNamedElems.Add(Result); - if FElems <> nil then - for NamedIndex := 0 to FElems.Count - 1 do - if FElems.SimpleItems[NamedIndex].Name = Name then - Result.FItems.Add(FElems.SimpleItems[NamedIndex]); - end - else - Result := TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]); -end; - -function TJclSimpleXMLElems.GetItemNamed(const Name: string): TJclSimpleXMLElem; -begin - Result := GetItemNamedDefault(Name, ''); -end; - -function TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64; -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamedDefault(Name, IntToStr(Default)); - if Elem = nil then - Result := Default - else - Result := Elem.IntValue; -end; - -procedure TJclSimpleXMLElems.LoadFromStringStream(StringStream: TJclStringStream); -type - TReadStatus = (rsWaitingTag, rsReadingTagKind); -var - lPos: TReadStatus; - St: TUCS4Array; - lElem: TJclSimpleXMLElem; - Ch: UCS4; - ContainsText, ContainsWhiteSpace, KeepWhiteSpace: Boolean; - SimpleXML: TJclSimpleXML; -begin - SetLength(St, 0); - lPos := rsWaitingTag; - SimpleXML := Parent.SimpleXML; - KeepWhiteSpace := (SimpleXML <> nil) and (sxoKeepWhitespace in SimpleXML.Options); - ContainsText := False; - ContainsWhiteSpace := False; - - // We read from a stream, thus replacing the existing items - Clear; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - rsWaitingTag: //We are waiting for a tag and thus avoiding spaces - begin - if Ch = Ord('<') then - begin - lPos := rsReadingTagKind; - St := UCS4Array(Ch); - end - else - if UnicodeIsWhiteSpace(Ch) then - ContainsWhiteSpace := True - else - ContainsText := True; - end; - - rsReadingTagKind: //We are trying to determine the kind of the tag - begin - lElem := nil; - case Ch of - Ord('/'): - if UCS4ArrayEquals(St, '<') then - begin // "'), Ord(':'): //This should be a classic tag - begin // " - lElem := TJclSimpleXMLElemClassic.Create; - SetLength(St, 0); - lPos := rsWaitingTag; - end; - else - if ContainsText or (ContainsWhiteSpace and KeepWhiteSpace) then - begin - // inner text - lElem := TJclSimpleXMLElemText.Create; - lPos := rsReadingTagKind; - ContainsText := False; - ContainsWhiteSpace := False; - end - else - begin - if not UCS4ArrayEquals(St, ' nil then - begin - CreateElems; - Notify(lElem, opInsert); - lElem.LoadFromStringStream(StringStream); - FElems.Add(lElem); - end; - end; - end; - end; -end; - -procedure TJclSimpleXMLElems.Notify(Value: TJclSimpleXMLElem; Operation: TOperation); -var - NamedIndex: Integer; -begin - case Operation of - opRemove: - if Value.Parent = Parent then // Only remove if we have it - begin - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); - end; - FElems.Remove(Value); - Value.FParent := nil; - Value.FSimpleXML := nil; - end; - opInsert: - begin - Value.FParent := Parent; - Value.FSimpleXML := Parent.SimpleXML; - end; - end; -end; - -function TJclSimpleXMLElems.Remove(Value: TJclSimpleXMLElem): Integer; -begin - if FElems = nil - then Result := -1 // like TList.IndexOf(alien) - else begin - Result := FElems.IndexOfSimpleItem(Value); - Notify(Value, opRemove); - end; -end; - -procedure TJclSimpleXMLElems.SaveToStringStream(StringStream: TJclStringStream; - const Level: string); -var - I: Integer; -begin - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream, Level); -end; - -function TJclSimpleXMLElems.SimpleCompare(Elems: TJclSimpleXMLElems; Index1, - Index2: Integer): Integer; -begin - Result := CompareText(Elems.Item[Index1].Name, Elems.Item[Index2].Name); -end; - -function TJclSimpleXMLElems.Value(const Name, Default: string): string; -var - Elem: TJclSimpleXMLElem; -begin - Result := ''; - Elem := GetItemNamedDefault(Name, Default); - if Elem = nil then - Result := Default - else - Result := Elem.Value; -end; - -procedure TJclSimpleXMLElems.Move(const CurIndex, NewIndex: Integer); -begin - if FElems <> nil then - FElems.Move(CurIndex, NewIndex); -end; - -function TJclSimpleXMLElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; -begin - if FElems = nil then - Result := -1 - else - Result := FElems.IndexOfSimpleItem(Value); -end; - -function TJclSimpleXMLElems.IndexOf(const Name: string): Integer; -begin - if FElems = nil then - Result := -1 - else - Result := FElems.IndexOfName(Name); -end; - -procedure TJclSimpleXMLElems.InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Insert(Index, Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; - - Notify(Value, opInsert); -end; - -function TJclSimpleXMLElems.Insert(Value: TJclSimpleXMLElem; - Index: Integer): TJclSimpleXMLElem; -begin - if Value <> nil then - InsertChild(Value, Index); - Result := Value; -end; - -function TJclSimpleXMLElems.Insert(const Name: string; - Index: Integer): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - InsertChild(Result, Index); -end; - -procedure QuickSort(Elems: TJclSimpleXMLElems; List: TList; L, R: Integer; - AFunction: TJclSimpleXMLElemCompare); -var - I, J, M: Integer; -begin - repeat - I := L; - J := R; - M := (L + R) shr 1; - repeat - while AFunction(Elems, I, M) < 0 do - Inc(I); - while AFunction(Elems, J, M) > 0 do - Dec(J); - if I < J then - begin - List.Exchange(I, J); - Inc(I); - Dec(J); - end - else - if I = J then - begin - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(Elems, List, L, J, AFunction); - L := I; - until I >= R; -end; - -procedure TJclSimpleXMLElems.CustomSort(AFunction: TJclSimpleXMLElemCompare); -begin - if FElems <> nil then - QuickSort(Self, FElems, 0, FElems.Count - 1, AFunction); -end; - -procedure TJclSimpleXMLElems.Sort; -begin - CustomSort(SimpleCompare); -end; - -//=== { TJclSimpleXMLPropsEnumerator } ======================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLPropsEnumerator.Create(AList: TJclSimpleXMLProps); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLPropsEnumerator.GetCurrent: TJclSimpleXMLProp; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLPropsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLProps } ================================================= - -function TJclSimpleXMLProps.Add(const Name, Value: string): TJclSimpleXMLProp; -begin - if FProperties = nil then - FProperties := TStringList.Create; - Result := TJclSimpleXMLProp.Create(Parent, Name, Value); - FProperties.AddObject(Name, Result); -end; - -function TJclSimpleXMLProps.Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; -begin - Result := Add(Name, IntToStr(Value)); -end; - -function TJclSimpleXMLProps.Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; -begin - Result := Add(Name, BoolToStr(Value)); -end; - -{$IFDEF SUPPORTS_UNICODE} -function TJclSimpleXMLProps.Add(const Name: string; - const Value: AnsiString): TJclSimpleXMLProp; -begin - Result := Add(Name, string(Value)); -end; -{$ENDIF SUPPORTS_UNICODE} - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; -begin - if FProperties = nil then - FProperties := TStringList.Create; - Result := TJclSimpleXMLProp.Create(Parent, Name, Value); - FProperties.InsertObject(Index, Name, Result); -end; - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; -begin - Result := Insert(Index, Name, IntToStr(Value)); -end; - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; -begin - Result := Insert(Index, Name, BoolToStr(Value)); -end; - -function TJclSimpleXMLProps.BoolValue(const Name: string; Default: Boolean): Boolean; -var - Prop: TJclSimpleXMLProp; -begin - try - Prop := GetItemNamedDefault(Name, BoolToStr(Default)); - if (Prop = nil) or (Prop.Value = '') then - Result := Default - else - Result := Prop.BoolValue; - except - Result := Default; - end; -end; - -procedure TJclSimpleXMLProps.Clear; -var - I: Integer; -begin - if FProperties <> nil then - begin - for I := 0 to FProperties.Count - 1 do - begin - TJclSimpleXMLProp(FProperties.Objects[I]).Free; - FProperties.Objects[I] := nil; - end; - FProperties.Clear; - end; -end; - -procedure TJclSimpleXMLProps.Delete(const Index: Integer); -begin - if (FProperties <> nil) and (Index >= 0) and (Index < FProperties.Count) then - begin - TObject(FProperties.Objects[Index]).Free; - FProperties.Delete(Index); - end; -end; - -constructor TJclSimpleXMLProps.Create(AParent: TJclSimpleXMLElem); -begin - inherited Create; - FParent := AParent; -end; - -procedure TJclSimpleXMLProps.Delete(const Name: string); -begin - if FProperties <> nil then - Delete(FProperties.IndexOf(Name)); -end; - -destructor TJclSimpleXMLProps.Destroy; -begin - FParent := nil; - Clear; - FreeAndNil(FProperties); - inherited Destroy; -end; - -procedure TJclSimpleXMLProps.DoItemRename(Value: TJclSimpleXMLProp; const Name: string); -var - I: Integer; -begin - if FProperties = nil then - Exit; - I := FProperties.IndexOfObject(Value); - if I <> -1 then - FProperties[I] := Name; -end; - -procedure TJclSimpleXMLProps.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -function TJclSimpleXMLProps.FloatValue(const Name: string; - const Default: Extended): Extended; -var - Prop: TJclSimpleXMLProp; -begin - Prop := GetItemNamedDefault(Name, FloatToStr(Default)); - if Prop = nil then - Result := Default - else - Result := Prop.FloatValue; -end; - -procedure TJclSimpleXMLProps.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -function TJclSimpleXMLProps.GetCount: Integer; -begin - if FProperties = nil then - Result := 0 - else - Result := FProperties.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLProps.GetEnumerator: TJclSimpleXMLPropsEnumerator; -begin - Result := TJclSimpleXMLPropsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLProps.GetItem(const Index: Integer): TJclSimpleXMLProp; -begin - if FProperties <> nil then - Result := TJclSimpleXMLProp(FProperties.Objects[Index]) - else - Result := nil; -end; - -function TJclSimpleXMLProps.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; -var - I: Integer; -begin - Result := nil; - if FProperties <> nil then - begin - I := FProperties.IndexOf(Name); - if I <> -1 then - Result := TJclSimpleXMLProp(FProperties.Objects[I]) - else - if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then - Result := Add(Name, Default); - end - else - if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then - begin - Result := Add(Name, Default); - end; -end; - -function TJclSimpleXMLProps.GetItemNamed(const Name: string): TJclSimpleXMLProp; -begin - Result := GetItemNamedDefault(Name, ''); -end; - -function TJclSimpleXMLProps.GetSimpleXML: TJclSimpleXML; -begin - if FParent <> nil then - Result := FParent.SimpleXML - else - Result := nil; -end; - -function TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64; -var - Prop: TJclSimpleXMLProp; -begin - Prop := GetItemNamedDefault(Name, IntToStr(Default)); - if Prop = nil then - Result := Default - else - Result := Prop.IntValue; -end; - -procedure TJclSimpleXMLProps.LoadFromStringStream(StringStream: TJclStringStream); -// -//Stop on / or ? or > -type - TPosType = ( - ptWaiting, - ptReadingName, - ptStartingContent, - ptReadingValue, - ptSpaceBeforeEqual - ); -var - lPos: TPosType; - lName, lValue, lNameSpace: TUCS4Array; - sValue: string; - lPropStart: UCS4; - Ch: UCS4; -begin - SetLength(lValue, 0); - SetLength(lNameSpace, 0); - SetLength(lName, 0); - lPropStart := Ord(NativeSpace); - lPos := ptWaiting; - - // We read from a stream, thus replacing the existing properties - Clear; - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - ptWaiting: //We are waiting for a property - begin - if UnicodeIsWhiteSpace(Ch) then - StringStream.ReadUCS4(Ch) - else - if UnicodeIsIdentifierStart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord('_')) then - begin - StringStream.ReadUCS4(Ch); - lName := UCS4Array(Ch); - SetLength(lNameSpace, 0); - lPos := ptReadingName; - end - else - if (Ch = Ord('/')) or (Ch = Ord('>')) or (Ch = Ord('?')) then - // end of properties - Break - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptReadingName: //We are reading a property name - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - begin - UCS4ArrayConcat(lName, Ch); - end - else - if Ch = Ord(':') then - begin - lNameSpace := lName; - SetLength(lName, 0); - end - else - if Ch = Ord('=') then - lPos := ptStartingContent - else - if UnicodeIsWhiteSpace(Ch) then - lPos := ptSpaceBeforeEqual - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptStartingContent: //We are going to start a property content - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsWhiteSpace(Ch) then - // ignore white space - else - if (Ch = Ord('''')) or (Ch = Ord('"')) then - begin - lPropStart := Ch; - SetLength(lValue, 0); - lPos := ptReadingValue; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte_), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptReadingValue: //We are reading a property - begin - StringStream.ReadUCS4(Ch); - if Ch = lPropStart then - begin - sValue := UCS4ToString(lValue); - if GetSimpleXML <> nil then - GetSimpleXML.DoDecodeValue(sValue); - with Add(UCS4ToString(lName), sValue) do - NameSpace := UCS4ToString(lNameSpace); - lPos := ptWaiting; - end - else - UCS4ArrayConcat(lValue, Ch); - end; - - ptSpaceBeforeEqual: // We are reading the white space between a property name and the = sign - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsWhiteSpace(Ch) then - // more white space, stay in this state and ignore - else - if Ch = Ord('=') then - lPos := ptStartingContent - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - else - Assert(False, RsEUnexpectedValueForLPos); - end; - end; -end; - -procedure TJclSimpleXMLProps.SaveToStringStream(StringStream: TJclStringStream); -var - I: Integer; -begin - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream); -end; - -function TJclSimpleXMLProps.Value(const Name, Default: string): string; -var - Prop: TJclSimpleXMLProp; -begin - Result := ''; - Prop := GetItemNamedDefault(Name, Default); - if Prop = nil then - Result := Default - else - Result := Prop.Value; -end; - -//=== { TJclSimpleXMLProp } ================================================== - -constructor TJclSimpleXMLProp.Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); -begin - inherited Create(AName, AValue); - FParent := AParent; -end; - -function TJclSimpleXMLProp.GetSimpleXML: TJclSimpleXML; -begin - if FParent <> nil then - Result := FParent.SimpleXML - else - Result := nil; -end; - -procedure TJclSimpleXMLProp.SaveToStringStream(StringStream: TJclStringStream); -var - AEncoder: TJclSimpleXML; - Tmp: string; -begin - AEncoder := GetSimpleXML; - Tmp := Value; - if AEncoder <> nil then - AEncoder.DoEncodeValue(Tmp); - if NameSpace <> '' then - Tmp := Format(' %s:%s="%s"', [NameSpace, Name, Tmp]) - else - Tmp := Format(' %s="%s"', [Name, tmp]); - StringStream.WriteString(Tmp, 1, Length(Tmp)); -end; - -procedure TJclSimpleXMLProp.SetName(const Value: string); -begin - if (Value <> Name) and (Value <> '') then - begin - if (Parent <> nil) and (Name <> '') then - FParent.Properties.DoItemRename(Self, Value); - inherited SetName(Value); - end; -end; - -//=== { TJclSimpleXMLElemClassic } =========================================== - -procedure TJclSimpleXMLElemClassic.LoadFromStringStream(StringStream: TJclStringStream); -// -//foorbeuhbar -//foorbeuhbar -type - TReadStatus = (rsWaitingOpeningTag, rsOpeningName, rsTypeOpeningTag, rsEndSingleTag, - rsWaitingClosingTag1, rsWaitingClosingTag2, rsClosingName); -var - lPos: TReadStatus; - St, lName, lNameSpace: TUCS4Array; - sValue: string; - Ch: UCS4; -begin - SetLength(St, 0); - SetLength(lName, 0); - SetLength(lNameSpace, 0); - sValue := ''; - lPos := rsWaitingOpeningTag; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - rsWaitingOpeningTag: // wait beginning of tag - if Ch = Ord('<') then - lPos := rsOpeningName // read name - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsOpeningName: - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - UCS4ArrayConcat(St, Ch) - else - if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then - begin - lNameSpace := St; - SetLength(st, 0); - end - else - if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then - // whitespace after "<" (no name) - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) - else - if UnicodeIsWhiteSpace(Ch) then - begin - lName := St; - SetLength(St, 0); - Properties.LoadFromStringStream(StringStream); - lPos := rsTypeOpeningTag; - end - else - if Ch = Ord('/') then // single tag - begin - lName := St; - lPos := rsEndSingleTag - end - else - if Ch = Ord('>') then // 2 tags - begin - lName := St; - SetLength(St, 0); - //Load elements - Items.LoadFromStringStream(StringStream); - lPos := rsWaitingClosingTag1; - end - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsTypeOpeningTag: - if UnicodeIsWhiteSpace(Ch) then - // nothing, spaces after name or properties - else - if Ch = Ord('/') then - lPos := rsEndSingleTag // single tag - else - if Ch = Ord('>') then // 2 tags - begin - //Load elements - Items.LoadFromStringStream(StringStream); - lPos := rsWaitingClosingTag1; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsEndSingleTag: - if Ch = Ord('>') then - Break - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsWaitingClosingTag1: - if UnicodeIsWhiteSpace(Ch) then - // nothing, spaces before closing tag - else - if Ch = Ord('<') then - lPos := rsWaitingClosingTag2 - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsWaitingClosingTag2: - if Ch = Ord('/') then - lPos := rsClosingName - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsClosingName: - if UnicodeIsWhiteSpace(Ch) or (Ch = Ord('>')) then - begin - if Length(lNameSpace) > 0 then - begin - if not StrSame(UCS4ToString(lNameSpace) + ':' + UCS4ToString(lName), UCS4ToString(St)) then - FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); - end - else - if not UCS4ArrayEquals(lName, St) then - FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); - //Set value if only one sub element - //This might reduce speed, but this is for compatibility issues - if (Items.Count = 1) and (Items[0] is TJclSimpleXMLElemText) then - begin - sValue := Items[0].Value; - Items.Clear; - // free some memory - FreeAndNil(FItems); - end; - Break; - end - else - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord(':')) then - UCS4ArrayConcat(St, Ch) - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - end; - end; - - Name := UCS4ToString(lName); - if SimpleXML <> nil then - SimpleXML.DoDecodeValue(sValue); - Value := sValue; - NameSpace := UCS4ToString(lNameSpace); - - if SimpleXML <> nil then - begin - SimpleXML.DoTagParsed(Name); - SimpleXML.DoValueParsed(Name, sValue); - end; -end; - -procedure TJclSimpleXMLElemClassic.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St, AName, tmp: string; - LevelAdd: string; - AutoIndent: Boolean; -begin - if(NameSpace <> '') then - AName := NameSpace + ':' + Name - else - AName := Name; - - if Name <> '' then - begin - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(AName); - St := Level + '<' + AName; - - StringStream.WriteString(St, 1, Length(St)); - if Assigned(FProps) then - FProps.SaveToStringStream(StringStream); - end; - - AutoIndent := (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options); - - if (ItemCount = 0) then - begin - tmp := Value; - if (Name <> '') then - begin - if Value = '' then - begin - if AutoIndent then - St := '/>' + sLineBreak - else - St := '/>'; - end - else - begin - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(tmp); - if AutoIndent then - St := '>' + tmp + '' + sLineBreak - else - St := '>' + tmp + ''; - end; - StringStream.WriteString(St, 1, Length(St)); - end; - end - else - begin - if (Name <> '') then - begin - if AutoIndent then - St := '>' + sLineBreak - else - St := '>'; - StringStream.WriteString(St, 1, Length(St)); - end; - if AutoIndent then - begin - LevelAdd := SimpleXML.IndentString; - end; - FItems.SaveToStringStream(StringStream, Level + LevelAdd); - if Name <> '' then - begin - if AutoIndent then - St := Level + '' + sLineBreak - else - St := Level + ''; - StringStream.WriteString(St, 1, Length(St)); - end; - end; - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemComment } =========================================== - -procedure TJclSimpleXMLElemComment.LoadFromStringStream(StringStream: TJclStringStream); -// -const - CS_START_COMMENT = ''; -var - lPos: Integer; - St: TUCS4Array; - Ch: UCS4; - lOk: Boolean; -begin - SetLength(St, 0); - lPos := 1; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..4: //' + sLineBreak - else - St := '-->'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemCData } ============================================= - -procedure TJclSimpleXMLElemCData.LoadFromStringStream(StringStream: TJclStringStream); -//Hello, world!]]> -const - CS_START_CDATA = ''; -var - lPos: Integer; - St: TUCS4Array; - Ch: UCS4; - lOk: Boolean; -begin - SetLength(St, 0); - lPos := 1; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..9: // - if Ch = Ord(CS_STOP_CDATA[lPos]) then - begin - lOk := True; - Break; //End if - end - else - // ]]] - if Ch = Ord(CS_STOP_CDATA[lPos-1]) then - UCS4ArrayConcat(St, Ord(']')) - else - begin - UCS4ArrayConcat(St, Ord(']')); - UCS4ArrayConcat(St, Ord(']')); - UCS4ArrayConcat(St, Ch); - Dec(lPos, 2); - end; - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCDATAUnexpectedEndOfData), [StringStream.PeekPosition]); - - Value := UCS4ToString(St); - Name := ''; - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', Value); -end; - -procedure TJclSimpleXMLElemCData.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St: string; -begin - St := Level + ' '' then - StringStream.WriteString(Value, 1, Length(Value)); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := ']]>' + sLineBreak - else - St := ']]>'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemText } ============================================== - -procedure TJclSimpleXMLElemText.LoadFromStringStream(StringStream: TJclStringStream); -var - Ch: UCS4; - USt: TUCS4Array; - St, TrimValue: string; -begin - SetLength(USt, 0); - St := ''; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case Ch of - Ord('<'): - //Quit text - Break; - else - begin - StringStream.ReadUCS4(Ch); - UCS4ArrayConcat(USt, Ch); - end; - end; - end; - - St := UCS4ToString(USt); - - if Assigned(SimpleXML) then - begin - SimpleXML.DoDecodeValue(St); - - TrimValue := St; - if sxoTrimPrecedingTextWhitespace in SimpleXML.Options then - TrimValue := TrimLeft(TrimValue); - if sxoTrimFollowingTextWhitespace in SimpleXML.Options then - TrimValue := TrimRight(TrimValue); - if (TrimValue <> '') or not (sxoKeepWhitespace in SimpleXML.Options) then - St := TrimValue; - end; - - Value := St; - Name := ''; - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', St); -end; - -procedure TJclSimpleXMLElemText.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St, tmp: string; -begin - // should never be used - if Value <> '' then - begin - tmp := Value; - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(tmp); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := Level + tmp + sLineBreak - else - St := Level + tmp; - StringStream.WriteString(St, 1, Length(St)); - end; - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemProcessingInstruction } ============================= - -procedure TJclSimpleXMLElemProcessingInstruction.LoadFromStringStream( - StringStream: TJclStringStream); -type - TReadStatus = (rsWaitingOpeningTag, rsOpeningTag, rsOpeningName, rsEndTag1, rsEndTag2); -var - lPos: TReadStatus; - lOk: Boolean; - St, lName, lNameSpace: TUCS4Array; - Ch: UCS4; -begin - SetLength(St, 0); - SetLength(lName, 0); - SetLength(lNameSpace, 0); - lPos := rsWaitingOpeningTag; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - rsWaitingOpeningTag: // wait beginning of tag - if Ch = Ord('<') then - lPos := rsOpeningTag - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsOpeningTag: - if Ch = Ord('?') then - lPos := rsOpeningName // read name - else - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsOpeningName: - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - UCS4ArrayConcat(St, Ch) - else - if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then - begin - lNameSpace := St; - SetLength(St, 0); - end - else - if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then - // whitespace after "<" (no name) - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) - else - if UnicodeIsWhiteSpace(Ch) then - begin - lName := St; - SetLength(St, 0); - Properties.LoadFromStringStream(StringStream); - lPos := rsEndTag1; - end - else - if Ch = Ord('?') then - begin - lName := St; - lPos := rsEndTag2; - end - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsEndTag1: - if Ch = Ord('?') then - lPos := rsEndTag2 - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsEndTag2: - if Ch = Ord('>') then - begin - lOk := True; - Break; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); - - Name := UCS4ToString(lName); - NameSpace := UCS4ToString(lNameSpace); -end; - -procedure TJclSimpleXMLElemProcessingInstruction.SaveToStringStream( - StringStream: TJclStringStream; const Level: string); -var - St: string; -begin - St := Level + ' '' then - St := St + NameSpace + ':' + Name - else - St := St + Name; - StringStream.WriteString(St, 1, Length(St)); - if Assigned(FProps) then - FProps.SaveToStringStream(StringStream); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := '?>' + sLineBreak - else - St := '?>'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemHeader } ============================================ - -constructor TJclSimpleXMLElemHeader.Create; -begin - inherited Create; - - Name := 'xml'; -end; - -function TJclSimpleXMLElemHeader.GetEncoding: string; -var - ASimpleXML: TJclSimpleXML; - DefaultCodePage: Word; -begin - ASimpleXML := SimpleXML; - if Assigned(ASimpleXML) then - begin - DefaultCodePage := ASimpleXML.CodePage; - {$IFDEF MSWINDOWS} - if DefaultCodePage = CP_ACP then - DefaultCodePage := GetAcp; - {$ENDIF MSWINDOWS} - end - else - {$IFDEF UNICODE} - DefaultCodePage := CP_UTF16LE; - {$ELSE ~UNICODE} - {$IFDEF MSWINDOWS} - DefaultCodePage := GetACP; - {$ELSE ~MSWINDOWS} - DefaultCodePage := 1252; - {$ENDIF ~MSWINDOWS} - {$ENDIF ~UNICODE} - Result := Properties.Value('encoding', CharsetNameFromCodePage(DefaultCodePage)); -end; - -function TJclSimpleXMLElemHeader.GetStandalone: Boolean; -begin - Result := Properties.Value('standalone') = 'yes'; -end; - -function TJclSimpleXMLElemHeader.GetVersion: string; -begin - Result := Properties.Value('version', '1.0'); -end; - -procedure TJclSimpleXMLElemHeader.LoadFromStringStream(StringStream: TJclStringStream); -// -var - CodePage: Word; - EncodingProp: TJclSimpleXMLProp; -begin - inherited LoadFromStringStream(StringStream); - - if Assigned(FProps) then - EncodingProp := FProps.ItemNamed['encoding'] - else - EncodingProp := nil; - if Assigned(EncodingProp) and (EncodingProp.Value <> '') then - CodePage := CodePageFromCharsetName(EncodingProp.Value) - else - CodePage := CP_ACP; - - // set current stringstream codepage - if StringStream is TJclAutoStream then - TJclAutoStream(StringStream).CodePage := CodePage - else - if StringStream is TJclAnsiStream then - TJclAnsiStream(StringStream).CodePage := CodePage - else - if not (StringStream is TJclUTF8Stream) and not (StringStream is TJclUTF16Stream) then - Error(LoadResString(@RsENoCharset)); -end; - -procedure TJclSimpleXMLElemHeader.SaveToStringStream( - StringStream: TJclStringStream; const Level: string); -begin - SetVersion(GetVersion); - SetEncoding(GetEncoding); - SetStandalone(GetStandalone); - - inherited SaveToStringStream(StringStream, Level); -end; - -procedure TJclSimpleXMLElemHeader.SetEncoding(const Value: string); -var - Prop: TJclSimpleXMLProp; -begin - Prop := Properties.ItemNamed['encoding']; - if Assigned(Prop) then - Prop.Value := Value - else - Properties.Add('encoding', Value); -end; - -procedure TJclSimpleXMLElemHeader.SetStandalone(const Value: Boolean); -var - Prop: TJclSimpleXMLProp; -const - BooleanValues: array [Boolean] of string = ('no', 'yes'); -begin - Prop := Properties.ItemNamed['standalone']; - if Assigned(Prop) then - Prop.Value := BooleanValues[Value] - else - Properties.Add('standalone', BooleanValues[Value]); -end; - -procedure TJclSimpleXMLElemHeader.SetVersion(const Value: string); -var - Prop: TJclSimpleXMLProp; -begin - Prop := Properties.ItemNamed['version']; - if Assigned(Prop) then - Prop.Value := Value - else - // Various XML parsers (including MSIE, Firefox) require the "version" to be the first - Properties.Insert(0, 'version', Value); -end; - -//=== { TJclSimpleXMLElemDocType } =========================================== - -procedure TJclSimpleXMLElemDocType.LoadFromStringStream(StringStream: TJclStringStream); -{ - - -' > -%xx; -]> - - -} -const - CS_START_DOCTYPE = ''); - SetLength(St, 0); - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..9: // or > - if lChar = Ch then - begin - if lChar = Ord('>') then - begin - lOk := True; - Break; //This is the end - end - else - begin - UCS4ArrayConcat(St, Ch); - lChar := Ord('>'); - end; - end - else - begin - UCS4ArrayConcat(St, Ch); - if Ch = Ord('[') then - lChar := Ord(']'); - end; - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); - - Name := ''; - Value := StrTrimCharsLeft(UCS4ToString(St), CharIsWhiteSpace); - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', Value); -end; - -procedure TJclSimpleXMLElemDocType.SaveToStringStream(StringStream: TJclStringStream; - const Level: string); -var - St: string; -begin - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := Level + '' + sLineBreak - else - St := Level + ''; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemsPrologEnumerator } ================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLElemsPrologEnumerator.Create(AList: TJclSimpleXMLElemsProlog); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLElemsPrologEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLElemsPrologEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLElemsProlog } =========================================== - -constructor TJclSimpleXMLElemsProlog.Create(ASimpleXML: TJclSimpleXML); -var - CaseSensitive: Boolean; -begin - inherited Create; - FSimpleXML := ASimpleXML; - CaseSensitive := Assigned(ASimpleXML) and (sxoCaseSensitive in ASimpleXML.Options); - FElems := TJclSimpleItemHashedList.Create(CaseSensitive); -end; - -destructor TJclSimpleXMLElemsProlog.Destroy; -begin - Clear; - FreeAndNil(FElems); - inherited Destroy; -end; - -procedure TJclSimpleXMLElemsProlog.Clear; -begin - FElems.Clear; -end; - -function TJclSimpleXMLElemsProlog.GetCount: Integer; -begin - Result := FElems.Count; -end; - -function TJclSimpleXMLElemsProlog.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); -end; - -procedure TJclSimpleXMLElemsProlog.LoadFromStringStream(StringStream: TJclStringStream); -{ - - -]> -Hello, world! - - Hello, world! -} -var - lPos: Integer; - St: TUCS4Array; - lEnd: Boolean; - lElem: TJclSimpleXMLElem; - Ch: UCS4; -begin - SetLength(St, 0); - lPos := 0; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - 0: //We are waiting for a tag and thus avoiding spaces and any BOM - begin - if UnicodeIsWhiteSpace(Ch) then - // still waiting - else - if Ch = Ord('<') then - begin - lPos := 1; - St := UCS4Array(Ch); - end - else - FmtError(LoadResString(@RsEInvalidDocumentUnexpectedTextInFile), [StringStream.PeekPosition]); - end; - 1: //We are trying to determine the kind of the tag - begin - lElem := nil; - lEnd := False; - - if not UCS4ArrayEquals(St, ' 3) and (St[1] = Ord('?')) and UnicodeIsWhiteSpace(St[High(St)]) then - lElem := TJclSimpleXMLElemProcessingInstruction.Create(SimpleXML) - else - if (Length(St) > 1) and (St[1] <> Ord('!')) and (St[1] <> Ord('?')) then - lEnd := True; - - if lEnd then - Break - else - if lElem <> nil then - begin - FElems.Add(lElem); - lElem.LoadFromStringStream(StringStream); - SetLength(St, 0); - lPos := 0; - end; - end; - end; - end; -end; - -procedure TJclSimpleXMLElemsProlog.SaveToStringStream(StringStream: TJclStringStream); -var - I: Integer; -begin - FindHeader; - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream, ''); -end; - -function VarXML: TVarType; -begin - Result := XMLVariant.VarType; -end; - -procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); -begin - TVarData(ADest).vType := VarXML; - TVarData(ADest).vAny := AXML; -end; - -function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; -begin - XMLCreateInto(Result, AXML); -end; - -function XMLCreate: Variant; -begin - XMLCreateInto(Result, TJclSimpleXMLElemClassic.Create(nil)); -end; - -//=== { TXMLVariant } ======================================================== - -procedure TXMLVariant.CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); -var - StorageStream: TStringStream; - ConversionString: TJclStringStream; -begin - if Source.vType = VarType then - begin - case AVarType of - varOleStr: - begin - StorageStream := TStringStream.Create(''); - try - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataFromOleStr(Dest, StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - varString: - begin - StorageStream := TStringStream.Create(''); - try - {$IFDEF SUPPORTS_UNICODE} - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - {$ELSE ~SUPPORTS_UNICODE} - ConversionString := TJclAnsiStream.Create(StorageStream, False); - {$ENDIF ~SUPPORTS_UNICODE} - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataFromStr(Dest, StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - {$IFDEF SUPPORTS_UNICODE_STRING} - varUString: - begin - StorageStream := TStringStream.Create(''); - try - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataClear(Dest); - Dest.VUString := nil; - Dest.VType := varUString; - UnicodeString(Dest.VUString) := UnicodeString(StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - {$ENDIF SUPPORTS_UNICODE_STRING} - else - RaiseCastError; - end; - end - else - inherited CastTo(Dest, Source, AVarType); -end; - -procedure TXMLVariant.Clear(var V: TVarData); -begin - V.vType := varEmpty; - V.vAny := nil; -end; - -procedure TXMLVariant.Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); -begin - if Indirect and VarDataIsByRef(Source) then - VarDataCopyNoInd(Dest, Source) - else - begin - Dest.vType := Source.vType; - Dest.vAny := Source.vAny; - end; -end; - -function TXMLVariant.DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; -var - VXML, LXML: TJclSimpleXMLElem; - VElems: TJclSimpleXMLElems; - I, J, K: Integer; -begin - Result := False; - if (Length(Arguments) = 1) and (Arguments[0].vType in [vtInteger, vtExtended]) then - begin - VXML := TJclSimpleXMLElem(V.VAny); - K := Arguments[0].vInteger; - J := 0; - - if (K > 0) and VXML.HasItems then - begin - VElems := VXML.Items; - for I := 0 to VElems.Count - 1 do - if UpperCase(VElems.Item[I].Name) = Name then - begin - Inc(J); - if J = K then - Break; - end; - end; - - if (J = K) and (J < VXML.ItemCount) then - begin - LXML := VXML.Items[J]; - if LXML <> nil then - begin - Dest.vType := VarXML; - Dest.vAny := Pointer(LXML); - Result := True; - end - end; - end -end; - -function TXMLVariant.GetProperty(var Dest: TVarData; const V: TVarData; - const Name: string): Boolean; -var - VXML, LXML: TJclSimpleXMLElem; - lProp: TJclSimpleXMLProp; -begin - Result := False; - VXML := TJclSimpleXMLElem(V.VAny); - if VXML.HasItems then - begin - LXML := VXML.Items.ItemNamed[Name]; - if LXML <> nil then - begin - Dest.vType := VarXML; - Dest.vAny := Pointer(LXML); - Result := True; - end; - end; - if (not Result) and VXML.HasProperties then - begin - lProp := VXML.Properties.ItemNamed[Name]; - if lProp <> nil then - begin - VarDataFromOleStr(Dest, lProp.Value); - Result := True; - end; - end; -end; - -function TXMLVariant.IsClear(const V: TVarData): Boolean; -var - VXML: TJclSimpleXMLElem; -begin - VXML := TJclSimpleXMLElem(V.VAny); - Result := (VXML = nil) or (not VXML.HasItems); -end; - -function TXMLVariant.SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; - - function GetStrValue: string; - begin - try - Result := Value.VOleStr; - except - Result := ''; - end; - end; - -var - VXML, LXML: TJclSimpleXMLElem; - lProp: TJclSimpleXMLProp; -begin - Result := False; - VXML := TJclSimpleXMLElem(V.VAny); - if VXML.HasItems then - begin - LXML := VXML.Items.ItemNamed[Name]; - if LXML <> nil then - begin - LXML.Value := GetStrValue; - Result := True; - end; - end; - if (not Result) and VXML.HasProperties then - begin - lProp := VXML.Properties.ItemNamed[Name]; - if lProp <> nil then - begin - lProp.Value := GetStrValue; - Result := True; - end; - end; -end; - -procedure TJclSimpleXMLElemsProlog.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -procedure TJclSimpleXMLElemsProlog.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -procedure TJclSimpleXML.SetIndentString(const Value: string); -begin - // test if the new value is only made of spaces or tabs - if not StrContainsChars(Value, CharIsWhiteSpace, True) then - Exit; - FIndentString := Value; -end; - -procedure TJclSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic); -begin - if Value <> FRoot then - begin -// FRoot.FSimpleXML := nil; - FRoot := Value; -// FRoot.FSimpleXML := Self; - end; -end; - -function TJclSimpleXMLElemsProlog.GetEncoding: string; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.Encoding - else - Result := 'UTF-8'; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLElemsProlog.GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; -begin - Result := TJclSimpleXMLElemsPrologEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLElemsProlog.GetStandAlone: Boolean; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.StandAlone - else - Result := False; -end; - -function TJclSimpleXMLElemsProlog.GetVersion: string; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.Version - else - Result := '1.0'; -end; - -procedure TJclSimpleXMLElemsProlog.SetEncoding(const Value: string); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.Encoding := Value; -end; - -procedure TJclSimpleXMLElemsProlog.SetStandAlone(const Value: Boolean); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.StandAlone := Value; -end; - -procedure TJclSimpleXMLElemsProlog.SetVersion(const Value: string); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.Version := Value; -end; - -function TJclSimpleXMLElemsProlog.FindHeader: TJclSimpleXMLElem; -var - I: Integer; -begin - for I := 0 to Count - 1 do - if Item[I] is TJclSimpleXMLElemHeader then - begin - Result := Item[I]; - Exit; - end; - // (p3) if we get here, an xml header was not found - Result := TJclSimpleXMLElemHeader.Create(SimpleXML); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemSheet.Create('xml-stylesheet'); - Result.Properties.Add('type',AType); - Result.Properties.Add('href',AHRef); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemMSOApplication.Create('mso-application'); - Result.Properties.Add('progid',AProgId); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemComment.Create('', AValue); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddDocType(const AValue: string): TJclSimpleXMLElemDocType; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemDocType.Create('', AValue); - FElems.Add(Result); -end; - -initialization - {$IFDEF UNITVERSIONING} - RegisterUnitVersion(HInstance, UnitVersioning); - {$ENDIF UNITVERSIONING} - -finalization - FreeAndNil(GlobalXMLVariant); - {$IFDEF UNITVERSIONING} - UnregisterUnitVersion(HInstance); - {$ENDIF UNITVERSIONING} - -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 JvSimpleXML.PAS, released on 2002-06-03. } +{ } +{ The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]. } +{ Portions created by Sébastien Buysse are Copyright (C) 2001 Sébastien Buysse. } +{ All Rights Reserved. } +{ } +{ Contributor(s): } +{ Christophe Paris, } +{ Florent Ouchet (move from the JVCL to the JCL) } +{ Teträm } +{ } +{**************************************************************************************************} +{ } +{ This unit contains Xml parser and writter classes } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +// Known Issues: This component does not parse the !DOCTYPE tags but preserves them + +unit JclSimpleXml; + +interface + +{$I jcl.inc} + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF HAS_UNIT_RTLCONSTS} + System.RTLConsts, + {$ENDIF HAS_UNIT_RTLCONSTS} + {$IFDEF MSWINDOWS} + Winapi.Windows, // Delphi 2005 inline + {$ENDIF MSWINDOWS} + System.SysUtils, System.Classes, + System.Variants, + System.IniFiles, + System.Contnrs, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF HAS_UNIT_RTLCONSTS} + RTLConsts, + {$ENDIF HAS_UNIT_RTLCONSTS} + {$IFDEF MSWINDOWS} + Windows, // Delphi 2005 inline + {$ENDIF MSWINDOWS} + SysUtils, Classes, + Variants, + IniFiles, + Contnrs, + {$ENDIF ~HAS_UNITSCOPE} + JclBase, JclStreams; + +type + TJclSimpleItem = class(TObject) + private + FName: string; + protected + procedure SetName(const Value: string); virtual; + public + property Name: string read FName write SetName; + end; + +type + TJclSimpleItemHashedList = class(TObjectList) + private + FNameHash: TStringHash; + FCaseSensitive: Boolean; + function GetSimpleItemByName(const Name: string): TJclSimpleItem; + function GetSimpleItem(Index: Integer): TJclSimpleItem; + procedure SetCaseSensitive(const Value: Boolean); + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + public + constructor Create(ACaseSensitive: Boolean); + destructor Destroy; override; + function Add(Item: TJclSimpleItem): Integer; + procedure Clear; override; + function IndexOfSimpleItem(Item: TJclSimpleItem): Integer; + function IndexOfName(const Name: string): Integer; + procedure Insert(Index: Integer; Item: TJclSimpleItem); + procedure InvalidateHash; + procedure Move(CurIndex, NewIndex: Integer); + property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; + property SimpleItemByNames[const Name: string]: TJclSimpleItem read GetSimpleItemByName; + property SimpleItems[Index: Integer]: TJclSimpleItem read GetSimpleItem; + end; + +type + TJclSimpleData = class(TJclSimpleItem) + private + FValue: string; + FData: Pointer; + protected + function GetBoolValue: Boolean; + procedure SetBoolValue(const Value: Boolean); + function GetFloatValue: Extended; + procedure SetFloatValue(const Value: Extended); + function GetAnsiValue: AnsiString; + procedure SetAnsiValue(const Value: AnsiString); + function GetIntValue: Int64; + procedure SetIntValue(const Value: Int64); + public + constructor Create; overload; virtual; + constructor Create(const AName: string); overload; + constructor Create(const AName, AValue: string); overload; + property Value: string read FValue write FValue; + property AnsiValue: AnsiString read GetAnsiValue write SetAnsiValue; + property IntValue: Int64 read GetIntValue write SetIntValue; + property BoolValue: Boolean read GetBoolValue write SetBoolValue; + property FloatValue: Extended read GetFloatValue write SetFloatValue; + + property Data: Pointer read FData write FData; + end; + +type + TJclSimpleXMLData = class(TJclSimpleData) + private + FNameSpace: string; + public + function FullName:string; + property NameSpace: string read FNameSpace write FNameSpace; + end; + +type + TJclSimpleXML = class; + EJclSimpleXMLError = class(EJclError); + {$TYPEINFO ON} // generate RTTI for published properties + TJclSimpleXMLElem = class; + {$IFNDEF TYPEINFO_ON} + {$TYPEINFO OFF} + {$ENDIF ~TYPEINFO_ON} + TJclSimpleXMLElems = class; + TJclSimpleXMLProps = class; + TJclSimpleXMLElemsProlog = class; + TJclSimpleXMLNamedElems = class; + TJclSimpleXMLElemComment = class; + TJclSimpleXMLElemClassic = class; + TJclSimpleXMLElemCData = class; + TJclSimpleXMLElemDocType = class; + TJclSimpleXMLElemText = class; + TJclSimpleXMLElemHeader = class; + TJclSimpleXMLElemSheet = class; + TJclSimpleXMLElemMSOApplication = class; + TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object; + TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object; + TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; + + //Those hash stuffs are for future use only + //Plans are to replace current hash by this mechanism + TJclHashKind = (hkList, hkDirect); + PJclHashElem = ^TJclHashElem; + TJclHashElem = packed record + Next: PJclHashElem; + Obj: TObject; + end; + PJclHashRecord = ^TJclHashRecord; + TJclHashList = array [0..25] of PJclHashRecord; + PJclHashList = ^TJclHashList; + TJclHashRecord = packed record + Count: Byte; + case Kind: TJclHashKind of + hkList: (List: PJclHashList); + hkDirect: (FirstElem: PJclHashElem); + end; + + TJclSimpleXMLProp = class(TJclSimpleXMLData) + private + FParent: TJclSimpleXMLElem; + protected + function GetSimpleXML: TJclSimpleXML; + procedure SetName(const Value: string); override; + public + constructor Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); + procedure SaveToStringStream(StringStream: TJclStringStream); + property Parent: TJclSimpleXMLElem read FParent; + property SimpleXML: TJclSimpleXML read GetSimpleXML; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLPropsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLProps; + public + constructor Create(AList: TJclSimpleXMLProps); + function GetCurrent: TJclSimpleXMLProp; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLProp read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLProps = class(TObject) + private + FProperties: TStringList; + FParent: TJclSimpleXMLElem; + function GetCount: Integer; + function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; + function GetItemNamed(const Name: string): TJclSimpleXMLProp; + protected + function GetSimpleXML: TJclSimpleXML; + function GetItem(const Index: Integer): TJclSimpleXMLProp; + procedure DoItemRename(Value: TJclSimpleXMLProp; const Name: string); + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + constructor Create(AParent: TJclSimpleXMLElem); + destructor Destroy; override; + function Add(const Name, Value: string): TJclSimpleXMLProp; overload; + {$IFDEF SUPPORTS_UNICODE} + function Add(const Name: string; const Value: AnsiString): TJclSimpleXMLProp; overload; + {$ENDIF SUPPORTS_UNICODE} + function Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; + function Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; + procedure Clear; virtual; + procedure Delete(const Index: Integer); overload; + procedure Delete(const Name: string); overload; + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLPropsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; + function BoolValue(const Name: string; Default: Boolean = True): Boolean; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream); + property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default; + property ItemNamed[const Name: string]: TJclSimpleXMLProp read GetItemNamed; + property Count: Integer read GetCount; + property Parent: TJclSimpleXMLElem read FParent; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLElemsPrologEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLElemsProlog; + public + constructor Create(AList: TJclSimpleXMLElemsProlog); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLElemsProlog = class(TObject) + private + FElems: TJclSimpleItemHashedList; + function GetCount: Integer; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + function GetEncoding: string; + function GetStandAlone: Boolean; + function GetVersion: string; + procedure SetEncoding(const Value: string); + procedure SetStandAlone(const Value: Boolean); + procedure SetVersion(const Value: string); + protected + FSimpleXML: TJclSimpleXML; + function FindHeader: TJclSimpleXMLElem; + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + constructor Create(ASimpleXML: TJclSimpleXML); + destructor Destroy; override; + function AddComment(const AValue: string): TJclSimpleXMLElemComment; + function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; + procedure Clear; + function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; + function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream); + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property Count: Integer read GetCount; + property Encoding: string read GetEncoding write SetEncoding; + property SimpleXML: TJclSimpleXML read FSimpleXML; + property StandAlone: Boolean read GetStandAlone write SetStandAlone; + property Version: string read GetVersion write SetVersion; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLNamedElemsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLNamedElems; + public + constructor Create(AList: TJclSimpleXMLNamedElems); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLNamedElems = class(TJclSimpleItem) + private + FElems: TJclSimpleXMLElems; + function GetCount: Integer; + protected + FItems: TList; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + procedure SetName(const Value: string); override; + public + constructor Create(AElems: TJclSimpleXMLElems; const AName: string); + destructor Destroy; override; + + function Add: TJclSimpleXMLElemClassic; overload; + function Add(const Value: string): TJclSimpleXMLElemClassic; overload; + function Add(const Value: Int64): TJclSimpleXMLElemClassic; overload; + function Add(const Value: Boolean): TJclSimpleXMLElemClassic; overload; + function Add(Value: TStream): TJclSimpleXMLElemClassic; overload; + function AddFirst: TJclSimpleXMLElemClassic; + function AddComment(const Value: string): TJclSimpleXMLElemComment; + function AddCData(const Value: string): TJclSimpleXMLElemCData; + function AddText(const Value: string): TJclSimpleXMLElemText; + procedure Clear; virtual; + procedure Delete(const Index: Integer); + procedure Move(const CurIndex, NewIndex: Integer); + function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; + function IndexOf(const Value: string): Integer; overload; + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + + property Elems: TJclSimpleXMLElems read FElems; + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property Count: Integer read GetCount; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLElemsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLElems; + public + constructor Create(AList: TJclSimpleXMLElems); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLElemCompare = function(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer of object; + TJclSimpleXMLElems = class(TObject) + private + FParent: TJclSimpleXMLElem; + function GetCount: Integer; + function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; + function GetItemNamed(const Name: string): TJclSimpleXMLElem; + function GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; + protected + FElems: TJclSimpleItemHashedList; + FCompare: TJclSimpleXMLElemCompare; + FNamedElems: TJclSimpleItemHashedList; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + procedure AddChild(const Value: TJclSimpleXMLElem); + procedure AddChildFirst(const Value: TJclSimpleXMLElem); + procedure InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); + procedure DoItemRename(Value: TJclSimpleXMLElem; const Name: string); + procedure CreateElems; + function SimpleCompare(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer; + public + constructor Create(AParent: TJclSimpleXMLElem); + destructor Destroy; override; + + // Use notify to indicate to a list that the given element is removed + // from the list so that it doesn't delete it as well as the one + // that insert it in itself. This method is automatically called + // by AddChild and AddChildFirst if the Container property of the + // given element is set. + procedure Notify(Value: TJclSimpleXMLElem; Operation: TOperation); + + function Add(const Name: string): TJclSimpleXMLElemClassic; overload; + function Add(const Name, Value: string): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; overload; + function Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; + function AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; + function AddFirst(const Name: string): TJclSimpleXMLElemClassic; overload; + function AddComment(const Name: string; const Value: string): TJclSimpleXMLElemComment; + function AddCData(const Name: string; const Value: string): TJclSimpleXMLElemCData; + function AddText(const Name: string; const Value: string): TJclSimpleXMLElemText; + function Insert(Value: TJclSimpleXMLElem; Index: Integer): TJclSimpleXMLElem; overload; + function Insert(const Name: string; Index: Integer): TJclSimpleXMLElemClassic; overload; + procedure Clear; virtual; + procedure Delete(const Index: Integer); overload; + procedure Delete(const Name: string); overload; + function Remove(Value: TJclSimpleXMLElem): Integer; + procedure Move(const CurIndex, NewIndex: Integer); + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLElemsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; + function IndexOf(const Name: string): Integer; overload; + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; + function BoolValue(const Name: string; Default: Boolean = True): Boolean; + procedure BinaryValue(const Name: string; Stream: TStream); + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); + procedure Sort; + procedure CustomSort(AFunction: TJclSimpleXMLElemCompare); + property Parent: TJclSimpleXMLElem read FParent; + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property ItemNamed[const Name: string]: TJclSimpleXMLElem read GetItemNamed; + property Count: Integer read GetCount; + property NamedElems[const Name: string]: TJclSimpleXMLNamedElems read GetNamedElems; + end; + + {$TYPEINFO ON} + TJclSimpleXMLElem = class(TJclSimpleXMLData) + private + FParent: TJclSimpleXMLElem; + FSimpleXML: TJclSimpleXML; + function GetHasItems: Boolean; + function GetHasProperties: Boolean; + function GetItemCount: Integer; + function GetPropertyCount: Integer; + protected + FItems: TJclSimpleXMLElems; + FProps: TJclSimpleXMLProps; + function GetChildsCount: Integer; + function GetProps: TJclSimpleXMLProps; + procedure SetName(const Value: string); override; + function GetItems: TJclSimpleXMLElems; + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + //constructor Create; overload; + //constructor Create(const AName: string); overload; + //constructor Create(const AName, AValue: string); overload; + constructor Create(ASimpleXML: TJclSimpleXML); overload; + destructor Destroy; override; + procedure Assign(Value: TJclSimpleXMLElem); virtual; + procedure Clear; virtual; + procedure LoadFromStringStream(StringStream: TJclStringStream); virtual; abstract; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); virtual; + abstract; + procedure LoadFromString(const Value: string); + function SaveToString: string; + procedure GetBinaryValue(Stream: TStream); + function GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; + function GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; + + property SimpleXML: TJclSimpleXML read FSimpleXML; + published + property Parent: TJclSimpleXMLElem read FParent; + property ChildsCount: Integer read GetChildsCount; + property HasItems: Boolean read GetHasItems; + property HasProperties: Boolean read GetHasProperties; + property ItemCount: Integer read GetItemCount; + property PropertyCount: Integer read GetPropertyCount; + property Items: TJclSimpleXMLElems read GetItems; + property Properties: TJclSimpleXMLProps read GetProps; + end; + {$IFNDEF TYPEINFO_ON} + {$TYPEINFO OFF} + {$ENDIF ~TYPEINFO_ON} + TJclSimpleXMLElemClass = class of TJclSimpleXMLElem; + + TJclSimpleXMLElemComment = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemClassic = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemCData = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemText = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemProcessingInstruction = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemHeader = class(TJclSimpleXMLElemProcessingInstruction) + private + function GetEncoding: string; + function GetStandalone: Boolean; + function GetVersion: string; + procedure SetEncoding(const Value: string); + procedure SetStandalone(const Value: Boolean); + procedure SetVersion(const Value: string); + public + constructor Create; override; + + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + property Version: string read GetVersion write SetVersion; + property StandAlone: Boolean read GetStandalone write SetStandalone; + property Encoding: string read GetEncoding write SetEncoding; + end; + + // for backward compatibility + TJclSimpleXMLElemSheet = class(TJclSimpleXMLElemProcessingInstruction) + end; + + // for backward compatibility + TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElemProcessingInstruction) + end; + + TJclSimpleXMLElemDocType = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue, + sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace, + sxoTrimFollowingTextWhitespace, sxoKeepWhitespace, sxoDoNotSaveBOM, sxoCaseSensitive); + TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object; + TJclSimpleXMLEncodeStreamEvent = procedure(Sender: TObject; InStream, OutStream: TStream) of object; + + TJclSimpleXML = class(TObject) + protected + FEncoding: TJclStringEncoding; + FCodePage: Word; + FFileName: TFileName; + FOptions: TJclSimpleXMLOptions; + FRoot: TJclSimpleXMLElemClassic; + FOnTagParsed: TJclOnSimpleXMLParsed; + FOnValue: TJclOnValueParsed; + FOnLoadProg: TJclOnSimpleProgress; + FOnSaveProg: TJclOnSimpleProgress; + FProlog: TJclSimpleXMLElemsProlog; + FSaveCount: Integer; + FSaveCurrent: Integer; + FIndentString: string; + FBaseIndentString: string; + FOnEncodeValue: TJclSimpleXMLEncodeEvent; + FOnDecodeValue: TJclSimpleXMLEncodeEvent; + FOnDecodeStream: TJclSimpleXMLEncodeStreamEvent; + FOnEncodeStream: TJclSimpleXMLEncodeStreamEvent; + procedure SetIndentString(const Value: string); + procedure SetBaseIndentString(const Value: string); + procedure SetRoot(const Value: TJclSimpleXMLElemClassic); + procedure SetFileName(const Value: TFileName); + protected + procedure DoLoadProgress(const APosition, ATotal: Integer); + procedure DoSaveProgress; + procedure DoTagParsed(const AName: string); + procedure DoValueParsed(const AName, AValue: string); + procedure DoEncodeValue(var Value: string); virtual; + procedure DoDecodeValue(var Value: string); virtual; + procedure GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); + public + constructor Create; + destructor Destroy; override; + procedure LoadFromString(const Value: string); + procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure LoadFromResourceName(Instance: THandle; const ResName: string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToStringStream(StringStream: TJclStringStream); + function SaveToString: string; + function SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word = CP_ACP): string; + property CodePage: Word read FCodePage; + property Prolog: TJclSimpleXMLElemsProlog read FProlog write FProlog; + property Root: TJclSimpleXMLElemClassic read FRoot write SetRoot; + property XMLData: string read SaveToString write LoadFromString; + property FileName: TFileName read FFileName write SetFileName; + property IndentString: string read FIndentString write SetIndentString; + property BaseIndentString: string read FBaseIndentString write SetBaseIndentString; + property Options: TJclSimpleXMLOptions read FOptions write FOptions; + property OnSaveProgress: TJclOnSimpleProgress read FOnSaveProg write FOnSaveProg; + property OnLoadProgress: TJclOnSimpleProgress read FOnLoadProg write FOnLoadProg; + property OnTagParsed: TJclOnSimpleXMLParsed read FOnTagParsed write FOnTagParsed; + property OnValueParsed: TJclOnValueParsed read FOnValue write FOnValue; + property OnEncodeValue: TJclSimpleXMLEncodeEvent read FOnEncodeValue write FOnEncodeValue; + property OnDecodeValue: TJclSimpleXMLEncodeEvent read FOnDecodeValue write FOnDecodeValue; + property OnEncodeStream: TJclSimpleXMLEncodeStreamEvent read FOnEncodeStream write FOnEncodeStream; + property OnDecodeStream: TJclSimpleXMLEncodeStreamEvent read FOnDecodeStream write FOnDecodeStream; + end; + + TXMLVariant = class(TInvokeableVariantType) + public + procedure Clear(var V: TVarData); override; + function IsClear(const V: TVarData): Boolean; override; + procedure Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); override; + procedure CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); override; + + function DoFunction(var Dest: TVarData; const V: TVarData; + const Name: string; const Arguments: TVarDataArray): Boolean; override; + function GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; override; + function SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + end; + +procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); +function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; overload; +function XMLCreate: Variant; overload; +function VarXML: TVarType; + +// Encodes a string into an internal format: +// any character TAB,LF,CR,#32..#127 is preserved +// all other characters are converted to hex notation except +// for some special characters that are converted to XML entities +function SimpleXMLEncode(const S: string): string; +// Decodes a string encoded with SimpleXMLEncode: +// any character TAB,LF,CR,#32..#127 is preserved +// all other characters and substrings are converted from +// the special XML entities to characters or from hex to characters +// NB! Setting TrimBlanks to true will slow down the process considerably +procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); + +function XMLEncode(const S: string): string; +function XMLDecode(const S: string): string; + +// Encodes special characters (', ", <, > and &) into XML entities (@apos;, ", <, > and &) +function EntityEncode(const S: string): string; +// Decodes XML entities (@apos;, ", <, > and &) into special characters (', ", <, > and &) +function EntityDecode(const S: string): string; + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNITSCOPE} + System.Types, + {$ENDIF HAS_UNITSCOPE} + JclCharsets, + JclStrings, + JclUnicode, + JclStringConversions, + JclResources; + +const + cBufferSize = 8192; + +var + GlobalXMLVariant: TXMLVariant = nil; + + PreparedNibbleCharMapping: Boolean = False; + NibbleCharMapping: array [Low(Char)..High(Char)] of Byte; + +function XMLVariant: TXMLVariant; +begin + if not Assigned(GlobalXMLVariant) then + GlobalXMLVariant := TXMLVariant.Create; + Result := GlobalXMLVariant; +end; + +procedure AddEntity(var Res: string; var ResIndex, ResLen: Integer; const Entity: string); +var + EntityIndex, EntityLen: Integer; +begin + EntityLen := Length(Entity); + if (ResIndex + EntityLen) > ResLen then + begin + if ResLen <= EntityLen then + ResLen := ResLen * EntityLen + else + ResLen := ResLen * 2; + SetLength(Res, ResLen); + end; + for EntityIndex := 1 to EntityLen do + begin + Res[ResIndex] := Entity[EntityIndex]; + Inc(ResIndex); + end; +end; + +function EntityEncode(const S: string): string; +var + C: Char; + SIndex, SLen, RIndex, RLen: Integer; + Tmp: string; +begin + SLen := Length(S); + RLen := SLen; + RIndex := 1; + SetLength(Tmp, RLen); + for SIndex := 1 to SLen do + begin + C := S[SIndex]; + case C of + '"': + AddEntity(Tmp, RIndex, RLen, '"'); + '&': + AddEntity(Tmp, RIndex, RLen, '&'); + #39: + AddEntity(Tmp, RIndex, RLen, '''); + '<': + AddEntity(Tmp, RIndex, RLen, '<'); + '>': + AddEntity(Tmp, RIndex, RLen, '>'); + else + if RIndex > RLen then + begin + RLen := RLen * 2; + SetLength(Tmp, RLen); + end; + Tmp[RIndex] := C; + Inc(RIndex); + end; + end; + if RIndex > 1 then + SetLength(Tmp, RIndex - 1); + + Result := Tmp; +end; + +function EntityDecode(const S: string): string; +var + I, J, L: Integer; +begin + Result := S; + I := 1; + J := 1; + L := Length(Result); + + while I <= L do + begin + if Result[I] = '&' then + begin + if StrSame(Copy(Result, I, 5), '&') then + begin + Result[J] := '&'; + Inc(J); + Inc(I, 4); + end + else + if StrSame(Copy(Result, I, 4), '<') then + begin + Result[J] := '<'; + Inc(J); + Inc(I, 3); + end + else + if StrSame(Copy(Result, I, 4), '>') then + begin + Result[J] := '>'; + Inc(J); + Inc(I, 3); + end + else + if StrSame(Copy(Result, I, 6), ''') then + begin + Result[J] := #39; + Inc(J); + Inc(I, 5); + end + else + if StrSame(Copy(Result, I, 6), '"') then + begin + Result[J] := '"'; + Inc(J); + Inc(I, 5); + end + else + begin + Result[J] := Result[I]; + Inc(J); + end; + end + else + begin + Result[J] := Result[I]; + Inc(J); + end; + Inc(I); + end; + if J > 1 then + SetLength(Result, J - 1) + else + SetLength(Result, 0); +end; + +function SimpleXMLEncode(const S: string): string; +var + C: Char; + SIndex, SLen, RIndex, RLen: Integer; + Tmp: string; +begin + SLen := Length(S); + RLen := SLen; + RIndex := 1; + SetLength(Tmp, RLen); + for SIndex := 1 to SLen do + begin + C := S[SIndex]; + case C of + '"': + AddEntity(Tmp, RIndex, RLen, '"'); + '&': + AddEntity(Tmp, RIndex, RLen, '&'); + #39: + AddEntity(Tmp, RIndex, RLen, '''); + '<': + AddEntity(Tmp, RIndex, RLen, '<'); + '>': + AddEntity(Tmp, RIndex, RLen, '>'); + NativeNull..NativeBackspace, // NativeTab, NativeLineFeed + NativeVerticalTab..NativeFormFeed, // NativeCarriageReturn + NativeSo..NativeUs, + Char(128)..Char(255): + AddEntity(Tmp, RIndex, RLen, Format('&#x%.2x;', [Ord(C)])); + {$IFDEF SUPPORTS_UNICODE} + Char(256)..High(Char): + AddEntity(Tmp, RIndex, RLen, Format('&#x%.4x;', [Ord(C)])); + {$ENDIF SUPPORTS_UNICODE} + else + if RIndex > RLen then + begin + RLen := RLen * 2; + SetLength(Tmp, RLen); + end; + Tmp[RIndex] := C; + Inc(RIndex); + end; + end; + if RIndex > 1 then + SetLength(Tmp, RIndex - 1); + + Result := Tmp; +end; + +procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); + procedure DecodeEntity(var S: string; StringLength: Cardinal; + var ReadIndex, WriteIndex: Cardinal); + const + cHexPrefix: array [Boolean] of string = ('', '$'); + var + I: Cardinal; + Value: Integer; + IsHex: Boolean; + begin + Inc(ReadIndex, 2); + IsHex := (ReadIndex <= StringLength) and ((S[ReadIndex] = 'x') or (S[ReadIndex] = 'X')); + Inc(ReadIndex, Ord(IsHex)); + I := ReadIndex; + while ReadIndex <= StringLength do + begin + if S[ReadIndex] = ';' then + begin + Value := StrToIntDef(cHexPrefix[IsHex] + Copy(S, I, ReadIndex - I), -1); // no characters are less than 0 + if Value >= 0 then + S[WriteIndex] := Chr(Value) + else + ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start + Exit; + end; + Inc(ReadIndex); + end; + ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start + end; + + procedure SkipBlanks(var S: string; StringLength: Cardinal; var ReadIndex: Cardinal); + begin + while ReadIndex < StringLength do + begin + if S[ReadIndex] = NativeCarriageReturn then + S[ReadIndex] := NativeLineFeed + else + if S[ReadIndex + 1] = NativeCarriageReturn then + S[ReadIndex + 1] := NativeLineFeed; + if (S[ReadIndex] < #33) and (S[ReadIndex] = S[ReadIndex + 1]) then + Inc(ReadIndex) + else + Exit; + end; + end; + +var + StringLength, ReadIndex, WriteIndex: Cardinal; +begin + // NB! This procedure replaces the text inplace to speed up the conversion. This + // works because when decoding, the string can only become shorter. This is + // accomplished by keeping track of the current read and write points. + // In addition, the original string length is read only once and passed to the + // inner procedures to speed up conversion as much as possible + ReadIndex := 1; + WriteIndex := 1; + StringLength := Length(S); + while ReadIndex <= StringLength do + begin + // this call lowers conversion speed by ~30%, ie 21MB/sec -> 15MB/sec (repeated tests, various inputs) + if TrimBlanks then + SkipBlanks(S, StringLength, ReadIndex); + if S[ReadIndex] = '&' then + begin + if (ReadIndex < StringLength) and (S[ReadIndex + 1] = '#') then + begin + DecodeEntity(S, StringLength, ReadIndex, WriteIndex); + Inc(WriteIndex); + end + else + if StrSame(Copy(S, ReadIndex, 5), '&') then + begin + S[WriteIndex] := '&'; + Inc(WriteIndex); + Inc(ReadIndex, 4); + end + else + if StrSame(Copy(S, ReadIndex, 4), '<') then + begin + S[WriteIndex] := '<'; + Inc(WriteIndex); + Inc(ReadIndex, 3); + end + else + if StrSame(Copy(S, ReadIndex, 4), '>') then + begin + S[WriteIndex] := '>'; + Inc(WriteIndex); + Inc(ReadIndex, 3); + end + else + if StrSame(Copy(S, ReadIndex, 6), ''') then + begin + S[WriteIndex] := #39; + Inc(WriteIndex); + Inc(ReadIndex, 5); + end + else + if StrSame(Copy(S, ReadIndex, 6), '"') then + begin + S[WriteIndex] := '"'; + Inc(WriteIndex); + Inc(ReadIndex, 5); + end + else + begin + S[WriteIndex] := S[ReadIndex]; + Inc(WriteIndex); + end; + end + else + begin + S[WriteIndex] := S[ReadIndex]; + Inc(WriteIndex); + end; + Inc(ReadIndex); + end; + if WriteIndex > 0 then + SetLength(S, WriteIndex - 1) + else + SetLength(S, 0); + // this call lowers conversion speed by ~65%, ie 21MB/sec -> 7MB/sec (repeated tests, various inputs) +// if TrimBlanks then +// S := AdjustLineBreaks(S); +end; + +function XMLEncode(const S: string): string; +begin + Result := SimpleXMLEncode(S); +end; + +function XMLDecode(const S: string): string; +begin + Result := S; + SimpleXMLDecode(Result, False); +end; + +//=== { TJclSimpleItem } ===================================================== + +procedure TJclSimpleItem.SetName(const Value: string); +begin + FName := Value; +end; + +//=== { TJclSimpleItemHashedList } =========================================== + +procedure TJclSimpleItemHashedList.Clear; +begin + InvalidateHash; + inherited Clear; +end; + +constructor TJclSimpleItemHashedList.Create(ACaseSensitive: Boolean); +begin + inherited Create(True); + FCaseSensitive := ACaseSensitive; +end; + +destructor TJclSimpleItemHashedList.Destroy; +begin + FreeAndNil(FNameHash); + inherited Destroy; +end; + +function TJclSimpleItemHashedList.Add(Item: TJclSimpleItem): Integer; +begin + Result := inherited Add(Item); + if FNameHash <> nil then + begin + if FCaseSensitive then + FNameHash.Add(Item.Name, Result) + else + FNameHash.Add(UpperCase(Item.Name), Result); + end; +end; + +function TJclSimpleItemHashedList.GetSimpleItem(Index: Integer): TJclSimpleItem; +begin + Result := TJclSimpleItem(GetItem(Index)); +end; + +function TJclSimpleItemHashedList.GetSimpleItemByName(const Name: string): TJclSimpleItem; +var + I: Integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := TJclSimpleItem(Items[I]) + else + Result := nil; +end; + +function TJclSimpleItemHashedList.IndexOfSimpleItem(Item: TJclSimpleItem): Integer; +begin + Result := IndexOf(Item); +end; + +function TJclSimpleItemHashedList.IndexOfName(const Name: string): Integer; +var + I: Integer; +begin + if FCaseSensitive then + begin + if FNameHash = nil then + begin + FNameHash := TStringHash.Create(8); + for I := 0 to Count - 1 do + FNameHash.Add(TJclSimpleData(Items[I]).Name, I); + end; + Result := FNameHash.ValueOf(Name); + end + else + begin + if FNameHash = nil then + begin + FNameHash := TStringHash.Create(8); + for I := 0 to Count - 1 do + FNameHash.Add(UpperCase(TJclSimpleData(Items[I]).Name), I); + end; + Result := FNameHash.ValueOf(UpperCase(Name)); + end; +end; + +procedure TJclSimpleItemHashedList.Insert(Index: Integer; Item: TJclSimpleItem); +begin + InvalidateHash; + inherited Insert(Index, Item); +end; + +procedure TJclSimpleItemHashedList.InvalidateHash; +begin + FreeAndNil(FNameHash); +end; + +procedure TJclSimpleItemHashedList.Move(CurIndex, NewIndex: Integer); +begin + InvalidateHash; + inherited Move(CurIndex, NewIndex); +end; + +procedure TJclSimpleItemHashedList.Notify(Ptr: Pointer; Action: TListNotification); +begin + if (Action = lnDeleted) and (FNameHash <> nil) then + begin + InvalidateHash; +// if FCaseSensitive then +// FNameHash.Remove(TJclSimpleItem(Ptr).Name) +// else +// FNameHash.Remove(UpperCase(TJclSimpleItem(Ptr).Name)); + end; + inherited Notify(Ptr, Action); +end; + +procedure TJclSimpleItemHashedList.SetCaseSensitive(const Value: Boolean); +begin + if FCaseSensitive <> Value then + begin + InvalidateHash; + FCaseSensitive := Value; + end; +end; + +//=== { TJclSimpleData } ===================================================== + +constructor TJclSimpleData.Create; +begin + inherited Create; +end; + +constructor TJclSimpleData.Create(const AName: string); +begin + inherited Create; + FName := AName; +end; + +constructor TJclSimpleData.Create(const AName, AValue: string); +begin + inherited Create; + FName := AName; + FValue := AValue; +end; + +function TJclSimpleData.GetAnsiValue: AnsiString; +begin + Result := AnsiString(Value); +end; + +function TJclSimpleData.GetBoolValue: Boolean; +begin + Result := StrToBoolDef(Value, False); +end; + +function TJclSimpleData.GetFloatValue: Extended; +begin + Result := 0.0; + if not TryStrToFloat(Value, Result) then + Result := 0.0; +end; + +function TJclSimpleData.GetIntValue: Int64; +begin + Result := StrToInt64Def(Value, -1); +end; + +procedure TJclSimpleData.SetAnsiValue(const Value: AnsiString); +begin + Self.Value := string(Value); +end; + +procedure TJclSimpleData.SetBoolValue(const Value: Boolean); +begin + FValue := BoolToStr(Value); +end; + +procedure TJclSimpleData.SetFloatValue(const Value: Extended); +begin + FValue := FloatToStr(Value); +end; + +procedure TJclSimpleData.SetIntValue(const Value: Int64); +begin + FValue := IntToStr(Value); +end; + +//=== { TJclSimpleXMLData } ================================================== + +function TJclSimpleXMLData.FullName: string; +begin + if NameSpace <> '' then + Result := NameSpace + ':' + Name + else + Result := Name; +end; + +//=== { TJclSimpleXML } ====================================================== + +constructor TJclSimpleXML.Create; +begin + inherited Create; + FRoot := TJclSimpleXMLElemClassic.Create(Self); + FProlog := TJclSimpleXMLElemsProlog.Create(Self); + FOptions := [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity]; + FIndentString := ' '; +end; + +destructor TJclSimpleXML.Destroy; +begin + FreeAndNil(FRoot); + FreeAndNil(FProlog); + inherited Destroy; +end; + +procedure TJclSimpleXML.DoDecodeValue(var Value: string); +begin + if sxoAutoEncodeValue in Options then + SimpleXMLDecode(Value, False) + else + if sxoAutoEncodeEntity in Options then + Value := EntityDecode(Value); + if Assigned(FOnDecodeValue) then + FOnDecodeValue(Self, Value); +end; + +procedure TJclSimpleXML.DoEncodeValue(var Value: string); +begin + if Assigned(FOnEncodeValue) then + FOnEncodeValue(Self, Value); + if sxoAutoEncodeValue in Options then + Value := SimpleXMLEncode(Value) + else + if sxoAutoEncodeEntity in Options then + Value := EntityEncode(Value); +end; + +procedure TJclSimpleXML.DoLoadProgress(const APosition, ATotal: Integer); +begin + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, APosition, ATotal); +end; + +procedure TJclSimpleXML.DoSaveProgress; +begin + if Assigned(FOnSaveProg) then + begin + Inc(FSaveCount); + FOnSaveProg(Self, FSaveCurrent, FSaveCount); + end; +end; + +procedure TJclSimpleXML.DoTagParsed(const AName: string); +begin + if Assigned(FOnTagParsed) then + FOnTagParsed(Self, AName); +end; + +procedure TJclSimpleXML.DoValueParsed(const AName, AValue: string); +begin + if Assigned(FOnValue) then + FOnValue(Self, AName, AValue); +end; + +procedure TJclSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); +var + Stream: TMemoryStream; +begin + Stream := TMemoryStream.Create; + try + Stream.LoadFromFile(FileName); + LoadFromStream(Stream, Encoding, CodePage); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromResourceName(Instance: THandle; const ResName: string; + Encoding: TJclStringEncoding; CodePage: Word); +{$IFNDEF MSWINDOWS} +const + RT_RCDATA = PChar(10); +{$ENDIF !MSWINDOWS} +var + Stream: TResourceStream; +begin + Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); + try + LoadFromStream(Stream, Encoding, CodePage); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); +var + AOutStream: TStream; + AStringStream: TJclStringStream; + DoFree: Boolean; +begin + FRoot.Clear; + FProlog.Clear; + AOutStream := nil; + DoFree := False; + try + if Assigned(FOnDecodeStream) then + begin + AOutStream := TMemoryStream.Create; + DoFree := True; + FOnDecodeStream(Self, Stream, AOutStream); + AOutStream.Seek(0, soBeginning); + end + else + AOutStream := Stream; + + case Encoding of + seAnsi: + begin + AStringStream := TJclAnsiStream.Create(AOutStream, False); + TJclAnsiStream(AStringStream).CodePage := CodePage; + end; + seUTF8: + AStringStream := TJclUTF8Stream.Create(AOutStream, False); + seUTF16: + AStringStream := TJclUTF16Stream.Create(AOutStream, False); + else + AStringStream := TJclAutoStream.Create(AOutStream, False); + if CodePage <> CP_ACP then + TJclAutoStream(AStringStream).CodePage := CodePage; + end; + try + AStringStream.SkipBOM; + + LoadFromStringStream(AStringStream); + + // save codepage and encoding for future saves + if AStringStream is TJclAutoStream then + begin + FCodePage := TJclAutoStream(AStringStream).CodePage; + FEncoding := TJclAutoStream(AStringStream).Encoding; + end + else + if AStringStream is TJclAnsiStream then + begin + FCodePage := TJclAnsiStream(AStringStream).CodePage; + FEncoding := Encoding; + end + else + begin + FCodePage := CodePage; + FEncoding := Encoding; + end; + finally + AStringStream.Free; + end; + finally + if DoFree then + AOutStream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromStringStream(StringStream: TJclStringStream); +var + BufferSize: Integer; +begin + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); + + BufferSize := StringStream.BufferSize; + StringStream.BufferSize := 1; + + // Read doctype and so on + FProlog.LoadFromStringStream(StringStream); + + StringStream.BufferSize := BufferSize; + + // Read elements + FRoot.LoadFromStringStream(StringStream); + + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); +end; + +procedure TJclSimpleXML.LoadFromString(const Value: string); +var + Stream: TStringStream; +begin + Stream := TStringStream.Create(Value {$IFDEF SUPPORTS_UNICODE}, TEncoding.Unicode{$ENDIF}); + try + LoadFromStream(Stream {$IFDEF SUPPORTS_UNICODE}, seUTF16, CP_UTF16LE{$ENDIF}); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); +var + XMLHeader: TJclSimpleXMLElemHeader; + I: Integer; +begin + XMLHeader := nil; + for I := 0 to Prolog.Count - 1 do + if Prolog.Item[I] is TJclSimpleXMLElemHeader then + begin + XMLHeader := TJclSimpleXMLElemHeader(Prolog.Item[I]); + Break; + end; + if Assigned(XMLHeader) then + begin + CodePage := CodePageFromCharsetName(XMLHeader.Encoding); + case CodePage of + CP_UTF8: + Encoding := seUTF8; + CP_UTF16LE: + Encoding := seUTF16; + else + Encoding := seAnsi; + end; + end + else + begin + // restore from previous load + Encoding := FEncoding; + CodePage := FCodePage; + end; +end; + +procedure TJclSimpleXML.SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); +var + Stream: TMemoryStream; +begin + Stream := TMemoryStream.Create; + try + SaveToStream(Stream, Encoding, CodePage); + Stream.SaveToFile(FileName); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); +var + AOutStream: TStream; + AStringStream: TJclStringStream; + DoFree: Boolean; +begin + if Assigned(FOnEncodeStream) then + begin + AOutStream := TMemoryStream.Create; + DoFree := True; + end + else + begin + AOutStream := Stream; + DoFree := False; + end; + try + if Encoding = seAuto then + GetEncodingFromXMLHeader(Encoding, CodePage); + + case Encoding of + seUTF8: + begin + AStringStream := TJclUTF8Stream.Create(AOutStream, False); + FCodePage := CP_UTF8; + end; + seUTF16: + begin + AStringStream := TJclUTF16Stream.Create(AOutStream, False); + FCodePage := CP_UTF16LE; + end + else + AStringStream := TJclAnsiStream.Create(AOutStream); + TJclAnsiStream(AStringStream).CodePage := CodePage; + end; + try + if not (sxoDoNotSaveBOM in Options) then + AStringStream.WriteBOM; + SaveToStringStream(AStringStream); + AStringStream.Flush; + finally + AStringStream.Free; + end; + if Assigned(FOnEncodeStream) then + begin + AOutStream.Seek(0, soBeginning); + FOnEncodeStream(Self, AOutStream, Stream); + end; + finally + if DoFree then + AOutStream.Free; + end; +end; + +procedure TJclSimpleXML.SaveToStringStream(StringStream: TJclStringStream); +var + lCount: Integer; +begin + lCount := Root.ChildsCount + Prolog.Count; + FSaveCount := lCount; + FSaveCurrent := 0; + + if Assigned(FOnSaveProg) then + FOnSaveProg(Self, 0, lCount); + + if not (sxoDoNotSaveProlog in FOptions) then + Prolog.SaveToStringStream(StringStream); + + Root.SaveToStringStream(StringStream, BaseIndentString); + + if Assigned(FOnSaveProg) then + FOnSaveProg(Self, lCount, lCount); +end; + +function TJclSimpleXML.SaveToString: string; +begin + Result := SaveToStringEncoding(seAuto, CP_ACP); +end; + +function TJclSimpleXML.SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word): string; +var + Stream: TStringStream; +begin + {$IFDEF SUPPORTS_UNICODE} + // Use the same logic for seAuto as in SaveToStream for creating the TStringStream. + // Otherwise a Unicode-TStringStream is written to from a TJclAnsiStream proxy. + if Encoding = seAuto then + GetEncodingFromXMLHeader(Encoding, CodePage); + + case Encoding of + seAnsi: + Stream := TStringStream.Create('', TEncoding.{$IFDEF COMPILER16_UP}ANSI{$ELSE}Default{$ENDIF}); + seUTF8: + Stream := TStringStream.Create('', TEncoding.UTF8); + else + //seUTF16: + Stream := TStringStream.Create('', TEncoding.Unicode); + end; + {$ELSE ~SUPPORTS_UNICODE} + Stream := TStringStream.Create(''); + {$ENDIF ~SUPPORTS_UNICODE} + try + SaveToStream(Stream, Encoding, CodePage); + Result := Stream.DataString; + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.SetBaseIndentString(const Value: string); +begin + // test if the new value is only made of spaces or tabs + if not StrContainsChars(Value, CharIsWhiteSpace, True) then + Exit; + + FBaseIndentString := Value; +end; + +procedure TJclSimpleXML.SetFileName(const Value: TFileName); +begin + FFileName := Value; + LoadFromFile(Value); +end; + +//=== { TJclSimpleXMLElem } ================================================== + +procedure TJclSimpleXMLElem.Assign(Value: TJclSimpleXMLElem); +var + Elems: TJclSimpleXMLElem; + SrcElem, DestElem: TJclSimpleXMLElem; + I: Integer; + SrcProps, DestProps: TJclSimpleXMLProps; + SrcProp: TJclSimpleXMLProp; + SrcElems, DestElems: TJclSimpleXMLElems; +begin + Clear; + if Value = nil then + Exit; + Elems := TJclSimpleXMLElem(Value); + Name := Elems.Name; + Self.Value := Elems.Value; + SrcProps := Elems.FProps; + if Assigned(SrcProps) then + begin + DestProps := Properties; + for I := 0 to SrcProps.Count - 1 do + begin + SrcProp := SrcProps.Item[I]; + DestProps.Add(SrcProp.Name, SrcProp.Value); + end; + end; + + SrcElems := Elems.FItems; + if Assigned(SrcElems) then + begin + DestElems := Items; + for I := 0 to SrcElems.Count - 1 do + begin + // Create from the class type, so that the virtual constructor is called + // creating an element of the correct class type. + SrcElem := SrcElems.Item[I]; + DestElem := TJclSimpleXMLElemClass(SrcElem.ClassType).Create(SrcElem.Name, SrcElem.Value); + DestElem.Assign(SrcElem); + DestElems.Add(DestElem); + end; + end; +end; + +procedure TJclSimpleXMLElem.Clear; +begin + if FItems <> nil then + FItems.Clear; + if FProps <> nil then + FProps.Clear; +end; + +constructor TJclSimpleXMLElem.Create(ASimpleXML: TJclSimpleXML); +begin + Create; + FSimpleXML := ASimpleXML; +end; + +destructor TJclSimpleXMLElem.Destroy; +begin + FSimpleXML := nil; + FParent := nil; + Clear; + FreeAndNil(FItems); + FreeAndNil(FProps); + inherited Destroy; +end; + +procedure TJclSimpleXMLElem.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +procedure TJclSimpleXMLElem.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +procedure TJclSimpleXMLElem.GetBinaryValue(Stream: TStream); +var + I, J, ValueLength, RequiredStreamSize: Integer; + Buf: array [0..cBufferSize - 1] of Byte; + N1, N2: Byte; + + function NibbleCharToNibble(const AChar: Char): Byte; + begin + case AChar of + '0': Result := 0; + '1': Result := 1; + '2': Result := 2; + '3': Result := 3; + '4': Result := 4; + '5': Result := 5; + '6': Result := 6; + '7': Result := 7; + '8': Result := 8; + '9': Result := 9; + 'a', 'A': Result := 10; + 'b', 'B': Result := 11; + 'c', 'C': Result := 12; + 'd', 'D': Result := 13; + 'e', 'E': Result := 14; + 'f', 'F': Result := 15; + else + Result := 16; + end; + end; + + procedure PrepareNibbleCharMapping; + var + C: Char; + begin + if not PreparedNibbleCharMapping then + begin + for C := Low(Char) to High(Char) do + NibbleCharMapping[C] := NibbleCharToNibble(C); + PreparedNibbleCharMapping := True; + end; + end; + +var + CurrentStreamPosition: Integer; +begin + PrepareNibbleCharMapping; + I := 1; + J := 0; + ValueLength := Length(Value); + RequiredStreamSize := Stream.Position + ValueLength div 2; + if Stream.Size < RequiredStreamSize then + begin + CurrentStreamPosition := Stream.Position; + Stream.Size := RequiredStreamSize; + Stream.Seek(CurrentStreamPosition, soBeginning); + end; + while I < ValueLength do + begin + //faster replacement for St := '$' + Value[I] + Value[I + 1]; Buf[J] := StrToIntDef(St, 0); + N1 := NibbleCharMapping[Value[I]]; + N2 := NibbleCharMapping[Value[I + 1]]; + Inc(I, 2); + if (N1 > 15) or (N2 > 15) then + Buf[J] := 0 + else + Buf[J] := (N1 shl 4) or N2; + Inc(J); + if J = cBufferSize - 1 then //Buffered write to speed up the process a little + begin + Stream.Write(Buf, J); + J := 0; + end; + end; + Stream.Write(Buf, J); +end; + +function TJclSimpleXMLElem.GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; +begin + if FItems = nil then + Result := -1 + else + Result := FItems.FElems.IndexOfSimpleItem(AChild); +end; + +function TJclSimpleXMLElem.GetChildsCount: Integer; +var + I: Integer; +begin + Result := 1; + if FItems <> nil then + for I := 0 to FItems.Count - 1 do + Result := Result + FItems[I].ChildsCount; +end; + +function TJclSimpleXMLElem.GetHasItems: Boolean; +begin + Result := Assigned(FItems) and (FItems.Count > 0); +end; + +function TJclSimpleXMLElem.GetHasProperties: Boolean; +begin + Result := Assigned(FProps) and (FProps.Count > 0); +end; + +function TJclSimpleXMLElem.GetItemCount: Integer; +begin + Result := 0; + if Assigned(FItems) then + Result := FItems.Count; +end; + +function TJclSimpleXMLElem.GetItems: TJclSimpleXMLElems; +begin + if FItems = nil then + FItems := TJclSimpleXMLElems.Create(Self); + Result := FItems; +end; + +function TJclSimpleXMLElem.GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; +begin + Result := Items.NamedElems[AChild.Name].IndexOf(AChild); +end; + +function TJclSimpleXMLElem.GetPropertyCount: Integer; +begin + Result := 0; + if Assigned(FProps) then + Result := FProps.Count; +end; + +function TJclSimpleXMLElem.GetProps: TJclSimpleXMLProps; +begin + if FProps = nil then + FProps := TJclSimpleXMLProps.Create(Self); + Result := FProps; +end; + +procedure TJclSimpleXMLElem.LoadFromString(const Value: string); +var + Stream: TJclStringStream; + StrStream: TStringStream; +begin + StrStream := TStringStream.Create(Value); + try + Stream := TJclAutoStream.Create(StrStream); + try + LoadFromStringStream(Stream); + finally + Stream.Free; + end; + finally + StrStream.Free; + end; +end; + +function TJclSimpleXMLElem.SaveToString: string; +var + Stream: TJclStringStream; + StrStream: TStringStream; +begin + StrStream := TStringStream.Create(''); + try + Stream := TJclAutoStream.Create(StrStream); + try + SaveToStringStream(Stream); + Stream.Flush; + finally + Stream.Free; + end; + Result := StrStream.DataString; + finally + StrStream.Free; + end; +end; + +procedure TJclSimpleXMLElem.SetName(const Value: string); +begin + if (Value <> Name) and (Value <> '') then + begin + if (Parent <> nil) and (Name <> '') then + Parent.Items.DoItemRename(Self, Value); + inherited SetName(Value); + end; +end; + +//=== { TJclSimpleXMLNamedElemsEnumerator } ================================== + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLNamedElemsEnumerator.Create(AList: TJclSimpleXMLNamedElems); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLNamedElemsEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLNamedElemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLNamedElems } ============================================ + +constructor TJclSimpleXMLNamedElems.Create(AElems: TJclSimpleXMLElems; const AName: string); +begin + inherited Create; + FElems := AElems; + FName := AName; + FItems := TList.Create; +end; + +destructor TJclSimpleXMLNamedElems.Destroy; +begin + FItems.Free; + inherited Destroy; +end; + +function TJclSimpleXMLNamedElems.Add(const Value: Int64): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add(Value: TStream): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add(const Value: Boolean): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add: TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name); +end; + +function TJclSimpleXMLNamedElems.Add(const Value: string): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddCData(const Value: string): TJclSimpleXMLElemCData; +begin + Result := Elems.AddCData(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddComment(const Value: string): TJclSimpleXMLElemComment; +begin + Result := Elems.AddComment(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddFirst: TJclSimpleXMLElemClassic; +begin + Result := Elems.AddFirst(Name); +end; + +function TJclSimpleXMLNamedElems.AddText(const Value: string): TJclSimpleXMLElemText; +begin + Result := Elems.AddText(Name, Value); +end; + +procedure TJclSimpleXMLNamedElems.Clear; +var + Index: Integer; +begin + for Index := FItems.Count - 1 downto 0 do + Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); +end; + +procedure TJclSimpleXMLNamedElems.Delete(const Index: Integer); +begin + if (Index >= 0) and (Index < FItems.Count) then + Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); +end; + +function TJclSimpleXMLNamedElems.GetCount: Integer; +begin + Result := FItems.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLNamedElems.GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; +begin + Result := TJclSimpleXMLNamedElemsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLNamedElems.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + if (Index >= 0) then + begin + While (Index >= Count) do + if Assigned(Elems.Parent) and Assigned(Elems.Parent.SimpleXML) and + (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then + Add + else + break; + if Index < Count then + Result := TJclSimpleXMLElem(FItems.Items[Index]) + else + Result := nil; + end + else + Result := nil; +end; + +function TJclSimpleXMLNamedElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; +begin + Result := FItems.IndexOf(Value); +end; + +function TJclSimpleXMLNamedElems.IndexOf(const Value: string): Integer; +var + Index: Integer; + NewItem: TJclSimpleXMLElem; +begin + Result := -1; + for Index := 0 to FItems.Count - 1 do + if TJclSimpleXMLElem(FItems.Items[Index]).Value = Value then + begin + Result := Index; + Break; + end; + if (Result = -1) and (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then + begin + NewItem := Elems.Add(Name, Value); + Result := FItems.IndexOf(NewItem); + end; +end; + +procedure TJclSimpleXMLNamedElems.Move(const CurIndex, NewIndex: Integer); +var + ElemsCurIndex, ElemsNewIndex: Integer; +begin + ElemsCurIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[CurIndex])); + ElemsNewIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[NewIndex])); + Elems.Move(ElemsCurIndex, ElemsNewIndex); + FItems.Move(CurIndex, NewIndex); +end; + +procedure TJclSimpleXMLNamedElems.SetName(const Value: string); +begin + raise EJclSimpleXMLError.CreateRes(@SReadOnlyProperty); +end; + +//=== { TJclSimpleXMLElemsEnumerator } ======================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLElemsEnumerator.Create(AList: TJclSimpleXMLElems); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLElemsEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLElemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLElems } ================================================= + +function TJclSimpleXMLElems.Add(const Name: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name, Value: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, IntToStr(Value)); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; +begin + if Value <> nil then + AddChild(Value); + Result := Value; +end; + +function TJclSimpleXMLElems.Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, BoolToStr(Value)); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; +var + Stream: TStringStream; + Buf: array [0..cBufferSize - 1] of Byte; + St: string; + I, Count: Integer; +begin + Stream := TStringStream.Create(''); + try + Buf[0] := 0; + repeat + Count := Value.Read(Buf, Length(Buf)); + St := ''; + for I := 0 to Count - 1 do + St := St + IntToHex(Buf[I], 2); + Stream.WriteString(St); + until Count = 0; + Result := TJclSimpleXMLElemClassic.Create(Name, Stream.DataString); + AddChild(Result); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXMLElems.AddChild(const Value: TJclSimpleXMLElem); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Add(Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; + + Notify(Value, opInsert); +end; + +procedure TJclSimpleXMLElems.AddChildFirst(const Value: TJclSimpleXMLElem); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Insert(0, Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Insert(0, Value); + end; + + Notify(Value, opInsert); +end; + +function TJclSimpleXMLElems.AddFirst(const Name: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + AddChildFirst(Result); +end; + +function TJclSimpleXMLElems.AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; +begin + if Value <> nil then + AddChildFirst(Value); + Result := Value; +end; + +function TJclSimpleXMLElems.AddComment(const Name, + Value: string): TJclSimpleXMLElemComment; +begin + Result := TJclSimpleXMLElemComment.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.AddCData(const Name, Value: string): TJclSimpleXMLElemCData; +begin + Result := TJclSimpleXMLElemCData.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.AddText(const Name, Value: string): TJclSimpleXMLElemText; +begin + Result := TJclSimpleXMLElemText.Create(Name, Value); + AddChild(Result); +end; + +procedure TJclSimpleXMLElems.BinaryValue(const Name: string; Stream: TStream); +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamed(Name); + if Elem <> nil then + Elem.GetBinaryValue(Stream); +end; + +function TJclSimpleXMLElems.BoolValue(const Name: string; Default: Boolean): Boolean; +var + Elem: TJclSimpleXMLElem; +begin + try + Elem := GetItemNamedDefault(Name, BoolToStr(Default)); + if (Elem = nil) or (Elem.Value = '') then + Result := Default + else + Result := Elem.BoolValue; + except + Result := Default; + end; +end; + +procedure TJclSimpleXMLElems.Clear; +begin + if FElems <> nil then + FElems.Clear; + if FNamedElems <> nil then + FNamedElems.Clear; +end; + +constructor TJclSimpleXMLElems.Create(AParent: TJclSimpleXMLElem); +begin + inherited Create; + FParent := AParent; +end; + +procedure TJclSimpleXMLElems.CreateElems; +var + CaseSensitive: Boolean; +begin + if FElems = nil then + begin + CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) + and (sxoCaseSensitive in Parent.SimpleXML.Options); + FElems := TJclSimpleItemHashedList.Create(CaseSensitive); + end; +end; + +procedure TJclSimpleXMLElems.Delete(const Index: Integer); +var + Elem: TJclSimpleXMLElem; + NamedIndex: Integer; +begin + if (FElems <> nil) and (Index >= 0) and (Index < FElems.Count) then + begin + Elem := TJclSimpleXMLElem(FElems.SimpleItems[Index]); + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Elem.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Elem); + end; + FElems.Delete(Index); + end; +end; + +procedure TJclSimpleXMLElems.Delete(const Name: string); +begin + if FElems <> nil then + Delete(FElems.IndexOfName(Name)); +end; + +destructor TJclSimpleXMLElems.Destroy; +begin + FParent := nil; + Clear; + FreeAndNil(FElems); + FreeAndNil(FNamedElems); + inherited Destroy; +end; + +procedure TJclSimpleXMLElems.DoItemRename(Value: TJclSimpleXMLElem; const Name: string); +var + NamedIndex: Integer; +begin + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); + + NamedIndex := FNamedElems.IndexOfName(Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; +end; + +function TJclSimpleXMLElems.FloatValue(const Name: string; + const Default: Extended): Extended; +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamedDefault(Name, FloatToStr(Default)); + if Elem = nil then + Result := Default + else + Result := Elem.FloatValue; +end; + +function TJclSimpleXMLElems.GetCount: Integer; +begin + if FElems = nil then + Result := 0 + else + Result := FElems.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLElems.GetEnumerator: TJclSimpleXMLElemsEnumerator; +begin + Result := TJclSimpleXMLElemsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLElems.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + if (FElems = nil) or (Index > FElems.Count) then + Result := nil + else + Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); +end; + +function TJclSimpleXMLElems.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; +var + I: Integer; +begin + Result := nil; + if FElems <> nil then + begin + I := FElems.IndexOfName(Name); + if I <> -1 then + Result := TJclSimpleXMLElem(FElems.SimpleItems[I]) + else + if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then + Result := Add(Name, Default); + end + else + if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then + Result := Add(Name, Default); +end; + +function TJclSimpleXMLElems.GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; +var + NamedIndex: Integer; + CaseSensitive: Boolean; +begin + if FNamedElems = nil then + begin + CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) + and (sxoCaseSensitive in Parent.SimpleXML.Options); + FNamedElems := TJclSimpleItemHashedList.Create(CaseSensitive); + end; + NamedIndex := FNamedElems.IndexOfName(Name); + if NamedIndex = -1 then + begin + Result := TJclSimpleXMLNamedElems.Create(Self, Name); + FNamedElems.Add(Result); + if FElems <> nil then + for NamedIndex := 0 to FElems.Count - 1 do + if FElems.SimpleItems[NamedIndex].Name = Name then + Result.FItems.Add(FElems.SimpleItems[NamedIndex]); + end + else + Result := TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]); +end; + +function TJclSimpleXMLElems.GetItemNamed(const Name: string): TJclSimpleXMLElem; +begin + Result := GetItemNamedDefault(Name, ''); +end; + +function TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64; +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamedDefault(Name, IntToStr(Default)); + if Elem = nil then + Result := Default + else + Result := Elem.IntValue; +end; + +procedure TJclSimpleXMLElems.LoadFromStringStream(StringStream: TJclStringStream); +type + TReadStatus = (rsWaitingTag, rsReadingTagKind); +var + lPos: TReadStatus; + St: TUCS4Array; + lElem: TJclSimpleXMLElem; + Ch: UCS4; + ContainsText, ContainsWhiteSpace, KeepWhiteSpace: Boolean; + SimpleXML: TJclSimpleXML; +begin + SetLength(St, 0); + lPos := rsWaitingTag; + SimpleXML := Parent.SimpleXML; + KeepWhiteSpace := (SimpleXML <> nil) and (sxoKeepWhitespace in SimpleXML.Options); + ContainsText := False; + ContainsWhiteSpace := False; + + // We read from a stream, thus replacing the existing items + Clear; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + rsWaitingTag: //We are waiting for a tag and thus avoiding spaces + begin + if Ch = Ord('<') then + begin + lPos := rsReadingTagKind; + St := UCS4Array(Ch); + end + else + if UnicodeIsWhiteSpace(Ch) then + ContainsWhiteSpace := True + else + ContainsText := True; + end; + + rsReadingTagKind: //We are trying to determine the kind of the tag + begin + lElem := nil; + case Ch of + Ord('/'): + if UCS4ArrayEquals(St, '<') then + begin // "'), Ord(':'): //This should be a classic tag + begin // " + lElem := TJclSimpleXMLElemClassic.Create; + SetLength(St, 0); + lPos := rsWaitingTag; + end; + else + if ContainsText or (ContainsWhiteSpace and KeepWhiteSpace) then + begin + // inner text + lElem := TJclSimpleXMLElemText.Create; + lPos := rsReadingTagKind; + ContainsText := False; + ContainsWhiteSpace := False; + end + else + begin + if not UCS4ArrayEquals(St, ' nil then + begin + CreateElems; + Notify(lElem, opInsert); + lElem.LoadFromStringStream(StringStream); + FElems.Add(lElem); + end; + end; + end; + end; +end; + +procedure TJclSimpleXMLElems.Notify(Value: TJclSimpleXMLElem; Operation: TOperation); +var + NamedIndex: Integer; +begin + case Operation of + opRemove: + if Value.Parent = Parent then // Only remove if we have it + begin + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); + end; + FElems.Remove(Value); + Value.FParent := nil; + Value.FSimpleXML := nil; + end; + opInsert: + begin + Value.FParent := Parent; + Value.FSimpleXML := Parent.SimpleXML; + end; + end; +end; + +function TJclSimpleXMLElems.Remove(Value: TJclSimpleXMLElem): Integer; +begin + if FElems = nil + then Result := -1 // like TList.IndexOf(alien) + else begin + Result := FElems.IndexOfSimpleItem(Value); + Notify(Value, opRemove); + end; +end; + +procedure TJclSimpleXMLElems.SaveToStringStream(StringStream: TJclStringStream; + const Level: string); +var + I: Integer; +begin + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream, Level); +end; + +function TJclSimpleXMLElems.SimpleCompare(Elems: TJclSimpleXMLElems; Index1, + Index2: Integer): Integer; +begin + Result := CompareText(Elems.Item[Index1].Name, Elems.Item[Index2].Name); +end; + +function TJclSimpleXMLElems.Value(const Name, Default: string): string; +var + Elem: TJclSimpleXMLElem; +begin + Result := ''; + Elem := GetItemNamedDefault(Name, Default); + if Elem = nil then + Result := Default + else + Result := Elem.Value; +end; + +procedure TJclSimpleXMLElems.Move(const CurIndex, NewIndex: Integer); +begin + if FElems <> nil then + FElems.Move(CurIndex, NewIndex); +end; + +function TJclSimpleXMLElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; +begin + if FElems = nil then + Result := -1 + else + Result := FElems.IndexOfSimpleItem(Value); +end; + +function TJclSimpleXMLElems.IndexOf(const Name: string): Integer; +begin + if FElems = nil then + Result := -1 + else + Result := FElems.IndexOfName(Name); +end; + +procedure TJclSimpleXMLElems.InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Insert(Index, Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; + + Notify(Value, opInsert); +end; + +function TJclSimpleXMLElems.Insert(Value: TJclSimpleXMLElem; + Index: Integer): TJclSimpleXMLElem; +begin + if Value <> nil then + InsertChild(Value, Index); + Result := Value; +end; + +function TJclSimpleXMLElems.Insert(const Name: string; + Index: Integer): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + InsertChild(Result, Index); +end; + +procedure QuickSort(Elems: TJclSimpleXMLElems; List: TList; L, R: Integer; + AFunction: TJclSimpleXMLElemCompare); +var + I, J, M: Integer; +begin + repeat + I := L; + J := R; + M := (L + R) shr 1; + repeat + while AFunction(Elems, I, M) < 0 do + Inc(I); + while AFunction(Elems, J, M) > 0 do + Dec(J); + if I < J then + begin + List.Exchange(I, J); + Inc(I); + Dec(J); + end + else + if I = J then + begin + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(Elems, List, L, J, AFunction); + L := I; + until I >= R; +end; + +procedure TJclSimpleXMLElems.CustomSort(AFunction: TJclSimpleXMLElemCompare); +begin + if FElems <> nil then + QuickSort(Self, FElems, 0, FElems.Count - 1, AFunction); +end; + +procedure TJclSimpleXMLElems.Sort; +begin + CustomSort(SimpleCompare); +end; + +//=== { TJclSimpleXMLPropsEnumerator } ======================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLPropsEnumerator.Create(AList: TJclSimpleXMLProps); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLPropsEnumerator.GetCurrent: TJclSimpleXMLProp; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLPropsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLProps } ================================================= + +function TJclSimpleXMLProps.Add(const Name, Value: string): TJclSimpleXMLProp; +begin + if FProperties = nil then + FProperties := TStringList.Create; + Result := TJclSimpleXMLProp.Create(Parent, Name, Value); + FProperties.AddObject(Name, Result); +end; + +function TJclSimpleXMLProps.Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; +begin + Result := Add(Name, IntToStr(Value)); +end; + +function TJclSimpleXMLProps.Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; +begin + Result := Add(Name, BoolToStr(Value)); +end; + +{$IFDEF SUPPORTS_UNICODE} +function TJclSimpleXMLProps.Add(const Name: string; + const Value: AnsiString): TJclSimpleXMLProp; +begin + Result := Add(Name, string(Value)); +end; +{$ENDIF SUPPORTS_UNICODE} + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; +begin + if FProperties = nil then + FProperties := TStringList.Create; + Result := TJclSimpleXMLProp.Create(Parent, Name, Value); + FProperties.InsertObject(Index, Name, Result); +end; + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; +begin + Result := Insert(Index, Name, IntToStr(Value)); +end; + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; +begin + Result := Insert(Index, Name, BoolToStr(Value)); +end; + +function TJclSimpleXMLProps.BoolValue(const Name: string; Default: Boolean): Boolean; +var + Prop: TJclSimpleXMLProp; +begin + try + Prop := GetItemNamedDefault(Name, BoolToStr(Default)); + if (Prop = nil) or (Prop.Value = '') then + Result := Default + else + Result := Prop.BoolValue; + except + Result := Default; + end; +end; + +procedure TJclSimpleXMLProps.Clear; +var + I: Integer; +begin + if FProperties <> nil then + begin + for I := 0 to FProperties.Count - 1 do + begin + TJclSimpleXMLProp(FProperties.Objects[I]).Free; + FProperties.Objects[I] := nil; + end; + FProperties.Clear; + end; +end; + +procedure TJclSimpleXMLProps.Delete(const Index: Integer); +begin + if (FProperties <> nil) and (Index >= 0) and (Index < FProperties.Count) then + begin + TObject(FProperties.Objects[Index]).Free; + FProperties.Delete(Index); + end; +end; + +constructor TJclSimpleXMLProps.Create(AParent: TJclSimpleXMLElem); +begin + inherited Create; + FParent := AParent; +end; + +procedure TJclSimpleXMLProps.Delete(const Name: string); +begin + if FProperties <> nil then + Delete(FProperties.IndexOf(Name)); +end; + +destructor TJclSimpleXMLProps.Destroy; +begin + FParent := nil; + Clear; + FreeAndNil(FProperties); + inherited Destroy; +end; + +procedure TJclSimpleXMLProps.DoItemRename(Value: TJclSimpleXMLProp; const Name: string); +var + I: Integer; +begin + if FProperties = nil then + Exit; + I := FProperties.IndexOfObject(Value); + if I <> -1 then + FProperties[I] := Name; +end; + +procedure TJclSimpleXMLProps.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +function TJclSimpleXMLProps.FloatValue(const Name: string; + const Default: Extended): Extended; +var + Prop: TJclSimpleXMLProp; +begin + Prop := GetItemNamedDefault(Name, FloatToStr(Default)); + if Prop = nil then + Result := Default + else + Result := Prop.FloatValue; +end; + +procedure TJclSimpleXMLProps.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +function TJclSimpleXMLProps.GetCount: Integer; +begin + if FProperties = nil then + Result := 0 + else + Result := FProperties.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLProps.GetEnumerator: TJclSimpleXMLPropsEnumerator; +begin + Result := TJclSimpleXMLPropsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLProps.GetItem(const Index: Integer): TJclSimpleXMLProp; +begin + if FProperties <> nil then + Result := TJclSimpleXMLProp(FProperties.Objects[Index]) + else + Result := nil; +end; + +function TJclSimpleXMLProps.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; +var + I: Integer; +begin + Result := nil; + if FProperties <> nil then + begin + I := FProperties.IndexOf(Name); + if I <> -1 then + Result := TJclSimpleXMLProp(FProperties.Objects[I]) + else + if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then + Result := Add(Name, Default); + end + else + if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then + begin + Result := Add(Name, Default); + end; +end; + +function TJclSimpleXMLProps.GetItemNamed(const Name: string): TJclSimpleXMLProp; +begin + Result := GetItemNamedDefault(Name, ''); +end; + +function TJclSimpleXMLProps.GetSimpleXML: TJclSimpleXML; +begin + if FParent <> nil then + Result := FParent.SimpleXML + else + Result := nil; +end; + +function TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64; +var + Prop: TJclSimpleXMLProp; +begin + Prop := GetItemNamedDefault(Name, IntToStr(Default)); + if Prop = nil then + Result := Default + else + Result := Prop.IntValue; +end; + +procedure TJclSimpleXMLProps.LoadFromStringStream(StringStream: TJclStringStream); +// +//Stop on / or ? or > +type + TPosType = ( + ptWaiting, + ptReadingName, + ptStartingContent, + ptReadingValue, + ptSpaceBeforeEqual + ); +var + lPos: TPosType; + lName, lValue, lNameSpace: TUCS4Array; + sValue: string; + lPropStart: UCS4; + Ch: UCS4; +begin + SetLength(lValue, 0); + SetLength(lNameSpace, 0); + SetLength(lName, 0); + lPropStart := Ord(NativeSpace); + lPos := ptWaiting; + + // We read from a stream, thus replacing the existing properties + Clear; + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + ptWaiting: //We are waiting for a property + begin + if UnicodeIsWhiteSpace(Ch) then + StringStream.ReadUCS4(Ch) + else + if UnicodeIsIdentifierStart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord('_')) then + begin + StringStream.ReadUCS4(Ch); + lName := UCS4Array(Ch); + SetLength(lNameSpace, 0); + lPos := ptReadingName; + end + else + if (Ch = Ord('/')) or (Ch = Ord('>')) or (Ch = Ord('?')) then + // end of properties + Break + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptReadingName: //We are reading a property name + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + begin + UCS4ArrayConcat(lName, Ch); + end + else + if Ch = Ord(':') then + begin + lNameSpace := lName; + SetLength(lName, 0); + end + else + if Ch = Ord('=') then + lPos := ptStartingContent + else + if UnicodeIsWhiteSpace(Ch) then + lPos := ptSpaceBeforeEqual + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptStartingContent: //We are going to start a property content + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsWhiteSpace(Ch) then + // ignore white space + else + if (Ch = Ord('''')) or (Ch = Ord('"')) then + begin + lPropStart := Ch; + SetLength(lValue, 0); + lPos := ptReadingValue; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte_), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptReadingValue: //We are reading a property + begin + StringStream.ReadUCS4(Ch); + if Ch = lPropStart then + begin + sValue := UCS4ToString(lValue); + if GetSimpleXML <> nil then + GetSimpleXML.DoDecodeValue(sValue); + with Add(UCS4ToString(lName), sValue) do + NameSpace := UCS4ToString(lNameSpace); + lPos := ptWaiting; + end + else + UCS4ArrayConcat(lValue, Ch); + end; + + ptSpaceBeforeEqual: // We are reading the white space between a property name and the = sign + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsWhiteSpace(Ch) then + // more white space, stay in this state and ignore + else + if Ch = Ord('=') then + lPos := ptStartingContent + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + else + Assert(False, RsEUnexpectedValueForLPos); + end; + end; +end; + +procedure TJclSimpleXMLProps.SaveToStringStream(StringStream: TJclStringStream); +var + I: Integer; +begin + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream); +end; + +function TJclSimpleXMLProps.Value(const Name, Default: string): string; +var + Prop: TJclSimpleXMLProp; +begin + Result := ''; + Prop := GetItemNamedDefault(Name, Default); + if Prop = nil then + Result := Default + else + Result := Prop.Value; +end; + +//=== { TJclSimpleXMLProp } ================================================== + +constructor TJclSimpleXMLProp.Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); +begin + inherited Create(AName, AValue); + FParent := AParent; +end; + +function TJclSimpleXMLProp.GetSimpleXML: TJclSimpleXML; +begin + if FParent <> nil then + Result := FParent.SimpleXML + else + Result := nil; +end; + +procedure TJclSimpleXMLProp.SaveToStringStream(StringStream: TJclStringStream); +var + AEncoder: TJclSimpleXML; + Tmp: string; +begin + AEncoder := GetSimpleXML; + Tmp := Value; + if AEncoder <> nil then + AEncoder.DoEncodeValue(Tmp); + if NameSpace <> '' then + Tmp := Format(' %s:%s="%s"', [NameSpace, Name, Tmp]) + else + Tmp := Format(' %s="%s"', [Name, tmp]); + StringStream.WriteString(Tmp, 1, Length(Tmp)); +end; + +procedure TJclSimpleXMLProp.SetName(const Value: string); +begin + if (Value <> Name) and (Value <> '') then + begin + if (Parent <> nil) and (Name <> '') then + FParent.Properties.DoItemRename(Self, Value); + inherited SetName(Value); + end; +end; + +//=== { TJclSimpleXMLElemClassic } =========================================== + +procedure TJclSimpleXMLElemClassic.LoadFromStringStream(StringStream: TJclStringStream); +// +//foorbeuhbar +//foorbeuhbar +type + TReadStatus = (rsWaitingOpeningTag, rsOpeningName, rsTypeOpeningTag, rsEndSingleTag, + rsWaitingClosingTag1, rsWaitingClosingTag2, rsClosingName); +var + lPos: TReadStatus; + St, lName, lNameSpace: TUCS4Array; + sValue: string; + Ch: UCS4; +begin + SetLength(St, 0); + SetLength(lName, 0); + SetLength(lNameSpace, 0); + sValue := ''; + lPos := rsWaitingOpeningTag; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + rsWaitingOpeningTag: // wait beginning of tag + if Ch = Ord('<') then + lPos := rsOpeningName // read name + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsOpeningName: + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + UCS4ArrayConcat(St, Ch) + else + if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then + begin + lNameSpace := St; + SetLength(st, 0); + end + else + if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then + // whitespace after "<" (no name) + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) + else + if UnicodeIsWhiteSpace(Ch) then + begin + lName := St; + SetLength(St, 0); + Properties.LoadFromStringStream(StringStream); + lPos := rsTypeOpeningTag; + end + else + if Ch = Ord('/') then // single tag + begin + lName := St; + lPos := rsEndSingleTag + end + else + if Ch = Ord('>') then // 2 tags + begin + lName := St; + SetLength(St, 0); + //Load elements + Items.LoadFromStringStream(StringStream); + lPos := rsWaitingClosingTag1; + end + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsTypeOpeningTag: + if UnicodeIsWhiteSpace(Ch) then + // nothing, spaces after name or properties + else + if Ch = Ord('/') then + lPos := rsEndSingleTag // single tag + else + if Ch = Ord('>') then // 2 tags + begin + //Load elements + Items.LoadFromStringStream(StringStream); + lPos := rsWaitingClosingTag1; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsEndSingleTag: + if Ch = Ord('>') then + Break + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsWaitingClosingTag1: + if UnicodeIsWhiteSpace(Ch) then + // nothing, spaces before closing tag + else + if Ch = Ord('<') then + lPos := rsWaitingClosingTag2 + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsWaitingClosingTag2: + if Ch = Ord('/') then + lPos := rsClosingName + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsClosingName: + if UnicodeIsWhiteSpace(Ch) or (Ch = Ord('>')) then + begin + if Length(lNameSpace) > 0 then + begin + if not StrSame(UCS4ToString(lNameSpace) + ':' + UCS4ToString(lName), UCS4ToString(St)) then + FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); + end + else + if not UCS4ArrayEquals(lName, St) then + FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); + //Set value if only one sub element + //This might reduce speed, but this is for compatibility issues + if (Items.Count = 1) and (Items[0] is TJclSimpleXMLElemText) then + begin + sValue := Items[0].Value; + Items.Clear; + // free some memory + FreeAndNil(FItems); + end; + Break; + end + else + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord(':')) then + UCS4ArrayConcat(St, Ch) + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + end; + end; + + Name := UCS4ToString(lName); + if SimpleXML <> nil then + SimpleXML.DoDecodeValue(sValue); + Value := sValue; + NameSpace := UCS4ToString(lNameSpace); + + if SimpleXML <> nil then + begin + SimpleXML.DoTagParsed(Name); + SimpleXML.DoValueParsed(Name, sValue); + end; +end; + +procedure TJclSimpleXMLElemClassic.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St, AName, tmp: string; + LevelAdd: string; + AutoIndent: Boolean; +begin + if(NameSpace <> '') then + AName := NameSpace + ':' + Name + else + AName := Name; + + if Name <> '' then + begin + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(AName); + St := Level + '<' + AName; + + StringStream.WriteString(St, 1, Length(St)); + if Assigned(FProps) then + FProps.SaveToStringStream(StringStream); + end; + + AutoIndent := (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options); + + if (ItemCount = 0) then + begin + tmp := Value; + if (Name <> '') then + begin + if Value = '' then + begin + if AutoIndent then + St := '/>' + sLineBreak + else + St := '/>'; + end + else + begin + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(tmp); + if AutoIndent then + St := '>' + tmp + '' + sLineBreak + else + St := '>' + tmp + ''; + end; + StringStream.WriteString(St, 1, Length(St)); + end; + end + else + begin + if (Name <> '') then + begin + if AutoIndent then + St := '>' + sLineBreak + else + St := '>'; + StringStream.WriteString(St, 1, Length(St)); + end; + if AutoIndent then + begin + LevelAdd := SimpleXML.IndentString; + end; + FItems.SaveToStringStream(StringStream, Level + LevelAdd); + if Name <> '' then + begin + if AutoIndent then + St := Level + '' + sLineBreak + else + St := Level + ''; + StringStream.WriteString(St, 1, Length(St)); + end; + end; + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemComment } =========================================== + +procedure TJclSimpleXMLElemComment.LoadFromStringStream(StringStream: TJclStringStream); +// +const + CS_START_COMMENT = ''; +var + lPos: Integer; + St: TUCS4Array; + Ch: UCS4; + lOk: Boolean; +begin + SetLength(St, 0); + lPos := 1; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..4: //' + sLineBreak + else + St := '-->'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemCData } ============================================= + +procedure TJclSimpleXMLElemCData.LoadFromStringStream(StringStream: TJclStringStream); +//Hello, world!]]> +const + CS_START_CDATA = ''; +var + lPos: Integer; + St: TUCS4Array; + Ch: UCS4; + lOk: Boolean; +begin + SetLength(St, 0); + lPos := 1; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..9: // + if Ch = Ord(CS_STOP_CDATA[lPos]) then + begin + lOk := True; + Break; //End if + end + else + // ]]] + if Ch = Ord(CS_STOP_CDATA[lPos-1]) then + UCS4ArrayConcat(St, Ord(']')) + else + begin + UCS4ArrayConcat(St, Ord(']')); + UCS4ArrayConcat(St, Ord(']')); + UCS4ArrayConcat(St, Ch); + Dec(lPos, 2); + end; + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCDATAUnexpectedEndOfData), [StringStream.PeekPosition]); + + Value := UCS4ToString(St); + Name := ''; + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', Value); +end; + +procedure TJclSimpleXMLElemCData.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St: string; +begin + St := Level + ' '' then + StringStream.WriteString(Value, 1, Length(Value)); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := ']]>' + sLineBreak + else + St := ']]>'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemText } ============================================== + +procedure TJclSimpleXMLElemText.LoadFromStringStream(StringStream: TJclStringStream); +var + Ch: UCS4; + USt: TUCS4Array; + St, TrimValue: string; +begin + SetLength(USt, 0); + St := ''; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case Ch of + Ord('<'): + //Quit text + Break; + else + begin + StringStream.ReadUCS4(Ch); + UCS4ArrayConcat(USt, Ch); + end; + end; + end; + + St := UCS4ToString(USt); + + if Assigned(SimpleXML) then + begin + SimpleXML.DoDecodeValue(St); + + TrimValue := St; + if sxoTrimPrecedingTextWhitespace in SimpleXML.Options then + TrimValue := TrimLeft(TrimValue); + if sxoTrimFollowingTextWhitespace in SimpleXML.Options then + TrimValue := TrimRight(TrimValue); + if (TrimValue <> '') or not (sxoKeepWhitespace in SimpleXML.Options) then + St := TrimValue; + end; + + Value := St; + Name := ''; + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', St); +end; + +procedure TJclSimpleXMLElemText.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St, tmp: string; +begin + // should never be used + if Value <> '' then + begin + tmp := Value; + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(tmp); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := Level + tmp + sLineBreak + else + St := Level + tmp; + StringStream.WriteString(St, 1, Length(St)); + end; + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemProcessingInstruction } ============================= + +procedure TJclSimpleXMLElemProcessingInstruction.LoadFromStringStream( + StringStream: TJclStringStream); +type + TReadStatus = (rsWaitingOpeningTag, rsOpeningTag, rsOpeningName, rsEndTag1, rsEndTag2); +var + lPos: TReadStatus; + lOk: Boolean; + St, lName, lNameSpace: TUCS4Array; + Ch: UCS4; +begin + SetLength(St, 0); + SetLength(lName, 0); + SetLength(lNameSpace, 0); + lPos := rsWaitingOpeningTag; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + rsWaitingOpeningTag: // wait beginning of tag + if Ch = Ord('<') then + lPos := rsOpeningTag + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsOpeningTag: + if Ch = Ord('?') then + lPos := rsOpeningName // read name + else + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsOpeningName: + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + UCS4ArrayConcat(St, Ch) + else + if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then + begin + lNameSpace := St; + SetLength(St, 0); + end + else + if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then + // whitespace after "<" (no name) + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) + else + if UnicodeIsWhiteSpace(Ch) then + begin + lName := St; + SetLength(St, 0); + Properties.LoadFromStringStream(StringStream); + lPos := rsEndTag1; + end + else + if Ch = Ord('?') then + begin + lName := St; + lPos := rsEndTag2; + end + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsEndTag1: + if Ch = Ord('?') then + lPos := rsEndTag2 + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsEndTag2: + if Ch = Ord('>') then + begin + lOk := True; + Break; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); + + Name := UCS4ToString(lName); + NameSpace := UCS4ToString(lNameSpace); +end; + +procedure TJclSimpleXMLElemProcessingInstruction.SaveToStringStream( + StringStream: TJclStringStream; const Level: string); +var + St: string; +begin + St := Level + ' '' then + St := St + NameSpace + ':' + Name + else + St := St + Name; + StringStream.WriteString(St, 1, Length(St)); + if Assigned(FProps) then + FProps.SaveToStringStream(StringStream); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := '?>' + sLineBreak + else + St := '?>'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemHeader } ============================================ + +constructor TJclSimpleXMLElemHeader.Create; +begin + inherited Create; + + Name := 'xml'; +end; + +function TJclSimpleXMLElemHeader.GetEncoding: string; +var + ASimpleXML: TJclSimpleXML; + DefaultCodePage: Word; +begin + ASimpleXML := SimpleXML; + if Assigned(ASimpleXML) then + begin + DefaultCodePage := ASimpleXML.CodePage; + {$IFDEF MSWINDOWS} + if DefaultCodePage = CP_ACP then + DefaultCodePage := GetAcp; + {$ENDIF MSWINDOWS} + end + else + {$IFDEF UNICODE} + DefaultCodePage := CP_UTF16LE; + {$ELSE ~UNICODE} + {$IFDEF MSWINDOWS} + DefaultCodePage := GetACP; + {$ELSE ~MSWINDOWS} + DefaultCodePage := 1252; + {$ENDIF ~MSWINDOWS} + {$ENDIF ~UNICODE} + Result := Properties.Value('encoding', CharsetNameFromCodePage(DefaultCodePage)); +end; + +function TJclSimpleXMLElemHeader.GetStandalone: Boolean; +begin + Result := Properties.Value('standalone') = 'yes'; +end; + +function TJclSimpleXMLElemHeader.GetVersion: string; +begin + Result := Properties.Value('version', '1.0'); +end; + +procedure TJclSimpleXMLElemHeader.LoadFromStringStream(StringStream: TJclStringStream); +// +var + CodePage: Word; + EncodingProp: TJclSimpleXMLProp; +begin + inherited LoadFromStringStream(StringStream); + + if Assigned(FProps) then + EncodingProp := FProps.ItemNamed['encoding'] + else + EncodingProp := nil; + if Assigned(EncodingProp) and (EncodingProp.Value <> '') then + CodePage := CodePageFromCharsetName(EncodingProp.Value) + else + CodePage := CP_ACP; + + // set current stringstream codepage + if StringStream is TJclAutoStream then + TJclAutoStream(StringStream).CodePage := CodePage + else + if StringStream is TJclAnsiStream then + TJclAnsiStream(StringStream).CodePage := CodePage + else + if not (StringStream is TJclUTF8Stream) and not (StringStream is TJclUTF16Stream) then + Error(LoadResString(@RsENoCharset)); +end; + +procedure TJclSimpleXMLElemHeader.SaveToStringStream( + StringStream: TJclStringStream; const Level: string); +begin + SetVersion(GetVersion); + SetEncoding(GetEncoding); + SetStandalone(GetStandalone); + + inherited SaveToStringStream(StringStream, Level); +end; + +procedure TJclSimpleXMLElemHeader.SetEncoding(const Value: string); +var + Prop: TJclSimpleXMLProp; +begin + Prop := Properties.ItemNamed['encoding']; + if Assigned(Prop) then + Prop.Value := Value + else + Properties.Add('encoding', Value); +end; + +procedure TJclSimpleXMLElemHeader.SetStandalone(const Value: Boolean); +var + Prop: TJclSimpleXMLProp; +const + BooleanValues: array [Boolean] of string = ('no', 'yes'); +begin + Prop := Properties.ItemNamed['standalone']; + if Assigned(Prop) then + Prop.Value := BooleanValues[Value] + else + Properties.Add('standalone', BooleanValues[Value]); +end; + +procedure TJclSimpleXMLElemHeader.SetVersion(const Value: string); +var + Prop: TJclSimpleXMLProp; +begin + Prop := Properties.ItemNamed['version']; + if Assigned(Prop) then + Prop.Value := Value + else + // Various XML parsers (including MSIE, Firefox) require the "version" to be the first + Properties.Insert(0, 'version', Value); +end; + +//=== { TJclSimpleXMLElemDocType } =========================================== + +procedure TJclSimpleXMLElemDocType.LoadFromStringStream(StringStream: TJclStringStream); +{ + + +' > +%xx; +]> + + +} +const + CS_START_DOCTYPE = ''); + SetLength(St, 0); + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..9: // or > + if lChar = Ch then + begin + if lChar = Ord('>') then + begin + lOk := True; + Break; //This is the end + end + else + begin + UCS4ArrayConcat(St, Ch); + lChar := Ord('>'); + end; + end + else + begin + UCS4ArrayConcat(St, Ch); + if Ch = Ord('[') then + lChar := Ord(']'); + end; + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); + + Name := ''; + Value := StrTrimCharsLeft(UCS4ToString(St), CharIsWhiteSpace); + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', Value); +end; + +procedure TJclSimpleXMLElemDocType.SaveToStringStream(StringStream: TJclStringStream; + const Level: string); +var + St: string; +begin + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := Level + '' + sLineBreak + else + St := Level + ''; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemsPrologEnumerator } ================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLElemsPrologEnumerator.Create(AList: TJclSimpleXMLElemsProlog); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLElemsPrologEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLElemsPrologEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLElemsProlog } =========================================== + +constructor TJclSimpleXMLElemsProlog.Create(ASimpleXML: TJclSimpleXML); +var + CaseSensitive: Boolean; +begin + inherited Create; + FSimpleXML := ASimpleXML; + CaseSensitive := Assigned(ASimpleXML) and (sxoCaseSensitive in ASimpleXML.Options); + FElems := TJclSimpleItemHashedList.Create(CaseSensitive); +end; + +destructor TJclSimpleXMLElemsProlog.Destroy; +begin + Clear; + FreeAndNil(FElems); + inherited Destroy; +end; + +procedure TJclSimpleXMLElemsProlog.Clear; +begin + FElems.Clear; +end; + +function TJclSimpleXMLElemsProlog.GetCount: Integer; +begin + Result := FElems.Count; +end; + +function TJclSimpleXMLElemsProlog.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); +end; + +procedure TJclSimpleXMLElemsProlog.LoadFromStringStream(StringStream: TJclStringStream); +{ + + +]> +Hello, world! + + Hello, world! +} +var + lPos: Integer; + St: TUCS4Array; + lEnd: Boolean; + lElem: TJclSimpleXMLElem; + Ch: UCS4; +begin + SetLength(St, 0); + lPos := 0; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + 0: //We are waiting for a tag and thus avoiding spaces and any BOM + begin + if UnicodeIsWhiteSpace(Ch) then + // still waiting + else + if Ch = Ord('<') then + begin + lPos := 1; + St := UCS4Array(Ch); + end + else + FmtError(LoadResString(@RsEInvalidDocumentUnexpectedTextInFile), [StringStream.PeekPosition]); + end; + 1: //We are trying to determine the kind of the tag + begin + lElem := nil; + lEnd := False; + + if not UCS4ArrayEquals(St, ' 3) and (St[1] = Ord('?')) and UnicodeIsWhiteSpace(St[High(St)]) then + lElem := TJclSimpleXMLElemProcessingInstruction.Create(SimpleXML) + else + if (Length(St) > 1) and (St[1] <> Ord('!')) and (St[1] <> Ord('?')) then + lEnd := True; + + if lEnd then + Break + else + if lElem <> nil then + begin + FElems.Add(lElem); + lElem.LoadFromStringStream(StringStream); + SetLength(St, 0); + lPos := 0; + end; + end; + end; + end; +end; + +procedure TJclSimpleXMLElemsProlog.SaveToStringStream(StringStream: TJclStringStream); +var + I: Integer; +begin + FindHeader; + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream, ''); +end; + +function VarXML: TVarType; +begin + Result := XMLVariant.VarType; +end; + +procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); +begin + TVarData(ADest).vType := VarXML; + TVarData(ADest).vAny := AXML; +end; + +function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; +begin + XMLCreateInto(Result, AXML); +end; + +function XMLCreate: Variant; +begin + XMLCreateInto(Result, TJclSimpleXMLElemClassic.Create(nil)); +end; + +//=== { TXMLVariant } ======================================================== + +procedure TXMLVariant.CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); +var + StorageStream: TStringStream; + ConversionString: TJclStringStream; +begin + if Source.vType = VarType then + begin + case AVarType of + varOleStr: + begin + StorageStream := TStringStream.Create(''); + try + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataFromOleStr(Dest, StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + varString: + begin + StorageStream := TStringStream.Create(''); + try + {$IFDEF SUPPORTS_UNICODE} + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + {$ELSE ~SUPPORTS_UNICODE} + ConversionString := TJclAnsiStream.Create(StorageStream, False); + {$ENDIF ~SUPPORTS_UNICODE} + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataFromStr(Dest, StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + {$IFDEF SUPPORTS_UNICODE_STRING} + varUString: + begin + StorageStream := TStringStream.Create(''); + try + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataClear(Dest); + Dest.VUString := nil; + Dest.VType := varUString; + UnicodeString(Dest.VUString) := UnicodeString(StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + {$ENDIF SUPPORTS_UNICODE_STRING} + else + RaiseCastError; + end; + end + else + inherited CastTo(Dest, Source, AVarType); +end; + +procedure TXMLVariant.Clear(var V: TVarData); +begin + V.vType := varEmpty; + V.vAny := nil; +end; + +procedure TXMLVariant.Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); +begin + if Indirect and VarDataIsByRef(Source) then + VarDataCopyNoInd(Dest, Source) + else + begin + Dest.vType := Source.vType; + Dest.vAny := Source.vAny; + end; +end; + +function TXMLVariant.DoFunction(var Dest: TVarData; const V: TVarData; + const Name: string; const Arguments: TVarDataArray): Boolean; +var + VXML, LXML: TJclSimpleXMLElem; + VElems: TJclSimpleXMLElems; + I, J, K: Integer; +begin + Result := False; + if (Length(Arguments) = 1) and (Arguments[0].vType in [vtInteger, vtExtended]) then + begin + VXML := TJclSimpleXMLElem(V.VAny); + K := Arguments[0].vInteger; + J := 0; + + if (K > 0) and VXML.HasItems then + begin + VElems := VXML.Items; + for I := 0 to VElems.Count - 1 do + if UpperCase(VElems.Item[I].Name) = Name then + begin + Inc(J); + if J = K then + Break; + end; + end; + + if (J = K) and (J < VXML.ItemCount) then + begin + LXML := VXML.Items[J]; + if LXML <> nil then + begin + Dest.vType := VarXML; + Dest.vAny := Pointer(LXML); + Result := True; + end + end; + end +end; + +function TXMLVariant.GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; +var + VXML, LXML: TJclSimpleXMLElem; + lProp: TJclSimpleXMLProp; +begin + Result := False; + VXML := TJclSimpleXMLElem(V.VAny); + if VXML.HasItems then + begin + LXML := VXML.Items.ItemNamed[Name]; + if LXML <> nil then + begin + Dest.vType := VarXML; + Dest.vAny := Pointer(LXML); + Result := True; + end; + end; + if (not Result) and VXML.HasProperties then + begin + lProp := VXML.Properties.ItemNamed[Name]; + if lProp <> nil then + begin + VarDataFromOleStr(Dest, lProp.Value); + Result := True; + end; + end; +end; + +function TXMLVariant.IsClear(const V: TVarData): Boolean; +var + VXML: TJclSimpleXMLElem; +begin + VXML := TJclSimpleXMLElem(V.VAny); + Result := (VXML = nil) or (not VXML.HasItems); +end; + +function TXMLVariant.SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; + + function GetStrValue: string; + begin + try + Result := Value.VOleStr; + except + Result := ''; + end; + end; + +var + VXML, LXML: TJclSimpleXMLElem; + lProp: TJclSimpleXMLProp; +begin + Result := False; + VXML := TJclSimpleXMLElem(V.VAny); + if VXML.HasItems then + begin + LXML := VXML.Items.ItemNamed[Name]; + if LXML <> nil then + begin + LXML.Value := GetStrValue; + Result := True; + end; + end; + if (not Result) and VXML.HasProperties then + begin + lProp := VXML.Properties.ItemNamed[Name]; + if lProp <> nil then + begin + lProp.Value := GetStrValue; + Result := True; + end; + end; +end; + +procedure TJclSimpleXMLElemsProlog.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +procedure TJclSimpleXMLElemsProlog.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +procedure TJclSimpleXML.SetIndentString(const Value: string); +begin + // test if the new value is only made of spaces or tabs + if not StrContainsChars(Value, CharIsWhiteSpace, True) then + Exit; + FIndentString := Value; +end; + +procedure TJclSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic); +begin + if Value <> FRoot then + begin +// FRoot.FSimpleXML := nil; + FRoot := Value; +// FRoot.FSimpleXML := Self; + end; +end; + +function TJclSimpleXMLElemsProlog.GetEncoding: string; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.Encoding + else + Result := 'UTF-8'; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLElemsProlog.GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; +begin + Result := TJclSimpleXMLElemsPrologEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLElemsProlog.GetStandAlone: Boolean; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.StandAlone + else + Result := False; +end; + +function TJclSimpleXMLElemsProlog.GetVersion: string; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.Version + else + Result := '1.0'; +end; + +procedure TJclSimpleXMLElemsProlog.SetEncoding(const Value: string); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.Encoding := Value; +end; + +procedure TJclSimpleXMLElemsProlog.SetStandAlone(const Value: Boolean); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.StandAlone := Value; +end; + +procedure TJclSimpleXMLElemsProlog.SetVersion(const Value: string); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.Version := Value; +end; + +function TJclSimpleXMLElemsProlog.FindHeader: TJclSimpleXMLElem; +var + I: Integer; +begin + for I := 0 to Count - 1 do + if Item[I] is TJclSimpleXMLElemHeader then + begin + Result := Item[I]; + Exit; + end; + // (p3) if we get here, an xml header was not found + Result := TJclSimpleXMLElemHeader.Create(SimpleXML); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemSheet.Create('xml-stylesheet'); + Result.Properties.Add('type',AType); + Result.Properties.Add('href',AHRef); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemMSOApplication.Create('mso-application'); + Result.Properties.Add('progid',AProgId); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemComment.Create('', AValue); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddDocType(const AValue: string): TJclSimpleXMLElemDocType; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemDocType.Create('', AValue); + FElems.Add(Result); +end; + +initialization + {$IFDEF UNITVERSIONING} + RegisterUnitVersion(HInstance, UnitVersioning); + {$ENDIF UNITVERSIONING} + +finalization + FreeAndNil(GlobalXMLVariant); + {$IFDEF UNITVERSIONING} + UnregisterUnitVersion(HInstance); + {$ENDIF UNITVERSIONING} + +end. From 3a091524d80f9ad6147cdc24d672022badf23af7 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 13:17:56 +0400 Subject: [PATCH 02/12] Faster JclStringList.Join - via StringBuilder --- jcl/source/common/JclStringLists.pas | 2896 +++++++++++++------------- 1 file changed, 1454 insertions(+), 1442 deletions(-) diff --git a/jcl/source/common/JclStringLists.pas b/jcl/source/common/JclStringLists.pas index 7218e37b95..b47bf4526c 100644 --- a/jcl/source/common/JclStringLists.pas +++ b/jcl/source/common/JclStringLists.pas @@ -1,1442 +1,1454 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 NewStringListUnit.pas. } -{ } -{ The Initial Developer of the Original Code is Romullo Sousa. } -{ Portions created by Romullo Sousa are Copyright (C) Romullo Sousa. All rights reserved. } -{ } -{ Contributor(s): } -{ Romullo Sousa (romullobr) } -{ Leo Simas (Leh_U) } -{ } -{**************************************************************************************************} -{ } -{ This unit contains several improvements of the standard TStringList. } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -unit JclStringLists; - -{$I jcl.inc} - -interface - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Winapi.Windows, - {$ENDIF MSWINDOWS} - System.Variants, - System.Classes, System.SysUtils, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF MSWINDOWS} - Variants, - Classes, SysUtils, - {$ENDIF ~HAS_UNITSCOPE} - JclBase, - JclPCRE; - -{$DEFINE HAS_TSTRINGS_COMPARESTRINGS} -{$IFDEF FPC} - {$UNDEF HAS_TSTRINGS_COMPARESTRINGS} -{$ENDIF FPC} - -type - EJclStringListError = class(EJclError); - - IJclStringList = interface; - - TJclStringListObjectsMode = (omNone, omObjects, omVariants, omInterfaces); - - TJclStringListSortCompare = function(List: IJclStringList; Index1, Index2: Integer): Integer; - - IJclStringList = interface(IInterface) - ['{8DC5B71C-4756-404D-8636-7872CD299796}'] - { From TStrings/TStringList } - function Add(const S: string): Integer; overload; - function AddObject(const S: string; AObject: TObject): Integer; - function Get(Index: Integer): string; - function GetCapacity: Integer; - function GetCount: Integer; - function GetObjects(Index: Integer): TObject; - function GetTextStr: string; - function GetValue(const Name: string): string; - {$IFDEF FPC} - function Find(const S: string; out Index: Integer): Boolean; - {$ELSE ~FPC} - function Find(const S: string; var Index: Integer): Boolean; - {$ENDIF ~FPC} - function IndexOf(const S: string): Integer; - function GetCaseSensitive: Boolean; - function GetDuplicates: TDuplicates; - function GetOnChange: TNotifyEvent; - function GetOnChanging: TNotifyEvent; - function GetSorted: Boolean; - function Equals(Strings: TStrings): Boolean; - function IndexOfName(const Name: string): Integer; - function IndexOfObject(AObject: TObject): Integer; - function LoadFromFile(const FileName: string): IJclStringList; - function LoadFromStream(Stream: TStream): IJclStringList; - function SaveToFile(const FileName: string): IJclStringList; - function SaveToStream(Stream: TStream): IJclStringList; - function GetCommaText: string; - function GetDelimitedText: string; - function GetDelimiter: Char; - function GetName(Index: Integer): string; - {$IFDEF COMPILER7_UP} - function GetNameValueSeparator: Char; - function GetValueFromIndex(Index: Integer): string; - {$ENDIF COMPILER7_UP} - function GetQuoteChar: Char; - procedure SetCommaText(const Value: string); - procedure SetDelimitedText(const Value: string); - procedure SetDelimiter(const Value: Char); - {$IFDEF COMPILER7_UP} - procedure SetNameValueSeparator(const Value: Char); - procedure SetValueFromIndex(Index: Integer; const Value: string); - {$ENDIF COMPILER7_UP} - procedure SetQuoteChar(const Value: Char); - procedure AddStrings(Strings: TStrings); overload; - procedure SetObjects(Index: Integer; const Value: TObject); - procedure Put(Index: Integer; const S: string); - procedure SetCapacity(NewCapacity: Integer); - procedure SetTextStr(const Value: string); - procedure SetValue(const Name, Value: string); - procedure SetCaseSensitive(const Value: Boolean); - procedure SetDuplicates(const Value: TDuplicates); - procedure SetOnChange(const Value: TNotifyEvent); - procedure SetOnChanging(const Value: TNotifyEvent); - procedure SetSorted(const Value: Boolean); - property Count: Integer read GetCount; - property Strings[Index: Integer]: string read Get write Put; default; - property Text: string read GetTextStr write SetTextStr; - property Objects[Index: Integer]: TObject read GetObjects write SetObjects; - property Capacity: Integer read GetCapacity write SetCapacity; - property Values[const Name: string]: string read GetValue write SetValue; - property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; - property Sorted: Boolean read GetSorted write SetSorted; - property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read GetOnChange write SetOnChange; - property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; - property DelimitedText: string read GetDelimitedText write SetDelimitedText; - property Delimiter: Char read GetDelimiter write SetDelimiter; - property Names[Index: Integer]: string read GetName; - property QuoteChar: Char read GetQuoteChar write SetQuoteChar; - property CommaText: string read GetCommaText write SetCommaText; - {$IFDEF COMPILER7_UP} - property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; - {$ENDIF COMPILER7_UP} - { New } - function Assign(Source: TPersistent): IJclStringList; - function LoadExeParams: IJclStringList; - function Exists(const S: string): Boolean; - function ExistsName(const S: string): Boolean; - function DeleteBlanks: IJclStringList; - function KeepIntegers: IJclStringList; - function DeleteIntegers: IJclStringList; - function ReleaseInterfaces: IJclStringList; - function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; - function Clone: IJclStringList; - function Insert(Index: Integer; const S: string): IJclStringList; - function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; - function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; - function SortAsInteger: IJclStringList; - function SortByName: IJclStringList; - function Delete(AIndex: Integer): IJclStringList; overload; - function Delete(const AString: string): IJclStringList; overload; - function Exchange(Index1, Index2: Integer): IJclStringList; - function Add(const A: array of const): IJclStringList; overload; - function AddStrings(const A: array of string): IJclStringList; overload; - function BeginUpdate: IJclStringList; - function EndUpdate: IJclStringList; - function Trim: IJclStringList; - function Join(const ASeparator: string = ''): string; - function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; - function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; - function Last: string; - function First: string; - function LastIndex: Integer; - function Clear: IJclStringList; - {$IFDEF JCL_PCRE} - function DeleteRegEx(const APattern: string): IJclStringList; - function KeepRegEx(const APattern: string): IJclStringList; - function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - {$ENDIF JCL_PCRE} - function GetStringsRef: TStrings; - function ConfigAsSet: IJclStringList; - function Delimit(const ADelimiter: string): IJclStringList; - function GetInterfaceByIndex(Index: Integer): IInterface; - function GetLists(Index: Integer): IJclStringList; - function GetVariants(AIndex: Integer): Variant; - function GetKeyInterface(const AKey: string): IInterface; - function GetKeyObject(const AKey: string): TObject; - function GetKeyVariant(const AKey: string): Variant; - function GetKeyList(const AKey: string): IJclStringList; - function GetObjectsMode: TJclStringListObjectsMode; - procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); - procedure SetLists(Index: Integer; const Value: IJclStringList); - procedure SetVariants(Index: Integer; const Value: Variant); - procedure SetKeyInterface(const AKey: string; const Value: IInterface); - procedure SetKeyObject(const AKey: string; const Value: TObject); - procedure SetKeyVariant(const AKey: string; const Value: Variant); - procedure SetKeyList(const AKey: string; const Value: IJclStringList); - property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; - property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; - property Variants[Index: Integer]: Variant read GetVariants write SetVariants; - property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; - property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; - property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; - property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; - property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; - end; - -type - TJclInterfacedStringList = class(TStringList, IInterface) - private - FOwnerInterface: IInterface; - public - { IInterface } - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall; - procedure AfterConstruction; override; - end; - - - TJclStringList = class(TJclInterfacedStringList, IInterface, IJclStringList) - private - FObjectsMode: TJclStringListObjectsMode; - FSelfAsInterface: IJclStringList; - {$IFDEF JCL_PCRE} - FLastRegExPattern: string; - FRegEx: TJclRegEx; - {$ENDIF JCL_PCRE} - FCompareFunction: TJclStringListSortCompare; - function CanFreeObjects: Boolean; - {$IFDEF JCL_PCRE} - function MatchRegEx(const S, APattern: string): Boolean; - {$ENDIF JCL_PCRE} - procedure EnsureObjectsMode(AMode: TJclStringListObjectsMode); - protected - FRefCount: Integer; - {$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} - function CompareStrings(const S1, S2: string): Integer; virtual; - {$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} - public - constructor Create; - destructor Destroy; override; - { IInterface } - // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - { IJclStringList } - // function Add(const S: string): Integer; overload; - // function AddObject(const S: string; AObject: TObject): Integer; - // function Get(Index: Integer): string; - // function GetCapacity: Integer; - // function GetCount: Integer; - function GetObjects(Index: Integer): TObject; - // function GetTextStr: string; - function GetValue(const Name: string): string; - // function Find(const S: string; var Index: Integer): Boolean; - // function IndexOf(const S: string): Integer; - function GetCaseSensitive: Boolean; - function GetDuplicates: TDuplicates; - function GetOnChange: TNotifyEvent; - function GetOnChanging: TNotifyEvent; - function GetSorted: Boolean; - // function Equals(Strings: TStrings): Boolean; - // function IndexOfName(const Name: string): Integer; - // function IndexOfObject(AObject: TObject): Integer; - function LoadFromFile(const FileName: string): IJclStringList; reintroduce; - function LoadFromStream(Stream: TStream): IJclStringList; reintroduce; - function SaveToFile(const FileName: string): IJclStringList; reintroduce; - function SaveToStream(Stream: TStream): IJclStringList; reintroduce; - function GetCommaText: string; - function GetDelimitedText: string; - function GetDelimiter: Char; - function GetName(Index: Integer): string; - {$IFDEF COMPILER7_UP} - function GetNameValueSeparator: Char; - function GetValueFromIndex(Index: Integer): string; - {$ENDIF COMPILER7_UP} - function GetQuoteChar: Char; - procedure SetCommaText(const Value: string); - procedure SetDelimitedText(const Value: string); - procedure SetDelimiter(const Value: Char); - {$IFDEF COMPILER7_UP} - procedure SetNameValueSeparator(const Value: Char); - procedure SetValueFromIndex(Index: Integer; const Value: string); - {$ENDIF COMPILER7_UP} - procedure SetQuoteChar(const Value: Char); - // procedure AddStrings(Strings: TStrings); overload; - procedure SetObjects(Index: Integer; const Value: TObject); - // procedure Put(Index: Integer; const S: string); - // procedure SetCapacity(NewCapacity: Integer); - // procedure SetTextStr(const Value: string); - procedure SetValue(const Name, Value: string); - procedure SetCaseSensitive(const Value: Boolean); - procedure SetDuplicates(const Value: TDuplicates); - procedure SetOnChange(const Value: TNotifyEvent); - procedure SetOnChanging(const Value: TNotifyEvent); - procedure SetSorted(const Value: Boolean); - property Count: Integer read GetCount; - property Strings[Index: Integer]: string read Get write Put; default; - property Text: string read GetTextStr write SetTextStr; - property Objects[Index: Integer]: TObject read GetObjects write SetObjects; - property Capacity: Integer read GetCapacity write SetCapacity; - property Values[const Name: string]: string read GetValue write SetValue; - property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; - property Sorted: Boolean read GetSorted write SetSorted; - property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read GetOnChange write SetOnChange; - property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; - property DelimitedText: string read GetDelimitedText write SetDelimitedText; - property Delimiter: Char read GetDelimiter write SetDelimiter; - property Names[Index: Integer]: string read GetName; - property QuoteChar: Char read GetQuoteChar write SetQuoteChar; - property CommaText: string read GetCommaText write SetCommaText; - {$IFDEF COMPILER7_UP} - property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; - {$ENDIF COMPILER7_UP} - { New } - function Assign(Source: TPersistent): IJclStringList; reintroduce; - function LoadExeParams: IJclStringList; - function Exists(const S: string): Boolean; - function ExistsName(const S: string): Boolean; - function DeleteBlanks: IJclStringList; - function KeepIntegers: IJclStringList; - function DeleteIntegers: IJclStringList; - function ReleaseInterfaces: IJclStringList; - function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; - function Clone: IJclStringList; - function Insert(Index: Integer; const S: string): IJclStringList; reintroduce; - function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; reintroduce; - function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; reintroduce; - function SortAsInteger: IJclStringList; - function SortByName: IJclStringList; - function Delete(AIndex: Integer): IJclStringList; reintroduce; overload; - function Delete(const AString: string): IJclStringList; reintroduce; overload; - function Exchange(Index1, Index2: Integer): IJclStringList; reintroduce; - function Add(const A: array of const): IJclStringList; reintroduce; overload; - function AddStrings(const A: array of string): IJclStringList; reintroduce; overload; - function BeginUpdate: IJclStringList; - function EndUpdate: IJclStringList; - function Trim: IJclStringList; - function Join(const ASeparator: string = ''): string; - function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; - function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; - function Last: string; - function First: string; - function LastIndex: Integer; - function Clear: IJclStringList; reintroduce; - {$IFDEF JCL_PCRE} - function DeleteRegEx(const APattern: string): IJclStringList; - function KeepRegEx(const APattern: string): IJclStringList; - function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - {$ENDIF JCL_PCRE} - function GetStringsRef: TStrings; - function ConfigAsSet: IJclStringList; - function Delimit(const ADelimiter: string): IJclStringList; - function GetInterfaceByIndex(Index: Integer): IInterface; - function GetLists(Index: Integer): IJclStringList; - function GetVariants(AIndex: Integer): Variant; - function GetKeyInterface(const AKey: string): IInterface; - function GetKeyObject(const AKey: string): TObject; - function GetKeyVariant(const AKey: string): Variant; - function GetKeyList(const AKey: string): IJclStringList; - function GetObjectsMode: TJclStringListObjectsMode; - procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); - procedure SetLists(Index: Integer; const Value: IJclStringList); - procedure SetVariants(Index: Integer; const Value: Variant); - procedure SetKeyInterface(const AKey: string; const Value: IInterface); - procedure SetKeyObject(const AKey: string; const Value: TObject); - procedure SetKeyVariant(const AKey: string; const Value: Variant); - procedure SetKeyList(const AKey: string; const Value: IJclStringList); - property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; - property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; - property Variants[Index: Integer]: Variant read GetVariants write SetVariants; - property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; - property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; - property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; - property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; - property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; - end; - -function JclStringList: IJclStringList; overload; -function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; -function JclStringListStrings(const A: array of string): IJclStringList; overload; -function JclStringList(const A: array of const): IJclStringList; overload; -function JclStringList(const AText: string): IJclStringList; overload; - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNITSCOPE} - System.TypInfo, - {$ELSE ~HAS_UNITSCOPE} - TypInfo, - {$ENDIF ~HAS_UNITSCOPE} - JclFileUtils, - JclStrings; - -type - TVariantWrapper = class(TObject) - private - FValue: Variant; - end; - - TInterfaceWrapper = class(TObject) - private - FValue: IInterface; - end; - -function JclStringList: IJclStringList; -begin - Result := TJclStringList.Create; -end; - -function JclStringList(const AText: string): IJclStringList; overload; -begin - Result := JclStringList; - Result.Text := AText; -end; - -function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; -begin - Result := JclStringList; - Result.AddStrings(AStrings); -end; - -function JclStringListStrings(const A: array of string): IJclStringList; -begin - Result := JclStringList.AddStrings(A); -end; - -function JclStringList(const A: array of const): IJclStringList; -begin - Result := JclStringList.Add(A); -end; - -//=== { TJclInterfacedStringList } ============================================== - -procedure TJclInterfacedStringList.AfterConstruction; -Var - MyOwner : TPersistent; -begin - inherited; - MyOwner := GetOwner; - if Assigned(MyOwner) then - MyOwner.GetInterface(IUnknown,FOwnerInterface); -end; - - -function TJclInterfacedStringList._AddRef: Integer;stdcall; -begin - if assigned(FOwnerInterface) then - Result := FOwnerInterface._AddRef - else - Result := -1; -end; - - -function TJclInterfacedStringList._Release: Integer;stdcall; -begin - if assigned(FOwnerInterface) then - Result := FOwnerInterface._Release - else - Result := -1; -end; - - -function TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall; -begin - if GetInterface(IID, Obj) then - Result := 0 - else - Result := E_NOINTERFACE; -end; - -//=== { TJclStringList } ===================================================== - -function TJclStringList.Add(const A: array of const): IJclStringList; -const - BoolToStr: array [Boolean] of string[5] = ('false', 'true'); -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := Low(A) to High(A) do - case A[I].VType of - vtInteger: - Add(IntToStr(A[I].VInteger)); - vtBoolean: - Add(string(BoolToStr[A[I].VBoolean])); - vtChar: - Add(string(AnsiString(A[I].VChar))); - vtExtended: - Add(FloatToStr(A[I].VExtended^)); - vtString: - Add(string(A[I].VString^)); - vtPChar: - Add(string(AnsiString(A[I].VPChar))); - vtPWideChar: - Add(string(WideString(A[I].VPWideChar))); - vtObject: - Add(A[I].VObject.ClassName); - vtClass: - Add(A[I].VClass.ClassName); - vtAnsiString: - Add(string(A[I].VAnsiString)); - vtWideString: - Add(string(A[I].VWideString)); - vtCurrency: - Add(CurrToStr(A[I].VCurrency^)); - vtVariant: - Add(string(A[I].VVariant^)); - vtInt64: - Add(IntToStr(A[I].VInt64^)); - {$IFDEF SUPPORTS_UNICODE_STRING} - vtUnicodeString: - Add(string(A[I].VUnicodeString)); - {$ENDIF SUPPORTS_UNICODE_STRING} - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.AddStrings(const A: array of string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := Low(A) to High(A) do - Add(A[I]); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.BeginUpdate: IJclStringList; -begin - inherited BeginUpdate; - Result := FSelfAsInterface; -end; - -function TJclStringList.Clear: IJclStringList; -begin - if CanFreeObjects then - FreeObjects(False); - inherited Clear; - Result := FSelfAsInterface; -end; - -function TJclStringList.EndUpdate: IJclStringList; -begin - inherited EndUpdate; - Result := FSelfAsInterface; -end; - -function TJclStringList.ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar; - AClearBeforeAdd: Boolean): IJclStringList; -var - L, I, X: Integer; -begin - Result := BeginUpdate; - try - if AClearBeforeAdd then - Clear; - I := 1; - L := Length(AText); - while I <= L do - begin - while (I <= L) and (AnsiChar(AText[I]) in ADelims) do - Inc(I); - X := I; - while (I <= L) and not (AnsiChar(AText[I]) in ADelims) do - Inc(I); - if X <> I then - Add(Copy(AText, X, I - X)); - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.First: string; -begin - Result := Strings[0]; -end; - -function TJclStringList.Join(const ASeparator: string): string; -var - I: Integer; -begin - Result := ''; - for I := 0 to LastIndex - 1 do - Result := Result + Strings[I] + ASeparator; - if Count > 0 then - Result := Result + Last; -end; - -function TJclStringList.Last: string; -begin - Result := Strings[LastIndex]; -end; - -function TJclStringList.Split(const AText, ASeparator: string; - AClearBeforeAdd: Boolean = True): IJclStringList; -var - LStartIndex, LEndIndex: Integer; - LLengthSeparator: Integer; -begin - Result := FSelfAsInterface; - if AText <> '' then - begin - Result := BeginUpdate; - try - if AClearBeforeAdd then - Clear; - LLengthSeparator := Length(ASeparator); - LStartIndex := 1; - LEndIndex := StrSearch(ASeparator, AText, LStartIndex); - while LEndIndex > 0 do - begin - Add(Copy(AText, LStartIndex, LEndIndex - LStartIndex)); - LStartIndex := LEndIndex + LLengthSeparator; - LEndIndex := StrSearch(ASeparator, AText, LStartIndex); - end; - Add(Copy(AText, LStartIndex, MaxInt)); - finally - Result := EndUpdate; - end; - end; -end; - -function TJclStringList.Trim: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Strings[I] := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList._AddRef: Integer; -begin - Result := InterlockedIncrement(FRefCount); -end; - -function TJclStringList._Release: Integer; -begin - Result := InterlockedDecrement(FRefCount); - if Result = 1 then - begin - // When there is only one reference, it is the internal reference, - // so we release it. The compiler will call _Release again and - // the object will be destroyed. - FSelfAsInterface := nil; - end - else - if Result = 0 then - Destroy; -end; - -{$IFDEF JCL_PCRE} -function TJclStringList.DeleteRegEx(const APattern: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if MatchRegEx(Strings[I], APattern) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.KeepRegEx(const APattern: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if not MatchRegEx(Strings[I], APattern) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.MatchRegEx(const S, APattern: string): Boolean; -begin - if FRegEx = nil then - FRegEx := TJclRegEx.Create; - if FLastRegExPattern <> APattern then - begin - if CaseSensitive then - FRegEx.Options := FRegEx.Options - [roIgnoreCase] - else - FRegEx.Options := FRegEx.Options + [roIgnoreCase]; - FRegEx.Compile(APattern, False, True); - FLastRegExPattern := APattern; - end; - Result := FRegEx.Match(S); -end; -{$ENDIF JCL_PCRE} - -destructor TJclStringList.Destroy; -begin - if CanFreeObjects then - FreeObjects(False); - {$IFDEF JCL_PCRE} - FreeAndNil(FRegEx); - {$ENDIF JCL_PCRE} - inherited Destroy; -end; - -{$IFDEF JCL_PCRE} -function TJclStringList.Directories(const APattern: string = '*'; - ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - - procedure DoDirectories(const APattern: string); - var - LSearchRec: TSearchRec; - LFullName: string; - LPath: string; - begin - LPath := ExtractFilePath(APattern); - if FindFirst(APattern, faAnyFile, LSearchRec) = 0 then - try - repeat - if (LSearchRec.Attr and faDirectory = 0) or - (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then - Continue; - LFullName := LPath + LSearchRec.Name; - if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then - Add(LFullName); - if ARecursive then - DoDirectories(PathAddSeparator(LFullName) + ExtractFileName(APattern)); - until FindNext(LSearchRec) <> 0; - finally - FindClose(LSearchRec); - end; - end; - -begin - Result := BeginUpdate; - try - if DirectoryExists(APattern) then - DoDirectories(PathAddSeparator(APattern) + '*') - else - DoDirectories(APattern); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Files(const APattern: string = '*'; - ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - - procedure DoFiles(const APattern: string); - var - LSearchRec: TSearchRec; - LFullName: string; - LDirectories: IJclStringList; - LPath: string; - I: Integer; - begin - LPath := ExtractFilePath(APattern); - if FindFirst(APattern, faAnyFile and not faDirectory, LSearchRec) = 0 then - begin - try - repeat - if (LSearchRec.Attr and faDirectory <> 0) or - (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then - Continue; - LFullName := LPath + LSearchRec.Name; - if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then - Add(LFullName); - until FindNext(LSearchRec) <> 0; - finally - FindClose(LSearchRec); - end; - end; - if ARecursive then - begin - LDirectories := JclStringList.Directories(LPath + '*', False); - for I := 0 to LDirectories.LastIndex do - DoFiles(PathAddSeparator(LDirectories[I]) + ExtractFileName(APattern)); - end; - end; - -begin - Result := BeginUpdate; - try - if DirectoryExists(APattern) then - DoFiles(PathAddSeparator(APattern) + '*') - else - DoFiles(APattern); - finally - Result := EndUpdate; - end; -end; -{$ENDIF JCL_PCRE} - -function TJclStringList.LastIndex: Integer; -begin - { The code bellow is more optimized than "Result := Count - 1". } - Result := Count; - Dec(Result); -end; - -constructor TJclStringList.Create; -begin - inherited Create; - if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then - System.Error(reIntfCastError); -end; - -function TJclStringList.GetLists(Index: Integer): IJclStringList; -begin - Result := Interfaces[Index] as IJclStringList; - if Result = nil then - begin - Result := JclStringList; - Interfaces[Index] := Result; - end; -end; - -procedure TJclStringList.SetLists(Index: Integer; const Value: IJclStringList); -begin - Interfaces[Index] := Value; -end; - -function TJclStringList.GetStringsRef: TStrings; -begin - Result := Self; -end; - -function TJclStringList.GetKeyInterface(const AKey: string): IInterface; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Interfaces[I] - else - Result := nil; -end; - -function TJclStringList.GetKeyObject(const AKey: string): TObject; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Objects[I] - else - Result := nil; -end; - -procedure TJclStringList.SetKeyInterface(const AKey: string; const Value: IInterface); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - I := Add(AKey); - Interfaces[I] := Value -end; - -procedure TJclStringList.SetKeyObject(const AKey: string; const Value: TObject); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - AddObject(AKey, Value) - else - Objects[I] := Value; -end; - -function TJclStringList.ConfigAsSet: IJclStringList; -begin - Sorted := True; - Duplicates := dupIgnore; - Result := FSelfAsInterface; -end; - -function TJclStringList.GetKeyVariant(const AKey: string): Variant; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Variants[I] - else - Result := Unassigned; -end; - -procedure TJclStringList.SetKeyVariant(const AKey: string; const Value: Variant); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - I := Add(AKey); - Variants[I] := Value -end; - -function TJclStringList.GetValue(const Name: string): string; -begin - Result := inherited Values[Name]; -end; - -procedure TJclStringList.SetValue(const Name, Value: string); -begin - inherited Values[Name] := Value; -end; - -function TJclStringList.GetInterfaceByIndex(Index: Integer): IInterface; -var - V: TInterfaceWrapper; -begin - if FObjectsMode <> omInterfaces then - EnsureObjectsMode(omInterfaces); - V := TInterfaceWrapper(inherited Objects[Index]); - if V = nil then - Result := nil - else - Result := V.FValue; -end; - -procedure TJclStringList.SetInterfaceByIndex(Index: Integer; const Value: IInterface); -var - V: TInterfaceWrapper; -begin - if FObjectsMode <> omInterfaces then - EnsureObjectsMode(omInterfaces); - V := TInterfaceWrapper(inherited Objects[Index]); - if V = nil then - begin - V := TInterfaceWrapper.Create; - inherited Objects[Index] := V; - end; - V.FValue := Value; -end; - -function TJclStringList.GetObjects(Index: Integer): TObject; -begin - if FObjectsMode <> omObjects then - EnsureObjectsMode(omObjects); - Result := inherited Objects[Index]; -end; - -procedure TJclStringList.SetObjects(Index: Integer; const Value: TObject); -begin - if FObjectsMode <> omObjects then - EnsureObjectsMode(omObjects); - inherited Objects[Index] := Value; -end; - -function TJclStringList.GetVariants(AIndex: Integer): Variant; -var - V: TVariantWrapper; -begin - if FObjectsMode <> omVariants then - EnsureObjectsMode(omVariants); - V := TVariantWrapper(inherited Objects[AIndex]); - if V = nil then - Result := Unassigned - else - Result := V.FValue; -end; - -procedure TJclStringList.SetVariants(Index: Integer; const Value: Variant); -var - V: TVariantWrapper; -begin - if FObjectsMode <> omVariants then - EnsureObjectsMode(omVariants); - V := TVariantWrapper(inherited Objects[Index]); - if V = nil then - begin - V := TVariantWrapper.Create; - inherited Objects[Index] := V; - end; - V.FValue := Value; -end; - -procedure TJclStringList.EnsureObjectsMode(AMode: TJclStringListObjectsMode); -begin - if FObjectsMode <> AMode then - begin - if FObjectsMode <> omNone then - begin - raise EJclStringListError.CreateFmt('Objects cannot be used as "%s" because it has been used as "%s".', - [GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(AMode)), - GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(FObjectsMode))]); - end; - FObjectsMode := AMode; - end; -end; - -function TJclStringList.GetKeyList(const AKey: string): IJclStringList; -begin - Result := KeyInterface[AKey] as IJclStringList; - if Result = nil then - begin - Result := JclStringList; - KeyInterface[AKey] := Result; - end; -end; - -procedure TJclStringList.SetKeyList(const AKey: string; const Value: IJclStringList); -begin - KeyInterface[AKey] := Value; -end; - -function TJclStringList.Delete(AIndex: Integer): IJclStringList; -begin - if CanFreeObjects then - inherited Objects[AIndex].Free; - inherited Delete(AIndex); - Result := FSelfAsInterface; -end; - -function TJclStringList.Delete(const AString: string): IJclStringList; -begin - Result := Delete(IndexOf(AString)); -end; - -function TJclStringList.Exchange(Index1, Index2: Integer): IJclStringList; -begin - inherited Exchange(Index1, Index2); - Result := FSelfAsInterface; -end; - -function LocalSort(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := TJclStringList(List).FCompareFunction(TJclStringList(List).FSelfAsInterface, Index1, Index2); -end; - -function TJclStringList.Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; -begin - FCompareFunction := ACompareFunction; - if not Assigned(ACompareFunction) then - inherited Sort - else - inherited CustomSort(@LocalSort); - Result := FSelfAsInterface; -end; - -function LocalSortAsInteger(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := StrToInt(List[Index1]) - StrToInt(List[Index2]); -end; - -function TJclStringList.SortAsInteger: IJclStringList; -begin - inherited CustomSort(@LocalSortAsInteger); - Result := FSelfAsInterface; -end; - -{$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} -function TJclStringList.CompareStrings(const S1, S2: string): Integer; -begin - Result := AnsiCompareText(S1, S2); -end; -{$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} - -function LocalSortByName(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := TJclStringList(List).CompareStrings(List.Names[Index1], List.Names[Index2]); -end; - -function TJclStringList.SortByName: IJclStringList; -begin - inherited CustomSort(@LocalSortByName); - Result := FSelfAsInterface; -end; - -function TJclStringList.Insert(Index: Integer; const S: string): IJclStringList; -begin - inherited Insert(Index, S); - Result := FSelfAsInterface; -end; - -function TJclStringList.InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; -begin - inherited InsertObject(Index, S, AObject); - Result := FSelfAsInterface; -end; - -function TJclStringList.GetCaseSensitive: Boolean; -begin - Result := inherited CaseSensitive; -end; - -function TJclStringList.GetDuplicates: TDuplicates; -begin - Result := inherited Duplicates; -end; - -function TJclStringList.GetOnChange: TNotifyEvent; -begin - Result := inherited OnChange; -end; - -function TJclStringList.GetOnChanging: TNotifyEvent; -begin - Result := inherited OnChanging; -end; - -function TJclStringList.GetSorted: Boolean; -begin - Result := inherited Sorted; -end; - -procedure TJclStringList.SetCaseSensitive(const Value: Boolean); -begin - inherited CaseSensitive := Value; -end; - -procedure TJclStringList.SetDuplicates(const Value: TDuplicates); -begin - inherited Duplicates := Value; -end; - -procedure TJclStringList.SetOnChange(const Value: TNotifyEvent); -begin - inherited OnChange := Value; -end; - -procedure TJclStringList.SetOnChanging(const Value: TNotifyEvent); -begin - inherited OnChanging := Value; -end; - -procedure TJclStringList.SetSorted(const Value: Boolean); -begin - inherited Sorted := Value; -end; - -function TJclStringList.LoadFromFile(const FileName: string): IJclStringList; -begin - inherited LoadFromFile(FileName); - Result := FSelfAsInterface; -end; - -function TJclStringList.LoadFromStream(Stream: TStream): IJclStringList; -begin - inherited LoadFromStream(Stream); - Result := FSelfAsInterface; -end; - -function TJclStringList.SaveToFile(const FileName: string): IJclStringList; -begin - inherited SaveToFile(FileName); - Result := FSelfAsInterface; -end; - -function TJclStringList.SaveToStream(Stream: TStream): IJclStringList; -begin - inherited SaveToStream(Stream); - Result := FSelfAsInterface; -end; - -function TJclStringList.GetCommaText: string; -begin - Result := inherited CommaText; -end; - -function TJclStringList.GetDelimitedText: string; -begin - Result := inherited DelimitedText; -end; - -function TJclStringList.GetDelimiter: Char; -begin - Result := inherited Delimiter; -end; - -function TJclStringList.GetName(Index: Integer): string; -begin - Result := inherited Names[Index]; -end; - -{$IFDEF COMPILER7_UP} - -function TJclStringList.GetNameValueSeparator: Char; -begin - Result := inherited NameValueSeparator; -end; - -function TJclStringList.GetValueFromIndex(Index: Integer): string; -begin - Result := inherited ValueFromIndex[Index]; -end; - -{$ENDIF COMPILER7_UP} - -function TJclStringList.GetQuoteChar: Char; -begin - Result := inherited QuoteChar; -end; - -procedure TJclStringList.SetCommaText(const Value: string); -begin - inherited CommaText := Value; -end; - -procedure TJclStringList.SetDelimitedText(const Value: string); -begin - inherited DelimitedText := Value; -end; - -procedure TJclStringList.SetDelimiter(const Value: Char); -begin - inherited Delimiter := Value; -end; - -{$IFDEF COMPILER7_UP} - -procedure TJclStringList.SetNameValueSeparator(const Value: Char); -begin - inherited NameValueSeparator := Value; -end; - -procedure TJclStringList.SetValueFromIndex(Index: Integer; const Value: string); -begin - inherited ValueFromIndex[Index] := Value; -end; - -{$ENDIF COMPILER7_UP} - -procedure TJclStringList.SetQuoteChar(const Value: Char); -begin - inherited QuoteChar := Value; -end; - -function TJclStringList.Delimit(const ADelimiter: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Strings[I] := ADelimiter + Strings[I] + ADelimiter; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.LoadExeParams: IJclStringList; -var - I: Integer; - S: string; -begin - Result := BeginUpdate; - try - Clear; - for I := 1 to ParamCount do - begin - S := ParamStr(I); - if (S[1] = '-') or (S[1] = '/') then - System.Delete(S, 1, 1); - Add(S); - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Exists(const S: string): Boolean; -begin - Result := IndexOf(S) >= 0; -end; - -function TJclStringList.ExistsName(const S: string): Boolean; -begin - Result := IndexOfName(S) >= 0; -end; - -function TJclStringList.DeleteBlanks: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]) = '' then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.KeepIntegers: IJclStringList; -var - I, X: Integer; -begin - Result := BeginUpdate; - try - X := 0; - for I := LastIndex downto 0 do - if not TryStrToInt(Strings[I], X) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.DeleteIntegers: IJclStringList; -var - I, X: Integer; -begin - Result := BeginUpdate; - try - X := 0; - for I := LastIndex downto 0 do - if TryStrToInt(Strings[I], X) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; -var - I: Integer; -begin - if AFreeAndNil then - Result := BeginUpdate; - for I := 0 to LastIndex do - begin - inherited Objects[I].Free; - if AFreeAndNil then - inherited Objects[I] := nil; - end; - if AFreeAndNil then - Result := EndUpdate - else - Result := FSelfAsInterface; -end; - -function TJclStringList.ReleaseInterfaces: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Interfaces[I] := nil; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Clone: IJclStringList; -begin - Result := JclStringList.Assign(Self); -end; - -function TJclStringList.Assign(Source: TPersistent): IJclStringList; -var - L: TJclStringList; - I: Integer; -begin - inherited Assign(Source); - Result := FSelfAsInterface; - if Source is TJclStringList then - begin - L := TJclStringList(Source); - FObjectsMode := L.FObjectsMode; - if not (FObjectsMode in [omNone, omObjects]) then - begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - begin - inherited Objects[I] := nil; - case FObjectsMode of - omVariants: - Variants[I] := L.Variants[I]; - omInterfaces: - Interfaces[I] := L.Interfaces[I]; - end; - end; - finally - Result := EndUpdate; - end; - end; - end; -end; - -function TJclStringList.CanFreeObjects: Boolean; -begin - Result := not (FObjectsMode in [omNone, omObjects]); -end; - -function TJclStringList.GetObjectsMode: TJclStringListObjectsMode; -begin - Result := FObjectsMode; -end; - -{$IFDEF UNITVERSIONING} -initialization - RegisterUnitVersion(HInstance, UnitVersioning); - -finalization - UnregisterUnitVersion(HInstance); -{$ENDIF UNITVERSIONING} - -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 NewStringListUnit.pas. } +{ } +{ The Initial Developer of the Original Code is Romullo Sousa. } +{ Portions created by Romullo Sousa are Copyright (C) Romullo Sousa. All rights reserved. } +{ } +{ Contributor(s): } +{ Romullo Sousa (romullobr) } +{ Leo Simas (Leh_U) } +{ } +{**************************************************************************************************} +{ } +{ This unit contains several improvements of the standard TStringList. } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit JclStringLists; + +{$I jcl.inc} + +interface + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Winapi.Windows, + {$ENDIF MSWINDOWS} + System.Variants, + System.Classes, System.SysUtils, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF MSWINDOWS} + Variants, + Classes, SysUtils, + {$ENDIF ~HAS_UNITSCOPE} + JclBase, + JclPCRE; + +{$DEFINE HAS_TSTRINGS_COMPARESTRINGS} +{$IFDEF FPC} + {$UNDEF HAS_TSTRINGS_COMPARESTRINGS} +{$ENDIF FPC} + +type + EJclStringListError = class(EJclError); + + IJclStringList = interface; + + TJclStringListObjectsMode = (omNone, omObjects, omVariants, omInterfaces); + + TJclStringListSortCompare = function(List: IJclStringList; Index1, Index2: Integer): Integer; + + IJclStringList = interface(IInterface) + ['{8DC5B71C-4756-404D-8636-7872CD299796}'] + { From TStrings/TStringList } + function Add(const S: string): Integer; overload; + function AddObject(const S: string; AObject: TObject): Integer; + function Get(Index: Integer): string; + function GetCapacity: Integer; + function GetCount: Integer; + function GetObjects(Index: Integer): TObject; + function GetTextStr: string; + function GetValue(const Name: string): string; + {$IFDEF FPC} + function Find(const S: string; out Index: Integer): Boolean; + {$ELSE ~FPC} + function Find(const S: string; var Index: Integer): Boolean; + {$ENDIF ~FPC} + function IndexOf(const S: string): Integer; + function GetCaseSensitive: Boolean; + function GetDuplicates: TDuplicates; + function GetOnChange: TNotifyEvent; + function GetOnChanging: TNotifyEvent; + function GetSorted: Boolean; + function Equals(Strings: TStrings): Boolean; + function IndexOfName(const Name: string): Integer; + function IndexOfObject(AObject: TObject): Integer; + function LoadFromFile(const FileName: string): IJclStringList; + function LoadFromStream(Stream: TStream): IJclStringList; + function SaveToFile(const FileName: string): IJclStringList; + function SaveToStream(Stream: TStream): IJclStringList; + function GetCommaText: string; + function GetDelimitedText: string; + function GetDelimiter: Char; + function GetName(Index: Integer): string; + {$IFDEF COMPILER7_UP} + function GetNameValueSeparator: Char; + function GetValueFromIndex(Index: Integer): string; + {$ENDIF COMPILER7_UP} + function GetQuoteChar: Char; + procedure SetCommaText(const Value: string); + procedure SetDelimitedText(const Value: string); + procedure SetDelimiter(const Value: Char); + {$IFDEF COMPILER7_UP} + procedure SetNameValueSeparator(const Value: Char); + procedure SetValueFromIndex(Index: Integer; const Value: string); + {$ENDIF COMPILER7_UP} + procedure SetQuoteChar(const Value: Char); + procedure AddStrings(Strings: TStrings); overload; + procedure SetObjects(Index: Integer; const Value: TObject); + procedure Put(Index: Integer; const S: string); + procedure SetCapacity(NewCapacity: Integer); + procedure SetTextStr(const Value: string); + procedure SetValue(const Name, Value: string); + procedure SetCaseSensitive(const Value: Boolean); + procedure SetDuplicates(const Value: TDuplicates); + procedure SetOnChange(const Value: TNotifyEvent); + procedure SetOnChanging(const Value: TNotifyEvent); + procedure SetSorted(const Value: Boolean); + property Count: Integer read GetCount; + property Strings[Index: Integer]: string read Get write Put; default; + property Text: string read GetTextStr write SetTextStr; + property Objects[Index: Integer]: TObject read GetObjects write SetObjects; + property Capacity: Integer read GetCapacity write SetCapacity; + property Values[const Name: string]: string read GetValue write SetValue; + property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; + property Sorted: Boolean read GetSorted write SetSorted; + property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read GetOnChange write SetOnChange; + property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; + property DelimitedText: string read GetDelimitedText write SetDelimitedText; + property Delimiter: Char read GetDelimiter write SetDelimiter; + property Names[Index: Integer]: string read GetName; + property QuoteChar: Char read GetQuoteChar write SetQuoteChar; + property CommaText: string read GetCommaText write SetCommaText; + {$IFDEF COMPILER7_UP} + property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; + {$ENDIF COMPILER7_UP} + { New } + function Assign(Source: TPersistent): IJclStringList; + function LoadExeParams: IJclStringList; + function Exists(const S: string): Boolean; + function ExistsName(const S: string): Boolean; + function DeleteBlanks: IJclStringList; + function KeepIntegers: IJclStringList; + function DeleteIntegers: IJclStringList; + function ReleaseInterfaces: IJclStringList; + function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; + function Clone: IJclStringList; + function Insert(Index: Integer; const S: string): IJclStringList; + function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; + function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; + function SortAsInteger: IJclStringList; + function SortByName: IJclStringList; + function Delete(AIndex: Integer): IJclStringList; overload; + function Delete(const AString: string): IJclStringList; overload; + function Exchange(Index1, Index2: Integer): IJclStringList; + function Add(const A: array of const): IJclStringList; overload; + function AddStrings(const A: array of string): IJclStringList; overload; + function BeginUpdate: IJclStringList; + function EndUpdate: IJclStringList; + function Trim: IJclStringList; + function Join(const ASeparator: string = ''): string; + function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; + function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; + function Last: string; + function First: string; + function LastIndex: Integer; + function Clear: IJclStringList; + {$IFDEF JCL_PCRE} + function DeleteRegEx(const APattern: string): IJclStringList; + function KeepRegEx(const APattern: string): IJclStringList; + function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + {$ENDIF JCL_PCRE} + function GetStringsRef: TStrings; + function ConfigAsSet: IJclStringList; + function Delimit(const ADelimiter: string): IJclStringList; + function GetInterfaceByIndex(Index: Integer): IInterface; + function GetLists(Index: Integer): IJclStringList; + function GetVariants(AIndex: Integer): Variant; + function GetKeyInterface(const AKey: string): IInterface; + function GetKeyObject(const AKey: string): TObject; + function GetKeyVariant(const AKey: string): Variant; + function GetKeyList(const AKey: string): IJclStringList; + function GetObjectsMode: TJclStringListObjectsMode; + procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); + procedure SetLists(Index: Integer; const Value: IJclStringList); + procedure SetVariants(Index: Integer; const Value: Variant); + procedure SetKeyInterface(const AKey: string; const Value: IInterface); + procedure SetKeyObject(const AKey: string; const Value: TObject); + procedure SetKeyVariant(const AKey: string; const Value: Variant); + procedure SetKeyList(const AKey: string; const Value: IJclStringList); + property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; + property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; + property Variants[Index: Integer]: Variant read GetVariants write SetVariants; + property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; + property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; + property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; + property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; + property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; + end; + +type + TJclInterfacedStringList = class(TStringList, IInterface) + private + FOwnerInterface: IInterface; + public + { IInterface } + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall; + procedure AfterConstruction; override; + end; + + + TJclStringList = class(TJclInterfacedStringList, IInterface, IJclStringList) + private + FObjectsMode: TJclStringListObjectsMode; + FSelfAsInterface: IJclStringList; + {$IFDEF JCL_PCRE} + FLastRegExPattern: string; + FRegEx: TJclRegEx; + {$ENDIF JCL_PCRE} + FCompareFunction: TJclStringListSortCompare; + function CanFreeObjects: Boolean; + {$IFDEF JCL_PCRE} + function MatchRegEx(const S, APattern: string): Boolean; + {$ENDIF JCL_PCRE} + procedure EnsureObjectsMode(AMode: TJclStringListObjectsMode); + protected + FRefCount: Integer; + {$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} + function CompareStrings(const S1, S2: string): Integer; virtual; + {$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} + public + constructor Create; + destructor Destroy; override; + { IInterface } + // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { IJclStringList } + // function Add(const S: string): Integer; overload; + // function AddObject(const S: string; AObject: TObject): Integer; + // function Get(Index: Integer): string; + // function GetCapacity: Integer; + // function GetCount: Integer; + function GetObjects(Index: Integer): TObject; + // function GetTextStr: string; + function GetValue(const Name: string): string; + // function Find(const S: string; var Index: Integer): Boolean; + // function IndexOf(const S: string): Integer; + function GetCaseSensitive: Boolean; + function GetDuplicates: TDuplicates; + function GetOnChange: TNotifyEvent; + function GetOnChanging: TNotifyEvent; + function GetSorted: Boolean; + // function Equals(Strings: TStrings): Boolean; + // function IndexOfName(const Name: string): Integer; + // function IndexOfObject(AObject: TObject): Integer; + function LoadFromFile(const FileName: string): IJclStringList; reintroduce; + function LoadFromStream(Stream: TStream): IJclStringList; reintroduce; + function SaveToFile(const FileName: string): IJclStringList; reintroduce; + function SaveToStream(Stream: TStream): IJclStringList; reintroduce; + function GetCommaText: string; + function GetDelimitedText: string; + function GetDelimiter: Char; + function GetName(Index: Integer): string; + {$IFDEF COMPILER7_UP} + function GetNameValueSeparator: Char; + function GetValueFromIndex(Index: Integer): string; + {$ENDIF COMPILER7_UP} + function GetQuoteChar: Char; + procedure SetCommaText(const Value: string); + procedure SetDelimitedText(const Value: string); + procedure SetDelimiter(const Value: Char); + {$IFDEF COMPILER7_UP} + procedure SetNameValueSeparator(const Value: Char); + procedure SetValueFromIndex(Index: Integer; const Value: string); + {$ENDIF COMPILER7_UP} + procedure SetQuoteChar(const Value: Char); + // procedure AddStrings(Strings: TStrings); overload; + procedure SetObjects(Index: Integer; const Value: TObject); + // procedure Put(Index: Integer; const S: string); + // procedure SetCapacity(NewCapacity: Integer); + // procedure SetTextStr(const Value: string); + procedure SetValue(const Name, Value: string); + procedure SetCaseSensitive(const Value: Boolean); + procedure SetDuplicates(const Value: TDuplicates); + procedure SetOnChange(const Value: TNotifyEvent); + procedure SetOnChanging(const Value: TNotifyEvent); + procedure SetSorted(const Value: Boolean); + property Count: Integer read GetCount; + property Strings[Index: Integer]: string read Get write Put; default; + property Text: string read GetTextStr write SetTextStr; + property Objects[Index: Integer]: TObject read GetObjects write SetObjects; + property Capacity: Integer read GetCapacity write SetCapacity; + property Values[const Name: string]: string read GetValue write SetValue; + property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; + property Sorted: Boolean read GetSorted write SetSorted; + property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read GetOnChange write SetOnChange; + property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; + property DelimitedText: string read GetDelimitedText write SetDelimitedText; + property Delimiter: Char read GetDelimiter write SetDelimiter; + property Names[Index: Integer]: string read GetName; + property QuoteChar: Char read GetQuoteChar write SetQuoteChar; + property CommaText: string read GetCommaText write SetCommaText; + {$IFDEF COMPILER7_UP} + property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; + {$ENDIF COMPILER7_UP} + { New } + function Assign(Source: TPersistent): IJclStringList; reintroduce; + function LoadExeParams: IJclStringList; + function Exists(const S: string): Boolean; + function ExistsName(const S: string): Boolean; + function DeleteBlanks: IJclStringList; + function KeepIntegers: IJclStringList; + function DeleteIntegers: IJclStringList; + function ReleaseInterfaces: IJclStringList; + function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; + function Clone: IJclStringList; + function Insert(Index: Integer; const S: string): IJclStringList; reintroduce; + function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; reintroduce; + function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; reintroduce; + function SortAsInteger: IJclStringList; + function SortByName: IJclStringList; + function Delete(AIndex: Integer): IJclStringList; reintroduce; overload; + function Delete(const AString: string): IJclStringList; reintroduce; overload; + function Exchange(Index1, Index2: Integer): IJclStringList; reintroduce; + function Add(const A: array of const): IJclStringList; reintroduce; overload; + function AddStrings(const A: array of string): IJclStringList; reintroduce; overload; + function BeginUpdate: IJclStringList; + function EndUpdate: IJclStringList; + function Trim: IJclStringList; + function Join(const ASeparator: string = ''): string; + function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; + function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; + function Last: string; + function First: string; + function LastIndex: Integer; + function Clear: IJclStringList; reintroduce; + {$IFDEF JCL_PCRE} + function DeleteRegEx(const APattern: string): IJclStringList; + function KeepRegEx(const APattern: string): IJclStringList; + function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + {$ENDIF JCL_PCRE} + function GetStringsRef: TStrings; + function ConfigAsSet: IJclStringList; + function Delimit(const ADelimiter: string): IJclStringList; + function GetInterfaceByIndex(Index: Integer): IInterface; + function GetLists(Index: Integer): IJclStringList; + function GetVariants(AIndex: Integer): Variant; + function GetKeyInterface(const AKey: string): IInterface; + function GetKeyObject(const AKey: string): TObject; + function GetKeyVariant(const AKey: string): Variant; + function GetKeyList(const AKey: string): IJclStringList; + function GetObjectsMode: TJclStringListObjectsMode; + procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); + procedure SetLists(Index: Integer; const Value: IJclStringList); + procedure SetVariants(Index: Integer; const Value: Variant); + procedure SetKeyInterface(const AKey: string; const Value: IInterface); + procedure SetKeyObject(const AKey: string; const Value: TObject); + procedure SetKeyVariant(const AKey: string; const Value: Variant); + procedure SetKeyList(const AKey: string; const Value: IJclStringList); + property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; + property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; + property Variants[Index: Integer]: Variant read GetVariants write SetVariants; + property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; + property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; + property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; + property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; + property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; + end; + +function JclStringList: IJclStringList; overload; +function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; +function JclStringListStrings(const A: array of string): IJclStringList; overload; +function JclStringList(const A: array of const): IJclStringList; overload; +function JclStringList(const AText: string): IJclStringList; overload; + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNITSCOPE} + System.TypInfo, + {$ELSE ~HAS_UNITSCOPE} + TypInfo, + {$ENDIF ~HAS_UNITSCOPE} + JclFileUtils, + JclStrings; + +type + TVariantWrapper = class(TObject) + private + FValue: Variant; + end; + + TInterfaceWrapper = class(TObject) + private + FValue: IInterface; + end; + +function JclStringList: IJclStringList; +begin + Result := TJclStringList.Create; +end; + +function JclStringList(const AText: string): IJclStringList; overload; +begin + Result := JclStringList; + Result.Text := AText; +end; + +function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; +begin + Result := JclStringList; + Result.AddStrings(AStrings); +end; + +function JclStringListStrings(const A: array of string): IJclStringList; +begin + Result := JclStringList.AddStrings(A); +end; + +function JclStringList(const A: array of const): IJclStringList; +begin + Result := JclStringList.Add(A); +end; + +//=== { TJclInterfacedStringList } ============================================== + +procedure TJclInterfacedStringList.AfterConstruction; +Var + MyOwner : TPersistent; +begin + inherited; + MyOwner := GetOwner; + if Assigned(MyOwner) then + MyOwner.GetInterface(IUnknown,FOwnerInterface); +end; + + +function TJclInterfacedStringList._AddRef: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result := FOwnerInterface._AddRef + else + Result := -1; +end; + + +function TJclInterfacedStringList._Release: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result := FOwnerInterface._Release + else + Result := -1; +end; + + +function TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +//=== { TJclStringList } ===================================================== + +function TJclStringList.Add(const A: array of const): IJclStringList; +const + BoolToStr: array [Boolean] of string[5] = ('false', 'true'); +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := Low(A) to High(A) do + case A[I].VType of + vtInteger: + Add(IntToStr(A[I].VInteger)); + vtBoolean: + Add(string(BoolToStr[A[I].VBoolean])); + vtChar: + Add(string(AnsiString(A[I].VChar))); + vtExtended: + Add(FloatToStr(A[I].VExtended^)); + vtString: + Add(string(A[I].VString^)); + vtPChar: + Add(string(AnsiString(A[I].VPChar))); + vtPWideChar: + Add(string(WideString(A[I].VPWideChar))); + vtObject: + Add(A[I].VObject.ClassName); + vtClass: + Add(A[I].VClass.ClassName); + vtAnsiString: + Add(string(A[I].VAnsiString)); + vtWideString: + Add(string(A[I].VWideString)); + vtCurrency: + Add(CurrToStr(A[I].VCurrency^)); + vtVariant: + Add(string(A[I].VVariant^)); + vtInt64: + Add(IntToStr(A[I].VInt64^)); + {$IFDEF SUPPORTS_UNICODE_STRING} + vtUnicodeString: + Add(string(A[I].VUnicodeString)); + {$ENDIF SUPPORTS_UNICODE_STRING} + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.AddStrings(const A: array of string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := Low(A) to High(A) do + Add(A[I]); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.BeginUpdate: IJclStringList; +begin + inherited BeginUpdate; + Result := FSelfAsInterface; +end; + +function TJclStringList.Clear: IJclStringList; +begin + if CanFreeObjects then + FreeObjects(False); + inherited Clear; + Result := FSelfAsInterface; +end; + +function TJclStringList.EndUpdate: IJclStringList; +begin + inherited EndUpdate; + Result := FSelfAsInterface; +end; + +function TJclStringList.ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar; + AClearBeforeAdd: Boolean): IJclStringList; +var + L, I, X: Integer; +begin + Result := BeginUpdate; + try + if AClearBeforeAdd then + Clear; + I := 1; + L := Length(AText); + while I <= L do + begin + while (I <= L) and (AnsiChar(AText[I]) in ADelims) do + Inc(I); + X := I; + while (I <= L) and not (AnsiChar(AText[I]) in ADelims) do + Inc(I); + if X <> I then + Add(Copy(AText, X, I - X)); + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.First: string; +begin + Result := Strings[0]; +end; + +function TJclStringList.Join(const ASeparator: string): string; +var + I: Integer; + SB: TJclStringBuilder; +begin + if Count <= 0 then + Result := '' + else begin + SB := TJclStringBuilder.Create(First); // Capacity: Sum([Strings]) + (Count-1) * [ASeparator] ? Worth it? + try + for I := 1 to LastIndex do + SB.Append(ASeparator).Append(Strings[i]); + Result := SB.ToString; + finally + SB.Free; + end; + end; +// for I := 0 to LastIndex - 1 do +// Result := Result + Strings[I] + ASeparator; +// if Count > 0 then +// Result := Result + Last; +end; + +function TJclStringList.Last: string; +begin + Result := Strings[LastIndex]; +end; + +function TJclStringList.Split(const AText, ASeparator: string; + AClearBeforeAdd: Boolean = True): IJclStringList; +var + LStartIndex, LEndIndex: Integer; + LLengthSeparator: Integer; +begin + Result := FSelfAsInterface; + if AText <> '' then + begin + Result := BeginUpdate; + try + if AClearBeforeAdd then + Clear; + LLengthSeparator := Length(ASeparator); + LStartIndex := 1; + LEndIndex := StrSearch(ASeparator, AText, LStartIndex); + while LEndIndex > 0 do + begin + Add(Copy(AText, LStartIndex, LEndIndex - LStartIndex)); + LStartIndex := LEndIndex + LLengthSeparator; + LEndIndex := StrSearch(ASeparator, AText, LStartIndex); + end; + Add(Copy(AText, LStartIndex, MaxInt)); + finally + Result := EndUpdate; + end; + end; +end; + +function TJclStringList.Trim: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Strings[I] := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TJclStringList._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 1 then + begin + // When there is only one reference, it is the internal reference, + // so we release it. The compiler will call _Release again and + // the object will be destroyed. + FSelfAsInterface := nil; + end + else + if Result = 0 then + Destroy; +end; + +{$IFDEF JCL_PCRE} +function TJclStringList.DeleteRegEx(const APattern: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if MatchRegEx(Strings[I], APattern) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.KeepRegEx(const APattern: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if not MatchRegEx(Strings[I], APattern) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.MatchRegEx(const S, APattern: string): Boolean; +begin + if FRegEx = nil then + FRegEx := TJclRegEx.Create; + if FLastRegExPattern <> APattern then + begin + if CaseSensitive then + FRegEx.Options := FRegEx.Options - [roIgnoreCase] + else + FRegEx.Options := FRegEx.Options + [roIgnoreCase]; + FRegEx.Compile(APattern, False, True); + FLastRegExPattern := APattern; + end; + Result := FRegEx.Match(S); +end; +{$ENDIF JCL_PCRE} + +destructor TJclStringList.Destroy; +begin + if CanFreeObjects then + FreeObjects(False); + {$IFDEF JCL_PCRE} + FreeAndNil(FRegEx); + {$ENDIF JCL_PCRE} + inherited Destroy; +end; + +{$IFDEF JCL_PCRE} +function TJclStringList.Directories(const APattern: string = '*'; + ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + + procedure DoDirectories(const APattern: string); + var + LSearchRec: TSearchRec; + LFullName: string; + LPath: string; + begin + LPath := ExtractFilePath(APattern); + if FindFirst(APattern, faAnyFile, LSearchRec) = 0 then + try + repeat + if (LSearchRec.Attr and faDirectory = 0) or + (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then + Continue; + LFullName := LPath + LSearchRec.Name; + if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then + Add(LFullName); + if ARecursive then + DoDirectories(PathAddSeparator(LFullName) + ExtractFileName(APattern)); + until FindNext(LSearchRec) <> 0; + finally + FindClose(LSearchRec); + end; + end; + +begin + Result := BeginUpdate; + try + if DirectoryExists(APattern) then + DoDirectories(PathAddSeparator(APattern) + '*') + else + DoDirectories(APattern); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Files(const APattern: string = '*'; + ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + + procedure DoFiles(const APattern: string); + var + LSearchRec: TSearchRec; + LFullName: string; + LDirectories: IJclStringList; + LPath: string; + I: Integer; + begin + LPath := ExtractFilePath(APattern); + if FindFirst(APattern, faAnyFile and not faDirectory, LSearchRec) = 0 then + begin + try + repeat + if (LSearchRec.Attr and faDirectory <> 0) or + (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then + Continue; + LFullName := LPath + LSearchRec.Name; + if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then + Add(LFullName); + until FindNext(LSearchRec) <> 0; + finally + FindClose(LSearchRec); + end; + end; + if ARecursive then + begin + LDirectories := JclStringList.Directories(LPath + '*', False); + for I := 0 to LDirectories.LastIndex do + DoFiles(PathAddSeparator(LDirectories[I]) + ExtractFileName(APattern)); + end; + end; + +begin + Result := BeginUpdate; + try + if DirectoryExists(APattern) then + DoFiles(PathAddSeparator(APattern) + '*') + else + DoFiles(APattern); + finally + Result := EndUpdate; + end; +end; +{$ENDIF JCL_PCRE} + +function TJclStringList.LastIndex: Integer; +begin + { The code bellow is more optimized than "Result := Count - 1". } + Result := Count; + Dec(Result); +end; + +constructor TJclStringList.Create; +begin + inherited Create; + if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then + System.Error(reIntfCastError); +end; + +function TJclStringList.GetLists(Index: Integer): IJclStringList; +begin + Result := Interfaces[Index] as IJclStringList; + if Result = nil then + begin + Result := JclStringList; + Interfaces[Index] := Result; + end; +end; + +procedure TJclStringList.SetLists(Index: Integer; const Value: IJclStringList); +begin + Interfaces[Index] := Value; +end; + +function TJclStringList.GetStringsRef: TStrings; +begin + Result := Self; +end; + +function TJclStringList.GetKeyInterface(const AKey: string): IInterface; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Interfaces[I] + else + Result := nil; +end; + +function TJclStringList.GetKeyObject(const AKey: string): TObject; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Objects[I] + else + Result := nil; +end; + +procedure TJclStringList.SetKeyInterface(const AKey: string; const Value: IInterface); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + I := Add(AKey); + Interfaces[I] := Value +end; + +procedure TJclStringList.SetKeyObject(const AKey: string; const Value: TObject); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + AddObject(AKey, Value) + else + Objects[I] := Value; +end; + +function TJclStringList.ConfigAsSet: IJclStringList; +begin + Sorted := True; + Duplicates := dupIgnore; + Result := FSelfAsInterface; +end; + +function TJclStringList.GetKeyVariant(const AKey: string): Variant; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Variants[I] + else + Result := Unassigned; +end; + +procedure TJclStringList.SetKeyVariant(const AKey: string; const Value: Variant); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + I := Add(AKey); + Variants[I] := Value +end; + +function TJclStringList.GetValue(const Name: string): string; +begin + Result := inherited Values[Name]; +end; + +procedure TJclStringList.SetValue(const Name, Value: string); +begin + inherited Values[Name] := Value; +end; + +function TJclStringList.GetInterfaceByIndex(Index: Integer): IInterface; +var + V: TInterfaceWrapper; +begin + if FObjectsMode <> omInterfaces then + EnsureObjectsMode(omInterfaces); + V := TInterfaceWrapper(inherited Objects[Index]); + if V = nil then + Result := nil + else + Result := V.FValue; +end; + +procedure TJclStringList.SetInterfaceByIndex(Index: Integer; const Value: IInterface); +var + V: TInterfaceWrapper; +begin + if FObjectsMode <> omInterfaces then + EnsureObjectsMode(omInterfaces); + V := TInterfaceWrapper(inherited Objects[Index]); + if V = nil then + begin + V := TInterfaceWrapper.Create; + inherited Objects[Index] := V; + end; + V.FValue := Value; +end; + +function TJclStringList.GetObjects(Index: Integer): TObject; +begin + if FObjectsMode <> omObjects then + EnsureObjectsMode(omObjects); + Result := inherited Objects[Index]; +end; + +procedure TJclStringList.SetObjects(Index: Integer; const Value: TObject); +begin + if FObjectsMode <> omObjects then + EnsureObjectsMode(omObjects); + inherited Objects[Index] := Value; +end; + +function TJclStringList.GetVariants(AIndex: Integer): Variant; +var + V: TVariantWrapper; +begin + if FObjectsMode <> omVariants then + EnsureObjectsMode(omVariants); + V := TVariantWrapper(inherited Objects[AIndex]); + if V = nil then + Result := Unassigned + else + Result := V.FValue; +end; + +procedure TJclStringList.SetVariants(Index: Integer; const Value: Variant); +var + V: TVariantWrapper; +begin + if FObjectsMode <> omVariants then + EnsureObjectsMode(omVariants); + V := TVariantWrapper(inherited Objects[Index]); + if V = nil then + begin + V := TVariantWrapper.Create; + inherited Objects[Index] := V; + end; + V.FValue := Value; +end; + +procedure TJclStringList.EnsureObjectsMode(AMode: TJclStringListObjectsMode); +begin + if FObjectsMode <> AMode then + begin + if FObjectsMode <> omNone then + begin + raise EJclStringListError.CreateFmt('Objects cannot be used as "%s" because it has been used as "%s".', + [GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(AMode)), + GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(FObjectsMode))]); + end; + FObjectsMode := AMode; + end; +end; + +function TJclStringList.GetKeyList(const AKey: string): IJclStringList; +begin + Result := KeyInterface[AKey] as IJclStringList; + if Result = nil then + begin + Result := JclStringList; + KeyInterface[AKey] := Result; + end; +end; + +procedure TJclStringList.SetKeyList(const AKey: string; const Value: IJclStringList); +begin + KeyInterface[AKey] := Value; +end; + +function TJclStringList.Delete(AIndex: Integer): IJclStringList; +begin + if CanFreeObjects then + inherited Objects[AIndex].Free; + inherited Delete(AIndex); + Result := FSelfAsInterface; +end; + +function TJclStringList.Delete(const AString: string): IJclStringList; +begin + Result := Delete(IndexOf(AString)); +end; + +function TJclStringList.Exchange(Index1, Index2: Integer): IJclStringList; +begin + inherited Exchange(Index1, Index2); + Result := FSelfAsInterface; +end; + +function LocalSort(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := TJclStringList(List).FCompareFunction(TJclStringList(List).FSelfAsInterface, Index1, Index2); +end; + +function TJclStringList.Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; +begin + FCompareFunction := ACompareFunction; + if not Assigned(ACompareFunction) then + inherited Sort + else + inherited CustomSort(@LocalSort); + Result := FSelfAsInterface; +end; + +function LocalSortAsInteger(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := StrToInt(List[Index1]) - StrToInt(List[Index2]); +end; + +function TJclStringList.SortAsInteger: IJclStringList; +begin + inherited CustomSort(@LocalSortAsInteger); + Result := FSelfAsInterface; +end; + +{$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} +function TJclStringList.CompareStrings(const S1, S2: string): Integer; +begin + Result := AnsiCompareText(S1, S2); +end; +{$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} + +function LocalSortByName(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := TJclStringList(List).CompareStrings(List.Names[Index1], List.Names[Index2]); +end; + +function TJclStringList.SortByName: IJclStringList; +begin + inherited CustomSort(@LocalSortByName); + Result := FSelfAsInterface; +end; + +function TJclStringList.Insert(Index: Integer; const S: string): IJclStringList; +begin + inherited Insert(Index, S); + Result := FSelfAsInterface; +end; + +function TJclStringList.InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; +begin + inherited InsertObject(Index, S, AObject); + Result := FSelfAsInterface; +end; + +function TJclStringList.GetCaseSensitive: Boolean; +begin + Result := inherited CaseSensitive; +end; + +function TJclStringList.GetDuplicates: TDuplicates; +begin + Result := inherited Duplicates; +end; + +function TJclStringList.GetOnChange: TNotifyEvent; +begin + Result := inherited OnChange; +end; + +function TJclStringList.GetOnChanging: TNotifyEvent; +begin + Result := inherited OnChanging; +end; + +function TJclStringList.GetSorted: Boolean; +begin + Result := inherited Sorted; +end; + +procedure TJclStringList.SetCaseSensitive(const Value: Boolean); +begin + inherited CaseSensitive := Value; +end; + +procedure TJclStringList.SetDuplicates(const Value: TDuplicates); +begin + inherited Duplicates := Value; +end; + +procedure TJclStringList.SetOnChange(const Value: TNotifyEvent); +begin + inherited OnChange := Value; +end; + +procedure TJclStringList.SetOnChanging(const Value: TNotifyEvent); +begin + inherited OnChanging := Value; +end; + +procedure TJclStringList.SetSorted(const Value: Boolean); +begin + inherited Sorted := Value; +end; + +function TJclStringList.LoadFromFile(const FileName: string): IJclStringList; +begin + inherited LoadFromFile(FileName); + Result := FSelfAsInterface; +end; + +function TJclStringList.LoadFromStream(Stream: TStream): IJclStringList; +begin + inherited LoadFromStream(Stream); + Result := FSelfAsInterface; +end; + +function TJclStringList.SaveToFile(const FileName: string): IJclStringList; +begin + inherited SaveToFile(FileName); + Result := FSelfAsInterface; +end; + +function TJclStringList.SaveToStream(Stream: TStream): IJclStringList; +begin + inherited SaveToStream(Stream); + Result := FSelfAsInterface; +end; + +function TJclStringList.GetCommaText: string; +begin + Result := inherited CommaText; +end; + +function TJclStringList.GetDelimitedText: string; +begin + Result := inherited DelimitedText; +end; + +function TJclStringList.GetDelimiter: Char; +begin + Result := inherited Delimiter; +end; + +function TJclStringList.GetName(Index: Integer): string; +begin + Result := inherited Names[Index]; +end; + +{$IFDEF COMPILER7_UP} + +function TJclStringList.GetNameValueSeparator: Char; +begin + Result := inherited NameValueSeparator; +end; + +function TJclStringList.GetValueFromIndex(Index: Integer): string; +begin + Result := inherited ValueFromIndex[Index]; +end; + +{$ENDIF COMPILER7_UP} + +function TJclStringList.GetQuoteChar: Char; +begin + Result := inherited QuoteChar; +end; + +procedure TJclStringList.SetCommaText(const Value: string); +begin + inherited CommaText := Value; +end; + +procedure TJclStringList.SetDelimitedText(const Value: string); +begin + inherited DelimitedText := Value; +end; + +procedure TJclStringList.SetDelimiter(const Value: Char); +begin + inherited Delimiter := Value; +end; + +{$IFDEF COMPILER7_UP} + +procedure TJclStringList.SetNameValueSeparator(const Value: Char); +begin + inherited NameValueSeparator := Value; +end; + +procedure TJclStringList.SetValueFromIndex(Index: Integer; const Value: string); +begin + inherited ValueFromIndex[Index] := Value; +end; + +{$ENDIF COMPILER7_UP} + +procedure TJclStringList.SetQuoteChar(const Value: Char); +begin + inherited QuoteChar := Value; +end; + +function TJclStringList.Delimit(const ADelimiter: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Strings[I] := ADelimiter + Strings[I] + ADelimiter; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.LoadExeParams: IJclStringList; +var + I: Integer; + S: string; +begin + Result := BeginUpdate; + try + Clear; + for I := 1 to ParamCount do + begin + S := ParamStr(I); + if (S[1] = '-') or (S[1] = '/') then + System.Delete(S, 1, 1); + Add(S); + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Exists(const S: string): Boolean; +begin + Result := IndexOf(S) >= 0; +end; + +function TJclStringList.ExistsName(const S: string): Boolean; +begin + Result := IndexOfName(S) >= 0; +end; + +function TJclStringList.DeleteBlanks: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]) = '' then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.KeepIntegers: IJclStringList; +var + I, X: Integer; +begin + Result := BeginUpdate; + try + X := 0; + for I := LastIndex downto 0 do + if not TryStrToInt(Strings[I], X) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.DeleteIntegers: IJclStringList; +var + I, X: Integer; +begin + Result := BeginUpdate; + try + X := 0; + for I := LastIndex downto 0 do + if TryStrToInt(Strings[I], X) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; +var + I: Integer; +begin + if AFreeAndNil then + Result := BeginUpdate; + for I := 0 to LastIndex do + begin + inherited Objects[I].Free; + if AFreeAndNil then + inherited Objects[I] := nil; + end; + if AFreeAndNil then + Result := EndUpdate + else + Result := FSelfAsInterface; +end; + +function TJclStringList.ReleaseInterfaces: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Interfaces[I] := nil; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Clone: IJclStringList; +begin + Result := JclStringList.Assign(Self); +end; + +function TJclStringList.Assign(Source: TPersistent): IJclStringList; +var + L: TJclStringList; + I: Integer; +begin + inherited Assign(Source); + Result := FSelfAsInterface; + if Source is TJclStringList then + begin + L := TJclStringList(Source); + FObjectsMode := L.FObjectsMode; + if not (FObjectsMode in [omNone, omObjects]) then + begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + begin + inherited Objects[I] := nil; + case FObjectsMode of + omVariants: + Variants[I] := L.Variants[I]; + omInterfaces: + Interfaces[I] := L.Interfaces[I]; + end; + end; + finally + Result := EndUpdate; + end; + end; + end; +end; + +function TJclStringList.CanFreeObjects: Boolean; +begin + Result := not (FObjectsMode in [omNone, omObjects]); +end; + +function TJclStringList.GetObjectsMode: TJclStringListObjectsMode; +begin + Result := FObjectsMode; +end; + +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} + +end. From 311f93cd1bd4db5f4048592da96564c2faf51286 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 13:23:19 +0400 Subject: [PATCH 03/12] TJCLStringBuilder.Insert typo - compare with .Add --- jcl/source/common/JclStrings.pas | 10816 ++++++++++++++--------------- 1 file changed, 5408 insertions(+), 5408 deletions(-) diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 72f445de09..e2e511eecf 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -1,5408 +1,5408 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 JclStrings.pas. } -{ } -{ The Initial Developer of the Original Code is Marcel van Brakel. } -{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. } -{ } -{ Contributor(s): } -{ Alexander Radchenko } -{ Andreas Hausladen (ahuser) } -{ Anthony Steele } -{ Azret Botash } -{ Barry Kelly } -{ Huanlin Tsai } -{ Jack N.A. Bakker } -{ Jean-Fabien Connault (cycocrew) } -{ John C Molyneux } -{ Kiriakos Vlahos } -{ Leonard Wennekers } -{ Marcel Bestebroer } -{ Martin Kimmings } -{ Martin Kubecka } -{ Massimo Maria Ghisalberti } -{ Matthias Thoma (mthoma) } -{ Michael Winter } -{ Nick Hodges } -{ Olivier Sannier (obones) } -{ Pelle F. S. Liljendal } -{ Petr Vones (pvones) } -{ Rik Barker (rikbarker) } -{ Robert Lee } -{ Robert Marquardt (marquardt) } -{ Robert Rossmair (rrossmair) } -{ Andreas Schmidt } -{ Sean Farrow (sfarrow) } -{ } -{**************************************************************************************************} -{ } -{ Various character and string routines (searching, testing and transforming) } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -unit JclStrings; - -{$I jcl.inc} - -interface - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Winapi.Windows, - {$ENDIF MSWINDOWS} - {$IFDEF UNICODE_RTL_DATABASE} - System.Character, - {$ENDIF UNICODE_RTL_DATABASE} - System.Classes, System.SysUtils, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF MSWINDOWS} - {$IFDEF UNICODE_RTL_DATABASE} - Character, - {$ENDIF UNICODE_RTL_DATABASE} - Classes, SysUtils, - {$ENDIF ~HAS_UNITSCOPE} - JclAnsiStrings, - JclWideStrings, - JclBase; - -// Exceptions -type - EJclStringError = class(EJclError); - -// Character constants and sets - -const - // Misc. often used character definitions - NativeNull = Char(#0); - NativeSoh = Char(#1); - NativeStx = Char(#2); - NativeEtx = Char(#3); - NativeEot = Char(#4); - NativeEnq = Char(#5); - NativeAck = Char(#6); - NativeBell = Char(#7); - NativeBackspace = Char(#8); - NativeTab = Char(#9); - NativeLineFeed = JclBase.NativeLineFeed; - NativeVerticalTab = Char(#11); - NativeFormFeed = Char(#12); - NativeCarriageReturn = JclBase.NativeCarriageReturn; - NativeCrLf = JclBase.NativeCrLf; - NativeSo = Char(#14); - NativeSi = Char(#15); - NativeDle = Char(#16); - NativeDc1 = Char(#17); - NativeDc2 = Char(#18); - NativeDc3 = Char(#19); - NativeDc4 = Char(#20); - NativeNak = Char(#21); - NativeSyn = Char(#22); - NativeEtb = Char(#23); - NativeCan = Char(#24); - NativeEm = Char(#25); - NativeEndOfFile = Char(#26); - NativeEscape = Char(#27); - NativeFs = Char(#28); - NativeGs = Char(#29); - NativeRs = Char(#30); - NativeUs = Char(#31); - NativeSpace = Char(' '); - NativeComma = Char(','); - NativeBackslash = Char('\'); - NativeForwardSlash = Char('/'); - - NativeDoubleQuote = Char('"'); - NativeSingleQuote = Char(''''); - - NativeLineBreak = JclBase.NativeLineBreak; - -const - // CharType return values - C1_UPPER = $0001; // Uppercase - C1_LOWER = $0002; // Lowercase - C1_DIGIT = $0004; // Decimal digits - C1_SPACE = $0008; // Space characters - C1_PUNCT = $0010; // Punctuation - C1_CNTRL = $0020; // Control characters - C1_BLANK = $0040; // Blank characters - C1_XDIGIT = $0080; // Hexadecimal digits - C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic - - {$IFDEF MSWINDOWS} - {$IFDEF SUPPORTS_EXTSYM} - {$EXTERNALSYM C1_UPPER} - {$EXTERNALSYM C1_LOWER} - {$EXTERNALSYM C1_DIGIT} - {$EXTERNALSYM C1_SPACE} - {$EXTERNALSYM C1_PUNCT} - {$EXTERNALSYM C1_CNTRL} - {$EXTERNALSYM C1_BLANK} - {$EXTERNALSYM C1_XDIGIT} - {$EXTERNALSYM C1_ALPHA} - {$ENDIF SUPPORTS_EXTSYM} - {$ENDIF MSWINDOWS} - -type - TCharValidator = function(const C: Char): Boolean; - -function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload; -function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; - -// String Test Routines -function StrIsAlpha(const S: string): Boolean; -function StrIsAlphaNum(const S: string): Boolean; -function StrIsAlphaNumUnderscore(const S: string): Boolean; -function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; -function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; -function StrConsistsOfNumberChars(const S: string): Boolean; -function StrIsDigit(const S: string): Boolean; -function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; -function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; -function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; - -// String Transformation Routines -function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; -function StrCharPosLower(const S: string; CharPos: SizeInt): string; -function StrCharPosUpper(const S: string; CharPos: SizeInt): string; -function StrDoubleQuote(const S: string): string; -function StrEnsureNoPrefix(const Prefix, Text: string): string; -function StrEnsureNoSuffix(const Suffix, Text: string): string; -function StrEnsurePrefix(const Prefix, Text: string): string; -function StrEnsureSuffix(const Suffix, Text: string): string; -function StrEscapedToString(const S: string): string; -function StrLower(const S: string): string; -procedure StrLowerInPlace(var S: string); -procedure StrLowerBuff(S: PChar); -procedure StrMove(var Dest: string; const Source: string; const ToIndex, - FromIndex, Count: SizeInt); -function StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string; -function StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string; -function StrProper(const S: string): string; -procedure StrProperBuff(S: PChar); -function StrQuote(const S: string; C: Char): string; -function StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveChars(const S: string; const Chars: array of Char): string; overload; -function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload; -function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload; -function StrKeepChars(const S: string; const Chars: TCharValidator): string; overload; -function StrKeepChars(const S: string; const Chars: array of Char): string; overload; -procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []); -function StrReplaceChar(const S: string; const Source, Replace: Char): string; -function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; -function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; -function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; -function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; -function StrRepeat(const S: string; Count: SizeInt): string; -function StrRepeatLength(const S: string; L: SizeInt): string; -function StrReverse(const S: string): string; -procedure StrReverseInPlace(var S: string); -function StrSingleQuote(const S: string): string; -procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; -procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; -function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; -function StrStringToEscaped(const S: string): string; -function StrStripNonNumberChars(const S: string): string; -function StrToHex(const Source: string): string; -function StrTrimCharLeft(const S: string; C: Char): string; -function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload; -function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; -function StrTrimCharRight(const S: string; C: Char): string; -function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload; -function StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload; -function StrTrimQuotes(const S: string): string; -function StrUpper(const S: string): string; -procedure StrUpperInPlace(var S: string); -procedure StrUpperBuff(S: PChar); - -// String Management -procedure StrAddRef(var S: string); -procedure StrDecRef(var S: string); -function StrLength(const S: string): SizeInt; -function StrRefCount(const S: string): SizeInt; - -// String Search and Replace Routines -function StrCharCount(const S: string; C: Char): SizeInt; overload; -function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload; -function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload; -function StrStrCount(const S, SubS: string): SizeInt; -function StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt; -function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt; -function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -procedure StrFillChar(var S; Count: SizeInt; C: Char); -function StrRepeatChar(C: Char; Count: SizeInt): string; -function StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt; -function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; -function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; -function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt; -function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; -function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; -function StrILastPos(const SubStr, S: string): SizeInt; -function StrIPos(const SubStr, S: string): SizeInt; -function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -function StrIsOneOf(const S: string; const List: array of string): Boolean; -function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -function StrLastPos(const SubStr, S: string): SizeInt; -function StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt; -function StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean; -function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; -function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; -function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -function StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt; -function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; - -// String Extraction -// Returns the String before SubStr -function StrAfter(const SubStr, S: string): string; -/// Returns the string after SubStr -function StrBefore(const SubStr, S: string): string; -/// Splits a string at SubStr, returns true when SubStr is found, Left contains the -/// string before the SubStr and Rigth the string behind SubStr -function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; -/// Returns the string between Start and Stop -function StrBetween(const S: string; const Start, Stop: Char): string; -/// Returns the left N characters of the string -function StrChopRight(const S: string; N: SizeInt): string; -/// Returns the left Count characters of the string -function StrLeft(const S: string; Count: SizeInt): string; -/// Returns the string starting from position Start for the Count Characters -function StrMid(const S: string; Start, Count: SizeInt): string; -/// Returns the string starting from position N to the end -function StrRestOf(const S: string; N: SizeInt): string; -/// Returns the right Count characters of the string -function StrRight(const S: string; Count: SizeInt): string; - -// Character Test Routines -function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} -function CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} -function CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharType(const C: Char): Word; - -// Character Transformation Routines -function CharHex(const C: Char): Byte; -function CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharToggleCase(const C: Char): Char; - -// Character Search and Replace -function CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; -function CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; -function CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt; -function CharReplace(var S: string; const Search, Replace: Char): SizeInt; - -// PCharVector -type - PCharVector = ^PChar; - -function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; -function PCharVectorCount(Source: PCharVector): SizeInt; -procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); -procedure FreePCharVector(var Dest: PCharVector); - -// MultiSz Routines -type - PMultiSz = PChar; - PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz; - PWideMultiSz = JclWideStrings.PWideMultiSz; - - TAnsiStrings = JclAnsiStrings.TJclAnsiStrings; - TWideStrings = JclWideStrings.TJclWideStrings; - TAnsiStringList = JclAnsiStrings.TJclAnsiStringList; - TWideStringList = JclWideStrings.TJclWideStringList; - -function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; -procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); -function MultiSzLength(const Source: PMultiSz): SizeInt; -procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); -procedure FreeMultiSz(var Dest: PMultiSz); -function MultiSzDup(const Source: PMultiSz): PMultiSz; - -function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; - {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} - -function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; - {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} - -// TStrings Manipulation -procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; overload; -function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: - Boolean = True): string; overload; -procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True); -procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True); -procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True); -function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; - -// Miscellaneous -// (OF) moved to JclSysUtils -// function BooleanToStr(B: Boolean): string; - // AnsiString here because it is binary data -function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; -procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; - Append: Boolean = False); - -function StrToken(var S: string; Separator: Char): string; -procedure StrTokens(const S: string; const List: TStrings); -procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); -function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload; -function StrWord(var S: PChar; out Word: string): Boolean; overload; -function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload; -function StrIdent(var S: PChar; out Ident: string): Boolean; overload; -function StrToFloatSafe(const S: string): Float; -function StrToIntSafe(const S: string): Integer; -procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; - -function ArrayOf(List: TStrings): TDynStringArray; overload; - -type - FormatException = class(EJclError); - ArgumentException = class(EJclError); - ArgumentNullException = class(EJclError); - ArgumentOutOfRangeException = class(EJclError); - - IToString = interface - ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] - function ToString: string; - end; - - TCharDynArray = array of Char; - - // The TStringBuilder class is a Delphi implementation of the .NET - // System.Text.StringBuilder. - // It is zero based and the method that allow an TObject (Append, Insert, - // AppendFormat) are limited to IToString implementors. - // This class is not threadsafe. Any instance of TStringBuilder should not - // be used in different threads at the same time. - TJclStringBuilder = class(TInterfacedObject, IToString) - private - FChars: TCharDynArray; - FLength: SizeInt; - FMaxCapacity: SizeInt; - - function GetCapacity: SizeInt; - procedure SetCapacity(const Value: SizeInt); - function GetChars(Index: SizeInt): Char; - procedure SetChars(Index: SizeInt; const Value: Char); - procedure Set_Length(const Value: SizeInt); - protected - function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; - function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; - public - constructor Create(const Value: string; Capacity: SizeInt = 16); overload; - constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload; - constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload; - - function Append(const Value: string): TJclStringBuilder; overload; - function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload; - function Append(Value: Boolean): TJclStringBuilder; overload; - function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload; - function Append(const Value: array of Char): TJclStringBuilder; overload; - function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; - function Append(Value: Cardinal): TJclStringBuilder; overload; - function Append(Value: Integer): TJclStringBuilder; overload; - function Append(Value: Double): TJclStringBuilder; overload; - function Append(Value: Int64): TJclStringBuilder; overload; - function Append(Obj: TObject): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload; - - function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload; - function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload; - function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; - overload; - function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload; - - function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; - overload; - function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; - overload; - - function Remove(StartIndex, Length: SizeInt): TJclStringBuilder; - function EnsureCapacity(Capacity: SizeInt): SizeInt; - - { IToString } - function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} - - property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default; - property Chars: TCharDynArray read FChars; - property Length: SizeInt read FLength write Set_Length; - property Capacity: SizeInt read GetCapacity write SetCapacity; - property MaxCapacity: SizeInt read FMaxCapacity; - end; - - {$IFDEF RTL200_UP} - TStringBuilder = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.TStringBuilder; - {$ELSE ~RTL200_UP} - TStringBuilder = TJclStringBuilder; - {$ENDIF ~RTL200_UP} - -// DotNetFormat() uses the .NET format style: "{argX}" -function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; -function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; -function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; -function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; - -// TJclTabSet -type - TJclTabSet = class (TInterfacedObject, IToString) - private - FData: TObject; - function GetCount: SizeInt; - function GetStops(Index: SizeInt): SizeInt; - function GetTabWidth: SizeInt; - function GetZeroBased: Boolean; - procedure SetStops(Index, Value: SizeInt); - procedure SetTabWidth(Value: SizeInt); - procedure SetZeroBased(Value: Boolean); - protected - function FindStop(Column: SizeInt): SizeInt; - function InternalTabStops: TDynSizeIntArray; - function InternalTabWidth: SizeInt; - procedure RemoveAt(Index: SizeInt); - public - constructor Create; overload; - constructor Create(Data: TObject); overload; - constructor Create(TabWidth: SizeInt); overload; - constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload; - constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload; - destructor Destroy; override; - - // cloning and referencing - function Clone: TJclTabSet; - function NewReference: TJclTabSet; - - // Tab stops manipulation - function Add(Column: SizeInt): SizeInt; - function Delete(Column: SizeInt): SizeInt; - - // Usage - function Expand(const S: string): string; overload; - function Expand(const S: string; Column: SizeInt): string; overload; - procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); - function Optimize(const S: string): string; overload; - function Optimize(const S: string; Column: SizeInt): string; overload; - function StartColumn: SizeInt; - function TabFrom(Column: SizeInt): SizeInt; - function UpdatePosition(const S: string): SizeInt; overload; - function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload; - function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload; - - { IToString } - function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} - // Conversions - function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload; - class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC} - - // Properties - property ActualTabWidth: SizeInt read InternalTabWidth; - property Count: SizeInt read GetCount; - property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default; - property TabWidth: SizeInt read GetTabWidth write SetTabWidth; - property ZeroBased: Boolean read GetZeroBased write SetZeroBased; - end; - -// Formatting constants -const - TabSetFormatting_SurroundStopsWithBrackets = 1; - TabSetFormatting_EmptyBracketsIfNoStops = 2; - TabSetFormatting_NoTabStops = 4; - TabSetFormatting_NoTabWidth = 8; - TabSetFormatting_AutoTabWidth = 16; - // common combinations - TabSetFormatting_Default = 0; - TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or - TabSetFormatting_EmptyBracketsIfNoStops; - TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth; - // aliases - TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth; - TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops; - TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default; - -// Tab expansion routines -function StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -// Tab optimization routines -function StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; - -// move to JclBase? -type - NullReferenceException = class(EJclError) - public - constructor Create; overload; - end; - -procedure StrResetLength(var S: WideString); overload; -procedure StrResetLength(var S: AnsiString); overload; -procedure StrResetLength(S: TJclStringBuilder); overload; -{$IFDEF SUPPORTS_UNICODE_STRING} -procedure StrResetLength(var S: UnicodeString); overload; -{$ENDIF SUPPORTS_UNICODE_STRING} - -// natural comparison functions -function CompareNaturalStr(const S1, S2: string): SizeInt; -function CompareNaturalText(const S1, S2: string): SizeInt; - -{$IFNDEF UNICODE_RTL_DATABASE} -// internal structures published to make function inlining working -const - MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set - StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars - StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars - StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars - StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table - -var - StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings - StrCaseMapReady: Boolean = False; // true if case map exists - StrCharTypes: array [Char] of Word; -{$ENDIF ~UNICODE_RTL_DATABASE} - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNIT_LIBC} - Libc, - {$ENDIF HAS_UNIT_LIBC} - {$IFDEF SUPPORTS_UNICODE} - {$IFDEF HAS_UNITSCOPE} - System.StrUtils, - {$ELSE ~HAS_UNITSCOPE} - StrUtils, - {$ENDIF ~HAS_UNITSCOPE} - {$ENDIF SUPPORTS_UNICODE} - JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils; - -//=== Internal =============================================================== - -type - TStrRec = packed record - RefCount: Longint; - Length: Longint; - end; - PStrRec = ^TStrRec; - -{$IFNDEF UNICODE_RTL_DATABASE} -procedure LoadCharTypes; -var - CurrChar: Char; - CurrType: Word; -begin - for CurrChar := Low(CurrChar) to High(CurrChar) do - begin - {$IFDEF MSWINDOWS} - CurrType := 0; - GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, CurrType); - {$DEFINE CHAR_TYPES_INITIALIZED} - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - CurrType := 0; - if isupper(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_UPPER; - if islower(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_LOWER; - if isdigit(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_DIGIT; - if isspace(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_SPACE; - if ispunct(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_PUNCT; - if iscntrl(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_CNTRL; - if isblank(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_BLANK; - if isxdigit(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_XDIGIT; - if isalpha(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_ALPHA; - {$DEFINE CHAR_TYPES_INITIALIZED} - {$ENDIF LINUX} - StrCharTypes[CurrChar] := CurrType; - {$IFNDEF CHAR_TYPES_INITIALIZED} - Implement case map initialization here - {$ENDIF ~CHAR_TYPES_INITIALIZED} - end; -end; - -procedure LoadCaseMap; -var - CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char; -begin - if not StrCaseMapReady then - begin - for CurrChar := Low(Char) to High(Char) do - begin - {$IFDEF MSWINDOWS} - LoCaseChar := CurrChar; - UpCaseChar := CurrChar; - {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuff(@LoCaseChar, 1); - {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuff(@UpCaseChar, 1); - {$DEFINE CASE_MAP_INITIALIZED} - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - LoCaseChar := Char(tolower(Byte(CurrChar))); - UpCaseChar := Char(toupper(Byte(CurrChar))); - {$DEFINE CASE_MAP_INITIALIZED} - {$ENDIF LINUX} - {$IFNDEF CASE_MAP_INITIALIZED} - Implement case map initialization here - {$ENDIF ~CASE_MAP_INITIALIZED} - if CharIsUpper(CurrChar) then - ReCaseChar := LoCaseChar - else - if CharIsLower(CurrChar) then - ReCaseChar := UpCaseChar - else - ReCaseChar := CurrChar; - StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar; - StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar; - StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar; - end; - StrCaseMapReady := True; - end; -end; - -// Uppercases or Lowercases a give string depending on the -// passed offset. (UpOffset or LoOffset) - -procedure StrCase(var Str: string; const Offset: SizeInt); -var - P: PChar; - I, L: SizeInt; -begin - L := Length(Str); - if L > 0 then - begin - UniqueString(Str); - P := PChar(Str); - for I := 1 to L do - begin - P^ := StrCaseMap[Offset + Ord(P^)]; - Inc(P); - end; - end; -end; - -// Internal utility function -// Uppercases or Lowercases a give null terminated string depending on the -// passed offset. (UpOffset or LoOffset) - -procedure StrCaseBuff(S: PChar; const Offset: SizeInt); -var - C: Char; -begin - if S <> nil then - begin - repeat - C := S^; - S^ := StrCaseMap[Offset + Ord(C)]; - Inc(S); - until C = #0; - end; -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -function StrEndW(Str: PWideChar): PWideChar; -begin - Result := Str; - while Result^ <> #0 do - Inc(Result); -end; - -function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; -var - idx: SizeInt; -begin - Result := ArrayContainsChar(Chars, C, idx); -end; - -function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; -{ optimized version for sorted arrays -var - I, L, H: SizeInt; -begin - L := Low(Chars); - H := High(Chars); - while L <= H do - begin - I := (L + H) div 2; - if C = Chars[I] then - begin - Result := True; - Exit; - end - else - if C < Chars[I] then - H := I - 1 - else - // C > Chars[I] - L := I + 1; - end; - Result := False; -end;} -begin - Index := High(Chars); - while (Index >= Low(Chars)) and (Chars[Index] <> C) do - Dec(Index); - Result := Index >= Low(Chars); -end; - -// String Test Routines -function StrIsAlpha(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsAlpha(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrIsAlphaNum(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsAlphaNum(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrConsistsofNumberChars(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsNumberChar(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; -var - I: SizeInt; -begin - Result := False; - if CheckAll then - begin - // this will not work with the current definition of the validator. The validator would need to check each character - // it requires against the string (which is currently not provided to the Validator). The current implementation of - // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon- - // sistent with the documentation and the array-based overload. - for I := 1 to Length(S) do - begin - Result := Chars(S[I]); - if not Result then - Break; - end; - end - else - begin - for I := 1 to Length(S) do - begin - Result := Chars(S[I]); - if Result then - Break; - end; - end; -end; - -function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; -var - I: SizeInt; -begin - if CheckAll then - begin - Result := True; - I := High(Chars); - while (I >= 0) and Result do - begin - Result := CharPos(S, Chars[I]) > 0; - Dec(I); - end; - end - else - begin - Result := False; - for I := 1 to Length(S) do - begin - Result := ArrayContainsChar(Chars, S[I]); - if Result then - Break; - end; - end; -end; - -function StrIsAlphaNumUnderscore(const S: string): Boolean; -var - I: SizeInt; - C: Char; -begin - for I := 1 to Length(S) do - begin - C := S[I]; - - if not (CharIsAlphaNum(C) or (C = '_')) then - begin - Result := False; - Exit; - end; - end; - - Result := Length(S) > 0; -end; - -function StrIsDigit(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsDigit(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; -var - I: SizeInt; -begin - for I := 1 to Length(S) do - begin - Result := ValidChars(S[I]); - if not Result then - Exit; - end; - - Result := Length(S) > 0; -end; - -function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; -var - I: SizeInt; -begin - for I := 1 to Length(S) do - begin - Result := ArrayContainsChar(ValidChars, S[I]); - if not Result then - Exit; - end; - - Result := Length(S) > 0; -end; - -function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; -begin - Result := StrCompare(S1, S2, CaseSensitive) = 0; -end; - -//=== String Transformation Routines ========================================= - -function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; -begin - if Length(S) < L then - begin - Result := StringOfChar(C, (L - Length(S)) div 2) + S; - Result := Result + StringOfChar(C, L - Length(Result)); - end - else - Result := S; -end; - -function StrCharPosLower(const S: string; CharPos: SizeInt): string; -begin - Result := S; - if (CharPos > 0) and (CharPos <= Length(S)) then - Result[CharPos] := CharLower(Result[CharPos]); -end; - -function StrCharPosUpper(const S: string; CharPos: SizeInt): string; -begin - Result := S; - if (CharPos > 0) and (CharPos <= Length(S)) then - Result[CharPos] := CharUpper(Result[CharPos]); -end; - -function StrDoubleQuote(const S: string): string; -begin - Result := NativeDoubleQuote + S + NativeDoubleQuote; -end; - -function StrEnsureNoPrefix(const Prefix, Text: string): string; -var - PrefixLen: SizeInt; -begin - PrefixLen := Length(Prefix); - if Copy(Text, 1, PrefixLen) = Prefix then - Result := Copy(Text, PrefixLen + 1, Length(Text)) - else - Result := Text; -end; - -function StrEnsureNoSuffix(const Suffix, Text: string): string; -var - SuffixLen: SizeInt; - StrLength: SizeInt; -begin - SuffixLen := Length(Suffix); - StrLength := Length(Text); - if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then - Result := Copy(Text, 1, StrLength - SuffixLen) - else - Result := Text; -end; - -function StrEnsurePrefix(const Prefix, Text: string): string; -var - PrefixLen: SizeInt; -begin - PrefixLen := Length(Prefix); - if Copy(Text, 1, PrefixLen) = Prefix then - Result := Text - else - Result := Prefix + Text; -end; - -function StrEnsureSuffix(const Suffix, Text: string): string; -var - SuffixLen: SizeInt; -begin - SuffixLen := Length(Suffix); - if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then - Result := Text - else - Result := Text + Suffix; -end; - -function StrEscapedToString(const S: string): string; - procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); - const - HexDigits = string('0123456789abcdefABCDEF'); - var - StartI, Val, N: SizeInt; - begin - StartI := I; - N := Pos(S[I + 1], HexDigits) - 1; - if N < 0 then - // '\x' without hex digit following is not escape sequence - Dest := Dest + '\x' - else - begin - Inc(I); // Jump over x - if N >= 16 then - N := N - 6; - Val := N; - // Same for second digit - if I < Len then - begin - N := Pos(S[I + 1], HexDigits) - 1; - if N >= 0 then - begin - Inc(I); // Jump over first digit - if N >= 16 then - N := N - 6; - Val := Val * 16 + N; - end; - end; - - if Val > Ord(High(Char)) then - raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); - - Dest := Dest + Char(Val); - end; - end; - - procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); - const - OctDigits = string('01234567'); - var - StartI, Val, N: SizeInt; - begin - StartI := I; - // first digit - Val := Pos(S[I], OctDigits) - 1; - if I < Len then - begin - N := Pos(S[I + 1], OctDigits) - 1; - if N >= 0 then - begin - Inc(I); - Val := Val * 8 + N; - end; - if I < Len then - begin - N := Pos(S[I + 1], OctDigits) - 1; - if N >= 0 then - begin - Inc(I); - Val := Val * 8 + N; - end; - end; - end; - - if Val > Ord(High(Char)) then - raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); - - Dest := Dest + Char(Val); - end; - -var - I, Len: SizeInt; -begin - Result := ''; - I := 1; - Len := Length(S); - while I <= Len do - begin - if not ((S[I] = '\') and (I < Len)) then - Result := Result + S[I] - else - begin - Inc(I); // Jump over escape character - case S[I] of - 'a': - Result := Result + NativeBell; - 'b': - Result := Result + NativeBackspace; - 'f': - Result := Result + NativeFormFeed; - 'n': - Result := Result + NativeLineFeed; - 'r': - Result := Result + NativeCarriageReturn; - 't': - Result := Result + NativeTab; - 'v': - Result := Result + NativeVerticalTab; - '\': - Result := Result + '\'; - '"': - Result := Result + '"'; - '''': - Result := Result + ''''; // Optionally escaped - '?': - Result := Result + '?'; // Optionally escaped - 'x': - if I < Len then - // Start of hex escape sequence - HandleHexEscapeSeq(S, I, Len, Result) - else - // '\x' at end of string is not escape sequence - Result := Result + '\x'; - '0'..'7': - // start of octal escape sequence - HandleOctEscapeSeq(S, I, Len, Result); - else - // no escape sequence - Result := Result + '\' + S[I]; - end; - end; - Inc(I); - end; -end; - -function StrLower(const S: string): string; -begin - Result := S; - StrLowerInPlace(Result); -end; - -procedure StrLowerInPlace(var S: string); -{$IFDEF UNICODE_RTL_DATABASE} -var - P: PChar; - I, L: SizeInt; -begin - L := Length(S); - if L > 0 then - begin - UniqueString(S); - P := PChar(S); - for I := 1 to L do - begin - P^ := TCharacter.ToLower(P^); - Inc(P); - end; - end; -end; -{$ELSE ~UNICODE_RTL_DATABASE} -begin - StrCase(S, StrLoOffset); -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -procedure StrLowerBuff(S: PChar); -begin - {$IFDEF UNICODE_RTL_DATABASE} - if S <> nil then - begin - repeat - S^ := TCharacter.ToLower(S^); - Inc(S); - until S^ = #0; - end; - {$ELSE ~UNICODE_RTL_DATABASE} - StrCaseBuff(S, StrLoOffset); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -procedure StrMove(var Dest: string; const Source: string; - const ToIndex, FromIndex, Count: SizeInt); -begin - // Check strings - if (Source = '') or (Length(Dest) = 0) then - Exit; - - // Check FromIndex - if (FromIndex <= 0) or (FromIndex > Length(Source)) or - (ToIndex <= 0) or (ToIndex > Length(Dest)) or - ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then - { TODO : Is failure without notice the proper thing to do here? } - Exit; - - // Move - Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char)); -end; - -function StrPadLeft(const S: string; Len: SizeInt; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - if L < Len then - Result := StringOfChar(C, Len - L) + S - else - Result := S; -end; - -function StrPadRight(const S: string; Len: SizeInt; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - if L < Len then - Result := S + StringOfChar(C, Len - L) - else - Result := S; -end; - -function StrProper(const S: string): string; -begin - Result := StrLower(S); - if Result <> '' then - Result[1] := UpCase(Result[1]); -end; - -procedure StrProperBuff(S: PChar); -begin - if (S <> nil) and (S^ <> #0) then - begin - StrLowerBuff(S); - S^ := CharUpper(S^); - end; -end; - -function StrQuote(const S: string; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - Result := S; - if L > 0 then - begin - if Result[1] <> C then - begin - Result := C + Result; - Inc(L); - end; - if Result[L] <> C then - Result := Result + C; - end; -end; - -function StrRemoveChars(const S: string; const Chars: TCharValidator): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if not Chars(Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRemoveChars(const S: string; const Chars: array of Char): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if not ArrayContainsChar(Chars, Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; -var - Len : SizeInt; - I: SizeInt; -begin - Len := Length(S); - I := 1; - while (I <= Len) and Chars(s[I]) do - Inc(I); - Result := Copy (s, I, Len-I+1); -end; - -function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; -var - Len : SizeInt; - I: SizeInt; -begin - Len := Length(S); - I := 1; - while (I <= Len) and ArrayContainsChar(Chars, s[I]) do - Inc(I); - Result := Copy (s, I, Len-I+1); -end; - -function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; -var - Len : SizeInt; -begin - Len := Length(S); - while (Len > 0) and Chars(s[Len]) do - Dec(Len); - Result := Copy (s, 1, Len); -end; - -function StrRemoveEndChars(const S: string; const Chars: array of Char): string; -var - Len : SizeInt; -begin - Len := Length(S); - while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do - Dec(Len); - Result := Copy (s, 1, Len); -end; - -function StrKeepChars(const S: string; const Chars: TCharValidator): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if Chars(Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrKeepChars(const S: string; const Chars: array of Char): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if ArrayContainsChar(Chars, Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRepeat(const S: string; Count: SizeInt): string; -var - Len, Index: SizeInt; - Dest, Source: PChar; -begin - Len := Length(S); - SetLength(Result, Count * Len); - Dest := PChar(Result); - Source := PChar(S); - if Dest <> nil then - for Index := 0 to Count - 1 do - begin - Move(Source^, Dest^, Len * SizeOf(Char)); - Inc(Dest, Len); - end; -end; - -function StrRepeatLength(const S: string; L: SizeInt): string; -var - Len: SizeInt; - Dest: PChar; -begin - Result := ''; - Len := Length(S); - - if (Len > 0) and (S <> '') then - begin - SetLength(Result, L); - Dest := PChar(Result); - while (L > 0) do - begin - Move(S[1], Dest^, Min(L, Len) * SizeOf(Char)); - Inc(Dest, Len); - Dec(L, Len); - end; - end; -end; - -procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags); -var - SearchStr: string; - ResultStr: string; { result string } - SourcePtr: PChar; { pointer into S of character under examination } - SourceMatchPtr: PChar; { pointers into S and Search when first character has } - SearchMatchPtr: PChar; { been matched and we're probing for a complete match } - ResultPtr: PChar; { pointer into Result of character being written } - ResultIndex, - SearchLength, { length of search string } - ReplaceLength, { length of replace string } - BufferLength, { length of temporary result buffer } - ResultLength: SizeInt; { length of result string } - C: Char; { first character of search string } - IgnoreCase: Boolean; -begin - if Search = '' then - begin - if S = '' then - begin - S := Replace; - Exit; - end - else - raise EJclStringError.CreateRes(@RsBlankSearchString); - end; - - if S <> '' then - begin - IgnoreCase := rfIgnoreCase in Flags; - if IgnoreCase then - SearchStr := StrUpper(Search) - else - SearchStr := Search; - { avoid having to call Length() within the loop } - SearchLength := Length(Search); - ReplaceLength := Length(Replace); - ResultLength := Length(S); - BufferLength := ResultLength; - SetLength(ResultStr, BufferLength); - { get pointers to begin of source and result } - ResultPtr := PChar(ResultStr); - SourcePtr := PChar(S); - C := SearchStr[1]; - { while we haven't reached the end of the string } - while True do - begin - { copy characters until we find the first character of the search string } - if IgnoreCase then - while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end - else - while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - { did we find that first character or did we hit the end of the string? } - if SourcePtr^ = #0 then - Break - else - begin - { continue comparing, +1 because first character was matched already } - SourceMatchPtr := SourcePtr + 1; - SearchMatchPtr := PChar(SearchStr) + 1; - if IgnoreCase then - while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do - begin - Inc(SourceMatchPtr); - Inc(SearchMatchPtr); - end - else - while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do - begin - Inc(SourceMatchPtr); - Inc(SearchMatchPtr); - end; - { did we find a complete match? } - if SearchMatchPtr^ = #0 then - begin - // keep track of result length - Inc(ResultLength, ReplaceLength - SearchLength); - if ReplaceLength > 0 then - begin - // increase buffer size if required - if ResultLength > BufferLength then - begin - BufferLength := ResultLength * 2; - ResultIndex := ResultPtr - PChar(ResultStr) + 1; - SetLength(ResultStr, BufferLength); - ResultPtr := @ResultStr[ResultIndex]; - end; - { append replace to result and move past the search string in source } - Move((@Replace[1])^, ResultPtr^, ReplaceLength * SizeOf(Char)); - end; - Inc(SourcePtr, SearchLength); - Inc(ResultPtr, ReplaceLength); - { replace all instances or just one? } - if not (rfReplaceAll in Flags) then - begin - { just one, copy until end of source and break out of loop } - while SourcePtr^ <> #0 do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - Break; - end; - end - else - begin - { copy current character and start over with the next } - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - end; - end; - { set result length and copy result into S } - SetLength(ResultStr, ResultLength); - S := ResultStr; - end; -end; - -function StrReplaceChar(const S: string; const Source, Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if Result[I] = Source then - Result[I] := Replace; -end; - -function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if Chars(Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if ArrayContainsChar(Chars, Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceButChars(const S: string; const Chars: TCharValidator; - Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if not Chars(Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if not ArrayContainsChar(Chars, Result[I]) then - Result[I] := Replace; -end; - -function StrReverse(const S: string): string; -begin - Result := S; - StrReverseInplace(Result); -end; - -procedure StrReverseInPlace(var S: string); -{ TODO -oahuser : Warning: This is dangerous for unicode surrogates } -var - P1, P2: PChar; - C: Char; -begin - UniqueString(S); - P1 := PChar(S); - P2 := P1 + (Length(S) - 1); - while P1 < P2 do - begin - C := P1^; - P1^ := P2^; - P2^ := C; - Inc(P1); - Dec(P2); - end; -end; - -function StrSingleQuote(const S: string): string; -begin - Result := NativeSingleQuote + S + NativeSingleQuote; -end; - -procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); -begin - while Chars(S^) do - Inc(S); -end; - -procedure StrSkipChars(var S: PChar; const Chars: array of Char); -begin - while ArrayContainsChar(Chars, S^) do - Inc(S); -end; - -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); -begin - while Chars(S[Index]) do - Inc(Index); -end; - -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); -begin - while ArrayContainsChar(Chars, S[Index]) do - Inc(Index); -end; - -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; -var - Source, Dest: PChar; - Index, Len: SizeInt; - InternalDelimiters: TCharValidator; -begin - Result := ''; - if Assigned(Delimiters) then - InternalDelimiters := Delimiters - else - InternalDelimiters := CharIsSpace; - - if S <> '' then - begin - Result := S; - UniqueString(Result); - - Len := Length(S); - Source := PChar(S); - Dest := PChar(Result); - Inc(Dest); - - for Index := 2 to Len do - begin - if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then - Dest^ := CharUpper(Dest^); - Inc(Dest); - Inc(Source); - end; - Result[1] := CharUpper(Result[1]); - end; -end; - -function StrSmartCase(const S: string; const Delimiters: array of Char): string; -var - Source, Dest: PChar; - Index, Len: SizeInt; -begin - Result := ''; - - if S <> '' then - begin - Result := S; - UniqueString(Result); - - Len := Length(S); - Source := PChar(S); - Dest := PChar(Result); - Inc(Dest); - - for Index := 2 to Len do - begin - if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then - Dest^ := CharUpper(Dest^); - Inc(Dest); - Inc(Source); - end; - Result[1] := CharUpper(Result[1]); - end; -end; - -function StrStringToEscaped(const S: string): string; -var - I: SizeInt; -begin - Result := ''; - for I := 1 to Length(S) do - begin - case S[I] of - NativeBackspace: - Result := Result + '\b'; - NativeBell: - Result := Result + '\a'; - NativeCarriageReturn: - Result := Result + '\r'; - NAtiveFormFeed: - Result := Result + '\f'; - NativeLineFeed: - Result := Result + '\n'; - NativeTab: - Result := Result + '\t'; - NativeVerticalTab: - Result := Result + '\v'; - NativeBackSlash: - Result := Result + '\\'; - NativeDoubleQuote: - Result := Result + '\"'; - else - // Characters < ' ' are escaped with hex sequence - if S[I] < #32 then - Result := Result + Format('\x%.2x', [SizeInt(S[I])]) - else - Result := Result + S[I]; - end; - end; -end; - -function StrStripNonNumberChars(const S: string): string; -var - I: SizeInt; - C: Char; -begin - Result := ''; - for I := 1 to Length(S) do - begin - C := S[I]; - if CharIsNumberChar(C) then - Result := Result + C; - end; -end; - -function StrToHex(const Source: string): string; -var - Index: SizeInt; - C, L, N: SizeInt; - BL, BH: Byte; - S: string; -begin - Result := ''; - if Source <> '' then - begin - S := Source; - L := Length(S); - if Odd(L) then - begin - S := '0' + S; - Inc(L); - end; - Index := 1; - SetLength(Result, L div 2); - C := 1; - N := 1; - while C <= L do - begin - BH := CharHex(S[Index]); - Inc(Index); - BL := CharHex(S[Index]); - Inc(Index); - Inc(C, 2); - if (BH = $FF) or (BL = $FF) then - begin - Result := ''; - Exit; - end; - Result[N] := Char((BH shl 4) or BL); - Inc(N); - end; - end; -end; - -function StrTrimCharLeft(const S: string; C: Char): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and (S[I] = C) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and Chars(S[I]) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and ArrayContainsChar(Chars, S[I]) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharRight(const S: string; C: Char): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and (S[I] = C) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and Chars(S[I]) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimCharsRight(const S: string; const Chars: array of Char): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and ArrayContainsChar(Chars, S[I]) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimQuotes(const S: string): string; -var - First, Last: Char; - L: SizeInt; -begin - L := Length(S); - if L > 1 then - begin - First := S[1]; - Last := S[L]; - if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) then - Result := Copy(S, 2, L - 2) - else - Result := S; - end - else - Result := S; -end; - -function StrUpper(const S: string): string; -begin - Result := S; - StrUpperInPlace(Result); -end; - -procedure StrUpperInPlace(var S: string); -{$IFDEF UNICODE_RTL_DATABASE} -var - P: PChar; - I, L: SizeInt; -begin - L := Length(S); - if L > 0 then - begin - UniqueString(S); - P := PChar(S); - for I := 1 to L do - begin - P^ := TCharacter.ToUpper(P^); - Inc(P); - end; - end; -end; -{$ELSE ~UNICODE_RTL_DATABASE} -begin - StrCase(S, StrUpOffset); -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -procedure StrUpperBuff(S: PChar); -begin - {$IFDEF UNICODE_RTL_DATABASE} - if S <> nil then - begin - repeat - S^ := TCharacter.ToUpper(S^); - Inc(S); - until S^ = #0; - end; - {$ELSE ~UNICODE_RTL_DATABASE} - StrCaseBuff(S, StrUpOffset); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== String Management ====================================================== - -procedure StrAddRef(var S: string); -var - P: PStrRec; -begin - P := Pointer(S); - if P <> nil then - begin - Dec(P); - if P^.RefCount = -1 then - UniqueString(S) - else - LockedInc(P^.RefCount); - end; -end; - -procedure StrDecRef(var S: string); -var - P: PStrRec; -begin - P := Pointer(S); - if P <> nil then - begin - Dec(P); - case P^.RefCount of - -1, 0: { nothing } ; - 1: - begin - Finalize(S); - Pointer(S) := nil; - end; - else - LockedDec(P^.RefCount); - end; - end; -end; - -function StrLength(const S: string): SizeInt; -var - P: PStrRec; -begin - Result := 0; - P := Pointer(S); - if P <> nil then - begin - Dec(P); - Result := P^.Length and (not $80000000 shr 1); - end; -end; - -function StrRefCount(const S: string): SizeInt; -var - P: PStrRec; -begin - Result := 0; - P := Pointer(S); - if P <> nil then - begin - Dec(P); - Result := P^.RefCount; - end; -end; - -procedure StrResetLength(var S: WideString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; - -procedure StrResetLength(var S: AnsiString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; - -procedure StrResetLength(S: TJclStringBuilder); -var - I: SizeInt; -begin - if S <> nil then - for I := 0 to S.Length - 1 do - if S[I] = #0 then - begin - S.Length := I; - Exit; - end; -end; - -{$IFDEF SUPPORTS_UNICODE_STRING} -procedure StrResetLength(var S: UnicodeString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; -{$ENDIF SUPPORTS_UNICODE_STRING} - -//=== String Search and Replace Routines ===================================== - -function StrCharCount(const S: string; C: Char): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if S[I] = C then - Inc(Result); -end; - -function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if Chars(S[I]) then - Inc(Result); -end; - -function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if ArrayContainsChar(Chars, S[I]) then - Inc(Result); -end; - -function StrStrCount(const S, SubS: string): SizeInt; -var - I: SizeInt; -begin - Result := 0; - if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then - Exit; - if Length(SubS) = 1 then - begin - Result := StrCharCount(S, SubS[1]); - Exit; - end; - I := StrSearch(SubS, S, 1); - - if I > 0 then - Inc(Result); - - while (I > 0) and (Length(S) > I + Length(SubS)) do - begin - I := StrSearch(SubS, S, I + 1); - - if I > 0 then - Inc(Result); - end; -end; - -(* -{ 1} Test(StrCompareRange('', '', 1, 5), 0); -{ 2} Test(StrCompareRange('A', '', 1, 5), -1); -{ 3} Test(StrCompareRange('AB', '', 1, 5), -1); -{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1); -{ 5} Test(StrCompareRange('', 'A', 1, 5), -1); -{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1); -{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1); -{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2); -{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32); -{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0); -{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1); -{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1); -{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32); -{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32); -{15} Test(StrCompareRange('', '', 1, 0), 0); -{16} Test(StrCompareRange('A', 'A', 1, 0), -2); -{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2); -{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0); -{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0); -{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1); -*) -function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -var - Len1, Len2: SizeInt; - I: SizeInt; - C1, C2: Char; -begin - if Pointer(S1) = Pointer(S2) then - begin - if (Count <= 0) and (S1 <> '') then - Result := -2 // no work - else - Result := 0; - end - else - if (S1 = '') or (S2 = '') then - Result := -1 // null string - else - if Count <= 0 then - Result := -2 // no work - else - begin - Len1 := Length(S1); - Len2 := Length(S2); - - if (Index - 1) + Count > Len1 then - Result := -2 - else - begin - if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it - Count := Len2 - (Index - 1); - - if CaseSensitive then - begin - for I := 0 to Count - 1 do - begin - C1 := S1[Index + I]; - C2 := S2[Index + I]; - if C1 <> C2 then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - end; - end - else - begin - for I := 0 to Count - 1 do - begin - C1 := S1[Index + I]; - C2 := S2[Index + I]; - if C1 <> C2 then - begin - C1 := CharLower(C1); - C2 := CharLower(C2); - if C1 <> C2 then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - end; - end; - end; - Result := 0; - end; - end; -end; - -function StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt; -var - Len1, Len2: SizeInt; -begin - if Pointer(S1) = Pointer(S2) then - Result := 0 - else - begin - Len1 := Length(S1); - Len2 := Length(S2); - Result := Len1 - Len2; - if Result = 0 then - Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive); - end; -end; - -function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -begin - Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive); -end; - -procedure StrFillChar(var S; Count: SizeInt; C: Char); -{$IFDEF SUPPORTS_UNICODE} -asm - // 32 --> EAX S - // EDX Count - // ECX C - // 64 --> RCX S - // RDX Count - // R8W C - {$IFDEF CPU32} - DEC EDX - JS @@Leave -@@Loop: - MOV [EAX], CX - ADD EAX, 2 - DEC EDX - JNS @@Loop - {$ENDIF CPU32} - {$IFDEF CPU64} - DEC RDX - JS @@Leave -@@Loop: - MOV WORD PTR [RCX], R8W - ADD RCX, 2 - DEC RDX - JNS @@Loop - {$ENDIF CPU64} -@@Leave: -end; -{$ELSE ~SUPPORTS_UNICODE} -begin - if Count > 0 then - FillChar(S, Count, C); -end; -{$ENDIF ~SUPPORTS_UNICODE} - -function StrRepeatChar(C: Char; Count: SizeInt): string; -begin - SetLength(Result, Count); - if Count > 0 then - StrFillChar(Result[1], Count, C); -end; - -function StrFind(const Substr, S: string; const Index: SizeInt): SizeInt; -var - pos: SizeInt; -begin - if (SubStr <> '') and (S <> '') then - begin - pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1)); - if pos = 0 then - Result := 0 - else - Result := Index + Pos - 1; - end - else - Result := 0; -end; - -function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; -begin - Result := StrPrefixIndex(S, Prefixes) > -1; -end; - -function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; -begin - Result := StrSuffixIndex(S, Suffixes) > -1; -end; - -function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean): SizeInt; -var - I: SizeInt; -begin - Result := -1; - for I := Low(List) to High(List) do - begin - if StrCompare(S, List[I], CaseSensitive) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; -begin - Result := StrIPrefixIndex(S, Prefixes) > -1; -end; - -function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; -begin - Result := StrISuffixIndex(S, Suffixes) > -1; -end; - -function StrILastPos(const SubStr, S: string): SizeInt; -begin - Result := StrLastPos(StrUpper(SubStr), StrUpper(S)); -end; - -function StrIPos(const SubStr, S: string): SizeInt; -begin - Result := Pos(StrUpper(SubStr), StrUpper(S)); -end; - -function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Prefixes) to High(Prefixes) do - begin - Test := StrLeft(S, Length(Prefixes[I])); - if CompareText(Test, Prefixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrIsOneOf(const S: string; const List: array of string): Boolean; -begin - Result := StrIndex(S, List) > -1; -end; - -function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Suffixes) to High(Suffixes) do - begin - Test := StrRight(S, Length(Suffixes[I])); - if CompareText(Test, Suffixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrLastPos(const SubStr, S: string): SizeInt; -var - Last, Current: PChar; -begin - Result := 0; - Last := nil; - Current := PChar(S); - - while (Current <> nil) and (Current^ <> #0) do - begin - Current := StrPos(PChar(Current), PChar(SubStr)); - if Current <> nil then - begin - Last := Current; - Inc(Current); - end; - end; - if Last <> nil then - Result := Abs(PChar(S) - Last) + 1; -end; - -// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*) -// (*) acts like (?) - -function StrMatch(const Substr, S: string; Index: SizeInt): SizeInt; -var - SI, SubI, SLen, SubLen: SizeInt; - SubC: Char; -begin - SLen := Length(S); - SubLen := Length(Substr); - Result := 0; - if (Index > SLen) or (SubLen = 0) then - Exit; - while Index <= SLen do - begin - SubI := 1; - SI := Index; - while (SI <= SLen) and (SubI <= SubLen) do - begin - SubC := Substr[SubI]; - if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then - begin - Inc(SI); - Inc(SubI); - end - else - Break; - end; - if SubI > SubLen then - begin - Result := Index; - Break; - end; - Inc(Index); - end; -end; - -// Derived from "Like" by Michael Winter -function StrMatches(const Substr, S: string; const Index: SizeInt): Boolean; -var - StringPtr: PChar; - PatternPtr: PChar; - StringRes: PChar; - PatternRes: PChar; -begin - if SubStr = '' then - raise EJclStringError.CreateRes(@RsBlankSearchString); - - Result := SubStr = '*'; - - if Result or (S = '') then - Exit; - - if (Index <= 0) or (Index > Length(S)) then - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - - StringPtr := PChar(@S[Index]); - PatternPtr := PChar(SubStr); - StringRes := nil; - PatternRes := nil; - - repeat - repeat - case PatternPtr^ of - #0: - begin - Result := StringPtr^ = #0; - if Result or (StringRes = nil) or (PatternRes = nil) then - Exit; - - StringPtr := StringRes; - PatternPtr := PatternRes; - Break; - end; - '*': - begin - Inc(PatternPtr); - PatternRes := PatternPtr; - Break; - end; - '?': - begin - if StringPtr^ = #0 then - Exit; - Inc(StringPtr); - Inc(PatternPtr); - end; - else - begin - if StringPtr^ = #0 then - Exit; - if StringPtr^ <> PatternPtr^ then - begin - if (StringRes = nil) or (PatternRes = nil) then - Exit; - StringPtr := StringRes; - PatternPtr := PatternRes; - Break; - end - else - begin - Inc(StringPtr); - Inc(PatternPtr); - end; - end; - end; - until False; - - repeat - case PatternPtr^ of - #0: - begin - Result := True; - Exit; - end; - '*': - begin - Inc(PatternPtr); - PatternRes := PatternPtr; - end; - '?': - begin - if StringPtr^ = #0 then - Exit; - Inc(StringPtr); - Inc(PatternPtr); - end; - else - begin - repeat - if StringPtr^ = #0 then - Exit; - if StringPtr^ = PatternPtr^ then - Break; - Inc(StringPtr); - until False; - Inc(StringPtr); - StringRes := StringPtr; - Inc(PatternPtr); - Break; - end; - end; - until False; - until False; -end; - -function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; -var - I, P: SizeInt; -begin - if N < 1 then - begin - Result := 0; - Exit; - end; - - Result := StrSearch(SubStr, S, 1); - I := 1; - while I < N do - begin - P := StrSearch(SubStr, S, Result + 1); - if P = 0 then - begin - Result := 0; - Break; - end - else - begin - Result := P; - Inc(I); - end; - end; -end; - -function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; -var - I, P: SizeInt; -begin - if N < 1 then - begin - Result := 0; - Exit; - end; - - Result := StrFind(SubStr, S, 1); - I := 1; - while I < N do - begin - P := StrFind(SubStr, S, Result + 1); - if P = 0 then - begin - Result := 0; - Break; - end - else - begin - Result := P; - Inc(I); - end; - end; -end; - -function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Prefixes) to High(Prefixes) do - begin - Test := StrLeft(S, Length(Prefixes[I])); - if CompareStr(Test, Prefixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt; -var - SP, SPI, SubP: PChar; - SLen: SizeInt; -begin - SLen := Length(S); - if Index <= SLen then - begin - SP := PChar(S); - SubP := PChar(Substr); - SPI := SP; - Inc(SPI, Index); - Dec(SPI); - SPI := StrPos(SPI, SubP); - if SPI <> nil then - Result := SPI - SP + 1 - else - Result := 0; - end - else - Result := 0; -end; - -function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Suffixes) to High(Suffixes) do - begin - Test := StrRight(S, Length(Suffixes[I])); - if CompareStr(Test, Suffixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -//=== String Extraction ====================================================== - -function StrAfter(const SubStr, S: string): string; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos - if P <= 0 then - Result := '' // substr not found -> nothing after it - else - Result := StrRestOf(S, P + Length(SubStr)); -end; - -function StrBefore(const SubStr, S: string): string; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); - if P <= 0 then - Result := S - else - Result := StrLeft(S, P - 1); -end; - -function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); - Result:= p > 0; - if Result then - begin - Left := StrLeft(S, P - 1); - Right := StrRestOf(S, P + Length(SubStr)); - end - else - begin - Left := ''; - Right := ''; - end; -end; - -function StrBetween(const S: string; const Start, Stop: Char): string; -var - PosStart, PosEnd: SizeInt; - L: SizeInt; -begin - PosStart := Pos(Start, S); - PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart. - - if (PosStart > 0) and (PosEnd > PosStart) then - begin - L := PosEnd - PosStart; - Result := Copy(S, PosStart + 1, L - 1); - end - else - Result := ''; -end; - -function StrChopRight(const S: string; N: SizeInt): string; -begin - Result := Copy(S, 1, Length(S) - N); -end; - -function StrLeft(const S: string; Count: SizeInt): string; -begin - Result := Copy(S, 1, Count); -end; - -function StrMid(const S: string; Start, Count: SizeInt): string; -begin - Result := Copy(S, Start, Count); -end; - -function StrRestOf(const S: string; N: SizeInt): string; -begin - Result := Copy(S, N, (Length(S) - N + 1)); -end; - -function StrRight(const S: string; Count: SizeInt): string; -begin - Result := Copy(S, Length(S) - Count + 1, Count); -end; - -//=== Character (do we have it ;) ============================================ - -function CharEqualNoCase(const C1, C2: Char): Boolean; -begin - //if they are not equal chars, may be same letter different case - Result := (C1 = C2) or - (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2))); -end; - - -function CharIsAlpha(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLetter(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_ALPHA) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsAlphaNum(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLetterOrDigit(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsBlank(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx - Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_BLANK) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsControl(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsControl(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_CNTRL) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsDelete(const C: Char): Boolean; -begin - Result := (C = #8); -end; - -function CharIsDigit(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsDigit(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_DIGIT) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsFracDigit(const C: Char): Boolean; -begin - Result := (C = '.') or CharIsDigit(C); -end; - -function CharIsHexDigit(const C: Char): Boolean; -begin - case C of - 'A'..'F', - 'a'..'f': - Result := True; - else - Result := CharIsDigit(C); - end; -end; - -function CharIsLower(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLower(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_LOWER) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsNumberChar(const C: Char): Boolean; -begin - Result := CharIsDigit(C) or (C = '+') or (C = '-') or (C = JclFormatSettings.DecimalSeparator); -end; - -function CharIsNumber(const C: Char): Boolean; -begin - Result := CharIsDigit(C) or (C = JclFormatSettings.DecimalSeparator); -end; - -function CharIsPrintable(const C: Char): Boolean; -begin - Result := not CharIsControl(C); -end; - -function CharIsPunctuation(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsPunctuation(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_PUNCT) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsReturn(const C: Char): Boolean; -begin - Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); -end; - -function CharIsSpace(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsWhiteSpace(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_SPACE) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsUpper(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsUpper(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_UPPER) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsValidIdentifierLetter(const C: Char): Boolean; -begin - case C of - {$IFDEF SUPPORTS_UNICODE} - // from XML specifications - #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D, - #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF, - #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs? - #$00B7, #$0300..#$036F, #$203F..#$2040, - {$ENDIF SUPPORTS_UNICODE} - '0'..'9', 'A'..'Z', 'a'..'z', '_': - Result := True; - else - Result := False; - end; -end; - -function CharIsWhiteSpace(const C: Char): Boolean; -begin - case C of - NativeTab, - NativeLineFeed, - NativeVerticalTab, - NativeFormFeed, - NativeCarriageReturn, - NativeSpace: - Result := True; - else - Result := False; - end; -end; - -function CharIsWildcard(const C: Char): Boolean; -begin - case C of - '*', '?': - Result := True; - else - Result := False; - end; -end; - -function CharType(const C: Char): Word; -begin - {$IFDEF UNICODE_RTL_DATABASE} - GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCharTypes[C]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== PCharVector ============================================================ - -function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; -var - I: SizeInt; - S: string; - List: array of PChar; -begin - Assert(Source <> nil); - Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar)); - SetLength(List, Source.Count + SizeOf(Char)); - for I := 0 to Source.Count - 1 do - begin - S := Source[I]; - List[I] := StrAlloc(Length(S) + SizeOf(Char)); - StrPCopy(List[I], S); - end; - List[Source.Count] := nil; - Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar)); - Result := Dest; -end; - -function PCharVectorCount(Source: PCharVector): SizeInt; -begin - Result := 0; - if Source <> nil then - begin - while Source^ <> nil do - begin - Inc(Source); - Inc(Result); - end; - end; -end; - -procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); -var - I, Count: SizeInt; - List: array of PChar; -begin - Assert(Dest <> nil); - if Source <> nil then - begin - Count := PCharVectorCount(Source); - SetLength(List, Count); - Move(Source^, List[0], Count * SizeOf(PChar)); - Dest.BeginUpdate; - try - Dest.Clear; - for I := 0 to Count - 1 do - Dest.Add(List[I]); - finally - Dest.EndUpdate; - end; - end; -end; - -procedure FreePCharVector(var Dest: PCharVector); -var - I, Count: SizeInt; - List: array of PChar; -begin - if Dest <> nil then - begin - Count := PCharVectorCount(Dest); - SetLength(List, Count); - Move(Dest^, List[0], Count * SizeOf(PChar)); - for I := 0 to Count - 1 do - StrDispose(List[I]); - FreeMem(Dest, (Count + 1) * SizeOf(PChar)); - Dest := nil; - end; -end; - -//=== Character Transformation Routines ====================================== - -function CharHex(const C: Char): Byte; -begin - case C of - '0'..'9': - Result := Ord(C) - Ord('0'); - 'a'..'f': - Result := Ord(C) - Ord('a') + 10; - 'A'..'F': - Result := Ord(C) - Ord('A') + 10; - else - Result := $FF; - end; -end; - -function CharLower(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.ToLower(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrLoOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharToggleCase(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - if CharIsLower(C) then - Result := CharUpper(C) - else if CharIsUpper(C) then - Result := CharLower(C) - else - Result := C; - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrReOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharUpper(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.ToUpper(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrUpOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== Character Search and Replace =========================================== - -function CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - for Result := Length(S) downto Index do - if S[Result] = C then - Exit; - end; - Result := 0; -end; - -function CharPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - for Result := Index to Length(S) do - if S[Result] = C then - Exit; - end; - Result := 0; -end; - -function CharIPos(const S: string; C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - C := CharUpper(C); - for Result := Index to Length(S) do - if CharUpper(S[Result]) = C then - Exit; - end; - Result := 0; -end; - -function CharReplace(var S: string; const Search, Replace: Char): SizeInt; -var - P: PChar; - Index, Len: SizeInt; -begin - Result := 0; - if Search <> Replace then - begin - UniqueString(S); - P := PChar(S); - Len := Length(S); - for Index := 0 to Len - 1 do - begin - if P^ = Search then - begin - P^ := Replace; - Inc(Result); - end; - Inc(P); - end; - end; -end; - -//=== MultiSz ================================================================ - -function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; -var - I, TotalLength: SizeInt; - P: PMultiSz; -begin - Assert(Source <> nil); - TotalLength := 1; - for I := 0 to Source.Count - 1 do - if Source[I] = '' then - raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem) - else - Inc(TotalLength, StrLen(PChar(Source[I])) + 1); - AllocateMultiSz(Dest, TotalLength); - P := Dest; - for I := 0 to Source.Count - 1 do - begin - P := StrECopy(P, PChar(Source[I])); - Inc(P); - end; - P^ := #0; - Result := Dest; -end; - -procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); -var - P: PMultiSz; -begin - Assert(Dest <> nil); - Dest.BeginUpdate; - try - Dest.Clear; - if Source <> nil then - begin - P := Source; - while P^ <> #0 do - begin - Dest.Add(P); - P := StrEnd(P); - Inc(P); - end; - end; - finally - Dest.EndUpdate; - end; -end; - -function MultiSzLength(const Source: PMultiSz): SizeInt; -var - P: PMultiSz; -begin - Result := 0; - if Source <> nil then - begin - P := Source; - repeat - Inc(Result, StrLen(P) + 1); - P := StrEnd(P); - Inc(P); - until P^ = #0; - Inc(Result); - end; -end; - -procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); -begin - if Len > 0 then - GetMem(Dest, Len * SizeOf(Char)) - else - Dest := nil; -end; - -procedure FreeMultiSz(var Dest: PMultiSz); -begin - if Dest <> nil then - FreeMem(Dest); - Dest := nil; -end; - -function MultiSzDup(const Source: PMultiSz): PMultiSz; -var - Len: SizeInt; -begin - if Source <> nil then - begin - Len := MultiSzLength(Source); - Result := nil; - AllocateMultiSz(Result, Len); - Move(Source^, Result^, Len * SizeOf(Char)); - end - else - Result := nil; -end; - -function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; -begin - Result := JclAnsiStrings.StringsToMultiSz(Dest, Source); -end; - -procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); -begin - JclAnsiStrings.MultiSzToStrings(Dest, Source); -end; - -function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; -begin - Result := JclAnsiStrings.MultiSzLength(Source); -end; - -procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); -begin - JclAnsiStrings.AllocateMultiSz(Dest, Len); -end; - -procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); -begin - JclAnsiStrings.FreeMultiSz(Dest); -end; - -function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; -begin - Result := JclAnsiStrings.MultiSzDup(Source); -end; - -function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; -begin - Result := JclWideStrings.StringsToMultiSz(Dest, Source); -end; - -procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); -begin - JclWideStrings.MultiSzToStrings(Dest, Source); -end; - -function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; -begin - Result := JclWideStrings.MultiSzLength(Source); -end; - -procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); -begin - JclWideStrings.AllocateMultiSz(Dest, Len); -end; - -procedure FreeWideMultiSz(var Dest: PWideMultiSz); -begin - JclWideStrings.FreeMultiSz(Dest); -end; - -function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; -begin - Result := JclWideStrings.MultiSzDup(Source); -end; - -//=== TStrings Manipulation ================================================== - -procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -var - I, L: SizeInt; - Left: string; -begin - Assert(List <> nil); - List.BeginUpdate; - try - List.Clear; - L := Length(Sep); - I := Pos(Sep, S); - while I > 0 do - begin - Left := StrLeft(S, I - 1); - if (Left <> '') or AllowEmptyString then - List.Add(Left); - Delete(S, 1, I + L - 1); - I := Pos(Sep, S); - end; - if S <> '' then - List.Add(S); // Ignore empty strings at the end. - finally - List.EndUpdate; - end; -end; - -procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -var - I, L: SizeInt; - LowerCaseStr: string; - Left: string; -begin - Assert(List <> nil); - LowerCaseStr := StrLower(S); - Sep := StrLower(Sep); - L := Length(Sep); - I := Pos(Sep, LowerCaseStr); - List.BeginUpdate; - try - List.Clear; - while I > 0 do - begin - Left := StrLeft(S, I - 1); - if (Left <> '') or AllowEmptyString then - List.Add(Left); - Delete(S, 1, I + L - 1); - Delete(LowerCaseStr, 1, I + L - 1); - I := Pos(Sep, LowerCaseStr); - end; - if S <> '' then - List.Add(S); // Ignore empty strings at the end. - finally - List.EndUpdate; - end; -end; - -function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; -var - I, L: SizeInt; -begin - Result := ''; - for I := 0 to List.Count - 1 do - begin - if (List[I] <> '') or AllowEmptyString then - begin - // don't combine these into one addition, somehow it hurts performance - Result := Result + List[I]; - Result := Result + Sep; - end; - end; - // remove terminating separator - if List.Count > 0 then - begin - L := Length(Sep); - Delete(Result, Length(Result) - L + 1, L); - end; -end; - -function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: - Boolean = True): string; -var - I, L, N: SizeInt; -begin - Result := ''; - if List.Count > NumberOfItems then - N := NumberOfItems - else - N := List.Count; - for I := 0 to N - 1 do - begin - if (List[I] <> '') or AllowEmptyString then - begin - // don't combine these into one addition, somehow it hurts performance - Result := Result + List[I]; - Result := Result + Sep; - end; - end; - // remove terminating separator - if N > 0 then - begin - L := Length(Sep); - Delete(Result, Length(Result) - L + 1, L); - end; -end; - -procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := Trim(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := TrimRight(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := TrimLeft(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; -begin - Assert(Strings <> nil); - Result := Unique and (Strings.IndexOf(S) <> -1); - if not Result then - Result := Strings.Add(S) > -1; -end; - -//=== Miscellaneous ========================================================== - -function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; -var - fs: TFileStream; - Len: SizeInt; -begin - fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - Len := fs.Size; - SetLength(Result, Len); - if Len > 0 then - fs.ReadBuffer(Result[1], Len); - finally - fs.Free; - end; -end; - -procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; - Append: Boolean); -var - FS: TFileStream; - Len: SizeInt; -begin - if Append and FileExists(filename) then - FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite) - else - FS := TFileStream.Create(FileName, fmCreate); - try - if Append then - FS.Seek(0, soEnd); // faster than .Position := .Size - Len := Length(Contents); - if Len > 0 then - FS.WriteBuffer(Contents[1], Len); - finally - FS.Free; - end; -end; - -function StrToken(var S: string; Separator: Char): string; -var - I: SizeInt; -begin - I := Pos(Separator, S); - if I <> 0 then - begin - Result := Copy(S, 1, I - 1); - Delete(S, 1, I); - end - else - begin - Result := S; - S := ''; - end; -end; - -procedure StrTokens(const S: string; const List: TStrings); -var - Start: PChar; - Token: string; - Done: Boolean; -begin - Assert(List <> nil); - if List = nil then - Exit; - - List.BeginUpdate; - try - List.Clear; - Start := Pointer(S); - repeat - Done := JclStrings.StrWord(Start, Token); - if Token <> '' then - List.Add(Token); - until Done; - finally - List.EndUpdate; - end; -end; - -function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; -var - Start: SizeInt; - C: Char; -begin - Word := ''; - if (S = '') then - begin - Result := True; - Exit; - end; - Start := Index; - Result := False; - while True do - begin - C := S[Index]; - case C of - #0: - begin - if Start <> 0 then - Word := Copy(S, Start, Index - Start); - Result := True; - Exit; - end; - NativeSpace, NativeLineFeed, NativeCarriageReturn: - begin - if Start <> 0 then - begin - Word := Copy(S, Start, Index - Start); - Exit; - end - else - begin - while CharIsWhiteSpace(C) do - begin - Inc(Index); - C := S[Index]; - end; - end; - end; - else - if Start = 0 then - Start := Index; - Inc(Index); - end; - end; -end; - -function StrWord(var S: PChar; out Word: string): Boolean; -var - Start: PChar; -begin - Word := ''; - if S = nil then - begin - Result := True; - Exit; - end; - Start := nil; - Result := False; - while True do - begin - case S^ of - #0: - begin - if Start <> nil then - SetString(Word, Start, S - Start); - Result := True; - Exit; - end; - NativeSpace, NativeLineFeed, NativeCarriageReturn: - begin - if Start <> nil then - begin - SetString(Word, Start, S - Start); - Exit; - end - else - while CharIsWhiteSpace(S^) do - Inc(S); - end; - else - if Start = nil then - Start := S; - Inc(S); - end; - end; -end; - -function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; -var - Start: SizeInt; - C: Char; -begin - Ident := ''; - if (S = '') then - begin - Result := True; - Exit; - end; - Start := Index; - Result := False; - while True do - begin - C := S[Index]; - if CharIsValidIdentifierLetter(C) then - begin - if Start = 0 then - Start := Index; - end - else - if C = #0 then - begin - if Start <> 0 then - Ident := Copy(S, Start, Index - Start); - Result := True; - Exit; - end - else - begin - if Start <> 0 then - begin - Ident := Copy(S, Start, Index - Start); - Exit; - end; - end; - Inc(Index); - end; -end; - -function StrIdent(var S: PChar; out Ident: string): Boolean; -var - Start: PChar; - C: Char; -begin - Ident := ''; - if S = nil then - begin - Result := True; - Exit; - end; - Start := nil; - Result := False; - while True do - begin - C := S^; - if CharIsValidIdentifierLetter(C) then - begin - if Start = nil then - Start := S; - end - else - if C = #0 then - begin - if Start <> nil then - SetString(Ident, Start, S - Start); - Result := True; - Exit; - end - else - begin - if Start <> nil then - begin - SetString(Ident, Start, S - Start); - Exit; - end - end; - Inc(S); - end; -end; - -procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); -var - Token: string; -begin - Assert(List <> nil); - - if List = nil then - Exit; - - List.BeginUpdate; - try - List.Clear; - while S <> '' do - begin - Token := StrToken(S, Separator); - List.Add(Token); - end; - finally - List.EndUpdate; - end; -end; - -function StrToFloatSafe(const S: string): Float; -var - Temp: string; - I, J, K: SizeInt; - SwapSeparators, IsNegative: Boolean; - DecSep, ThouSep, C: Char; -begin - DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator; - ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator; - Temp := S; - SwapSeparators := False; - - IsNegative := False; - J := 0; - for I := 1 to Length(Temp) do - begin - C := Temp[I]; - if C = '-' then - IsNegative := not IsNegative - else - if (C <> ' ') and (C <> '(') and (C <> '+') then - begin - // if it appears prior to any digit, it has to be a decimal separator - SwapSeparators := Temp[I] = ThouSep; - J := I; - Break; - end; - end; - - if not SwapSeparators then - begin - K := CharPos(Temp, DecSep); - SwapSeparators := - // if it appears prior to any digit, it has to be a decimal separator - (K > J) and - // if it appears multiple times, it has to be a thousand separator - ((StrCharCount(Temp, DecSep) > 1) or - // we assume (consistent with Windows Platform SDK documentation), - // that thousand separators appear only to the left of the decimal - (K < CharPos(Temp, ThouSep))); - end; - - if SwapSeparators then - begin - // assume a numerical string from a different locale, - // where DecimalSeparator and ThousandSeparator are exchanged - for I := 1 to Length(Temp) do - if Temp[I] = DecSep then - Temp[I] := ThouSep - else - if Temp[I] = ThouSep then - Temp[I] := DecSep; - end; - - Temp := StrKeepChars(Temp, CharIsNumber); - - if Length(Temp) > 0 then - begin - if Temp[1] = DecSep then - Temp := '0' + Temp; - if Temp[Length(Temp)] = DecSep then - Temp := Temp + '0'; - Result := StrToFloat(Temp); - if IsNegative then - Result := -Result; - end - else - Result := 0.0; -end; - -function StrToIntSafe(const S: string): Integer; -begin - Result := Trunc(StrToFloatSafe(S)); -end; - -procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; -begin - Index := Max(1, Min(Index, StrLen + 1)); - Count := Max(0, Min(Count, StrLen + 1 - Index)); -end; - -function ArrayOf(List: TStrings): TDynStringArray; -var - I: SizeInt; -begin - if List <> nil then - begin - SetLength(Result, List.Count); - for I := 0 to List.Count - 1 do - Result[I] := List[I]; - end - else - Result := nil; -end; - -const - BoolToStr: array [Boolean] of string = ('false', 'true'); - -type - TInterfacedObjectAccess = class(TInterfacedObject); - -procedure MoveChar(const Source; var Dest; Count: SizeInt); -begin - if Count > 0 then - Move(Source, Dest, Count * SizeOf(Char)); -end; - -function DotNetFormat(const Fmt: string; const Arg0: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0]); -end; - -function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0, Arg1]); -end; - -function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); -end; - -function DotNetFormat(const Fmt: string; const Args: array of const): string; -var - F, P: PChar; - Len, Capacity, Count: SizeInt; - Index: SizeInt; - ErrorCode: Integer; - S: string; - - procedure Grow(Count: SizeInt); - begin - if Len + Count > Capacity then - begin - Capacity := Capacity * 5 div 3 + Count; - SetLength(Result, Capacity); - end; - end; - - function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; - begin - Result := True; - while AClass <> nil do - begin - if CompareText(AClass.ClassName, ClassName) = 0 then - Exit; - AClass := AClass.ClassParent; - end; - Result := False; - end; - - function GetStringOf(const V: TVarData; Index: SizeInt): string; overload; - begin - case V.VType of - varEmpty, varNull: - raise ArgumentNullException.CreateRes(@RsArgumentIsNull); - varSmallInt: - Result := IntToStr(V.VSmallInt); - varInteger: - Result := IntToStr(V.VInteger); - varSingle: - Result := FloatToStr(V.VSingle); - varDouble: - Result := FloatToStr(V.VDouble); - varCurrency: - Result := CurrToStr(V.VCurrency); - varDate: - Result := DateTimeToStr(V.VDate); - varOleStr: - Result := V.VOleStr; - varBoolean: - Result := BoolToStr[V.VBoolean <> False]; - varByte: - Result := IntToStr(V.VByte); - varWord: - Result := IntToStr(V.VWord); - varShortInt: - Result := IntToStr(V.VShortInt); - varLongWord: - Result := IntToStr(V.VLongWord); - varInt64: - Result := IntToStr(V.VInt64); - varString: - Result := string(V.VString); - {$IFDEF SUPPORTS_UNICODE_STRING} - varUString: - Result := string(V.VUString); - {$ENDIF SUPPORTS_UNICODE_STRING} - {varArray, - varDispatch, - varError, - varUnknown, - varAny, - varByRef:} - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - end; - end; - - function GetStringOf(Index: SizeInt): string; overload; - var - V: TVarRec; - Intf: IToString; - begin - V := Args[Index]; - if (V.VInteger = 0) and - (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, - vtInterface, vtInt64]) then - raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); - - case V.VType of - vtInteger: - Result := IntToStr(V.VInteger); - vtBoolean: - Result := BoolToStr[V.VBoolean]; - vtChar: - Result := string(AnsiString(V.VChar)); - vtExtended: - Result := FloatToStr(V.VExtended^); - vtString: - Result := string(V.VString^); - vtPointer: - Result := IntToHex(TJclAddr(V.VPointer), 8); - vtPChar: - Result := string(AnsiString(V.VPChar)); - vtObject: - if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then - begin - Result := Intf.ToString; - Pointer(Intf) := nil; // do not release the object - // undo the RefCount change - Dec(TInterfacedObjectAccess(V.VObject).FRefCount); - end - else - if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then - Result := Intf.ToString - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - vtClass: - Result := V.VClass.ClassName; - vtWideChar: - Result := V.VWideChar; - vtPWideChar: - Result := V.VPWideChar; - vtAnsiString: - Result := string(V.VAnsiString); - vtCurrency: - Result := CurrToStr(V.VCurrency^); - vtVariant: - Result := GetStringOf(TVarData(V.VVariant^), Index); - vtInterface: - if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then - Result := IToString(Intf).ToString - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - vtWideString: - Result := WideString(V.VWideString); - vtInt64: - Result := IntToStr(V.VInt64^); - {$IFDEF SUPPORTS_UNICODE_STRING} - vtUnicodeString: - Result := UnicodeString(V.VUnicodeString); - {$ENDIF SUPPORTS_UNICODE_STRING} - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - end; - end; - -begin - if Length(Args) = 0 then - begin - Result := Fmt; - Exit; - end; - Len := 0; - Capacity := Length(Fmt); - SetLength(Result, Capacity); - if Capacity = 0 then - raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); - - P := Pointer(Fmt); - F := P; - while True do - begin - if (P[0] = #0) or (P[0] = '{') then - begin - Count := P - F; - Inc(P); - if (P[-1] <> #0) and (P[0] = '{') then - Inc(Count); // include '{' - - if Count > 0 then - begin - Grow(Count); - MoveChar(F[0], Result[Len + 1], Count); - Inc(Len, Count); - end; - - if P[-1] = #0 then - Break; - - if P[0] <> '{' then - begin - F := P; - Inc(P); - while (P[0] <> #0) and (P[0] <> '}') do - Inc(P); - SetString(S, F, P - F); - Val(S, Index, ErrorCode); - if ErrorCode <> 0 then - raise FormatException.CreateRes(@RsFormatException); - if (Index < 0) or (Index > High(Args)) then - raise FormatException.CreateRes(@RsFormatException); - S := GetStringOf(Index); - if S <> '' then - begin - Grow(Length(S)); - MoveChar(S[1], Result[Len + 1], Length(S)); - Inc(Len, Length(S)); - end; - - if P[0] = #0 then - Break; - end; - F := P + 1; - end - else - if (P[0] = '}') and (P[1] = '}') then - begin - Count := P - F + 1; - Inc(P); // skip next '}' - - Grow(Count); - MoveChar(F[0], Result[Len + 1], Count); - Inc(Len, Count); - F := P + 1; - end; - - Inc(P); - end; - - SetLength(Result, Len); -end; - -//=== { TJclStringBuilder } ===================================================== - -constructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt); -begin - inherited Create; - SetLength(FChars, Capacity); - FMaxCapacity := MaxCapacity; -end; - -constructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt); -begin - Create(Capacity); - Append(Value); -end; - -constructor TJclStringBuilder.Create(const Value: string; StartIndex, - Length, Capacity: SizeInt); -begin - Create(Capacity); - Append(Value, StartIndex + 1, Length); -end; - -function TJclStringBuilder.ToString: string; -begin - if FLength > 0 then - SetString(Result, PChar(@FChars[0]), FLength) - else - Result := ''; -end; - -function TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt; -begin - if System.Length(FChars) < Capacity then - SetCapacity(Capacity); - Result := System.Length(FChars); -end; - -procedure TJclStringBuilder.SetCapacity(const Value: SizeInt); -begin - if Value <> System.Length(FChars) then - begin - SetLength(FChars, Value); - if Value < FLength then - FLength := Value; - end; -end; - -function TJclStringBuilder.GetChars(Index: SizeInt): Char; -begin - Result := FChars[Index]; -end; - -procedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char); -begin - FChars[Index] := Value; -end; - -procedure TJclStringBuilder.Set_Length(const Value: SizeInt); -begin - FLength := Value; -end; - -function TJclStringBuilder.GetCapacity: SizeInt; -begin - Result := System.Length(FChars); -end; - -function TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder; -var - Capacity: SizeInt; -begin - if (Count > 0) and (RepeatCount > 0) then - begin - repeat - Capacity := System.Length(FChars); - if Capacity + Count > MaxCapacity then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Count then - SetLength(FChars, Capacity * 5 div 3 + Count); - if Count = 1 then - FChars[FLength] := Value[0] - else - MoveChar(Value[0], FChars[FLength], Count); - Inc(FLength, Count); - Dec(RepeatCount); - until RepeatCount <= 0; - end; - Result := Self; -end; - -function TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count, - RepeatCount: SizeInt): TJclStringBuilder; -var - Capacity: SizeInt; -begin - if (Index < 0) or (Index > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - - if Index = FLength then - AppendPChar(Value, Count, RepeatCount) - else - if (Count > 0) and (RepeatCount > 0) then - begin - repeat - Capacity := System.Length(FChars); - if Capacity + Count > MaxCapacity then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Count then - SetLength(FChars, Capacity * 5 div 3 + Count); - MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); - if Count = 1 then - FChars[Index] := Value[0] - else - MoveChar(Value[0], FChars[Index], Count); - Inc(FLength, Count); - - Dec(RepeatCount); - - Inc(Index, Count); // little optimization - until RepeatCount <= 0; - end; - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - AppendPChar(@Value[0], Len); - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - AppendPChar(PChar(@Value[0]) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; -begin - Result := AppendPChar(@Value, 1, RepeatCount); -end; - -function TJclStringBuilder.Append(const Value: string): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - AppendPChar(Pointer(Value), Len); - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder; -begin - Result := Append(BoolToStr[Value]); -end; - -function TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Integer): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Double): TJclStringBuilder; -begin - Result := Append(FloatToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Int64): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder; -begin - Result := Append(DotNetFormat('{0}', [Obj])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, Args)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - InsertPChar(Index, @Value[0], Len); - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - InsertPChar(Index, Pointer(Value), Len, Count); - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; -begin - Result := Insert(Index, BoolToStr[Value]); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char; - StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder; -begin - Result := Insert(Index, FloatToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; -begin - Result := Insert(Index, Format('{0}', [Obj])); -end; - -function TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder; -begin - if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Length > 0 then - begin - MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length)); - Dec(FLength, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, - Count: SizeInt): TJclStringBuilder; -var - I: SizeInt; -begin - if Count = -1 then - Count := FLength; - if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if (Count > 0) and (OldChar <> NewChar) then - begin - for I := StartIndex to StartIndex + Length - 1 do - if FChars[I] = OldChar then - FChars[I] := NewChar; - end; - Result := Self; -end; - -function TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder; -var - I: SizeInt; - Offset: SizeInt; - NewLen, OldLen, Capacity: SizeInt; -begin - if Count = -1 then - Count := FLength; - if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if OldValue = '' then - raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); - - if (Count > 0) and (OldValue <> NewValue) then - begin - OldLen := System.Length(OldValue); - NewLen := System.Length(NewValue); - Offset := NewLen - OldLen; - Capacity := System.Length(FChars); - for I := StartIndex to StartIndex + Length - 1 do - if FChars[I] = OldValue[1] then - begin - if OldLen > 1 then - if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then - Continue; - if Offset <> 0 then - begin - if FLength - OldLen + NewLen > MaxCurrency then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Offset then - begin - Capacity := Capacity * 5 div 3 + Offset; - SetLength(FChars, Capacity); - end; - if Offset < 0 then - MoveChar(FChars[I - Offset], FChars[I], FLength - I) - else - MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I); - Inc(FLength, Offset); - end; - if NewLen > 0 then - begin - if (OldLen = 1) and (NewLen = 1) then - FChars[I] := NewValue[1] - else - MoveChar(NewValue[1], FChars[I], NewLen); - end; - end; - end; - Result := Self; -end; - -function StrExpandTabs(S: string): string; -begin - // use an empty tab set, which will default to a tab width of 2 - Result := TJclTabSet(nil).Expand(s); -end; - -function StrExpandTabs(S: string; TabWidth: SizeInt): string; -var - TabSet: TJclTabSet; -begin - // create a tab set with no tab stops and the given tab width - TabSet := TJclTabSet.Create(TabWidth); - try - Result := TabSet.Expand(S); - finally - TabSet.Free; - end; -end; - -function StrExpandTabs(S: string; TabSet: TJclTabSet): string; -begin - // use the provided tab set to perform the expansion - Result := TabSet.Expand(S); -end; - -function StrOptimizeTabs(S: string): string; -begin - // use an empty tab set, which will default to a tab width of 2 - Result := TJclTabSet(nil).Optimize(s); -end; - -function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; -var - TabSet: TJclTabSet; -begin - // create a tab set with no tab stops and the given tab width - TabSet := TJclTabSet.Create(TabWidth); - try - Result := TabSet.Optimize(S); - finally - TabSet.Free; - end; -end; - -function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; -begin - // use the provided tab set to perform the optimization - Result := TabSet.Optimize(S); -end; - -// === { TTabSetData } =================================================== - -type - TTabSetData = class - public - FStops: TDynSizeIntArray; - FRealWidth: SizeInt; - FRefCount: SizeInt; - FWidth: SizeInt; - FZeroBased: Boolean; - constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); - - function Add(Column: SizeInt): SizeInt; - function AddRef: SizeInt; - procedure CalcRealWidth; - function FindStop(Column: SizeInt): SizeInt; - function ReleaseRef: SizeInt; - procedure RemoveAt(Index: SizeInt); - procedure SetStops(Index, Value: SizeInt); - end; - -constructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); -var - idx: SizeInt; -begin - inherited Create; - FRefCount := 1; - for idx := 0 to High(Tabstops) do - Add(Tabstops[idx]); - FWidth := TabWidth; - FZeroBased := ZeroBased; - CalcRealWidth; -end; - -function TTabSetData.Add(Column: SizeInt): SizeInt; -var - I: SizeInt; -begin - if Column < Ord(FZeroBased) then - raise ArgumentOutOfRangeException.Create('Column'); - Result := FindStop(Column); - if Result < 0 then - begin - // the column doesn't exist; invert the result of FindStop to get the correct index position - Result := not Result; - // increase the tab stop array - SetLength(FStops, Length(FStops) + 1); - // shift rooms after the insert position - for I := High(FStops) - 1 downto Result do - FStops[I + 1] := FStops[I]; - // add the tab stop at the correct location - FStops[Result] := Column; - CalcRealWidth; - end - else - begin - raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); - end; -end; - -function TTabSetData.AddRef: SizeInt; -begin - Result := LockedInc(FRefCount); -end; - -procedure TTabSetData.CalcRealWidth; -begin - if FWidth < 1 then - begin - if Length(FStops) > 1 then - FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))] - else - if Length(FStops) = 1 then - FRealWidth := FStops[0] - else - FRealWidth := 2; - end - else - FRealWidth := FWidth; -end; - -function TTabSetData.FindStop(Column: SizeInt): SizeInt; -begin - Result := High(FStops); - while (Result >= 0) and (FStops[Result] > Column) do - Dec(Result); - if (Result >= 0) and (FStops[Result] <> Column) then - Result := not Succ(Result); -end; - -function TTabSetData.ReleaseRef: SizeInt; -begin - Result := LockedDec(FRefCount); - if Result <= 0 then - Destroy; -end; - -procedure TTabSetData.RemoveAt(Index: SizeInt); -var - I: SizeInt; -begin - for I := Index to High(FStops) - 1 do - FStops[I] := FStops[I + 1]; - SetLength(FStops, High(FStops)); - CalcRealWidth; -end; - -procedure TTabSetData.SetStops(Index, Value: SizeInt); -var - temp: SizeInt; -begin - if (Index < 0) or (Index >= Length(FStops)) then - begin - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - end - else - begin - temp := FindStop(Value); - if temp < 0 then - begin - // remove existing tab stop... - RemoveAt(Index); - // now add the new tab stop - Add(Value); - end - else - if temp <> Index then - begin - // new tab stop already present at another index - raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); - end; - end; -end; - -//=== { TJclTabSet } ===================================================== - -constructor TJclTabSet.Create; -begin - // no tab stops, tab width set to auto - Create([], True, 0); -end; - -constructor TJclTabSet.Create(TabWidth: SizeInt); -begin - // no tab stops, specified tab width - Create([], True, TabWidth); -end; - -constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); -begin - // specified tab stops, tab width equal to distance between last two tab stops - Create(Tabstops, ZeroBased, 0); -end; - -constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); -begin - inherited Create; - FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth); -end; - -constructor TJclTabSet.Create(Data: TObject); -begin - inherited Create; - // add a reference to the data - TTabSetData(Data).AddRef; - // assign the data to this instance - FData := TTabSetData(Data); -end; - -destructor TJclTabSet.Destroy; -begin - // release the reference to the tab set data - TTabSetData(FData).ReleaseRef; - // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction - FData := nil; - // really destroy the instance - inherited Destroy; -end; - -function TJclTabSet.Add(Column: SizeInt): SizeInt; -begin - if Self = nil then - raise NullReferenceException.Create; - Result := TTabSetData(FData).Add(Column); -end; - -function TJclTabSet.Clone: TJclTabSet; -begin - if Self <> nil then - Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth) - else - Result := nil; -end; - -function TJclTabSet.Delete(Column: SizeInt): SizeInt; -begin - Result := TTabSetData(FData).FindStop(Column); - if Result >= 0 then - TTabSetData(FData).RemoveAt(Result); -end; - -function TJclTabSet.Expand(const S: string): string; -begin - Result := Expand(s, StartColumn); -end; - -function TJclTabSet.Expand(const S: string; Column: SizeInt): string; -var - sb: TJclStringBuilder; - head: PChar; - cur: PChar; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - sb := TJclStringBuilder.Create(Length(S)); - try - cur := PChar(S); - while cur^ <> #0 do - begin - head := cur; - while (cur^ <> #0) and (cur^ <> #9) do - begin - if CharIsReturn(cur^) then - Column := StartColumn - else - Inc(Column); - Inc(cur); - end; - if cur > head then - sb.Append(head, 0, cur - head); - if cur^ = #9 then - begin - sb.Append(' ', TabFrom(Column) - Column); - Column := TabFrom(Column); - Inc(cur); - end; - end; - Result := sb.ToString; - finally - sb.Free; - end; -end; - -function TJclTabSet.FindStop(Column: SizeInt): SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FindStop(Column) - else - Result := -1; -end; - -class function TJclTabSet.FromString(const S: string): TJclTabSet; -var - cur: PChar; - - function ParseNumber: Integer; - var - head: PChar; - begin - StrSkipChars(cur, CharIsWhiteSpace); - head := cur; - while CharIsDigit(cur^) do - Inc(cur); - Result := -1; - if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then - Result := -1; - end; - - procedure ParseStops; - var - openBracket, hadComma: Boolean; - num: SizeInt; - begin - StrSkipChars(cur, CharIsWhiteSpace); - openBracket := cur^ = '['; - hadComma := False; - if openBracket then - Inc(cur); - repeat - num := ParseNumber; - if (num < 0) and hadComma then - raise EJclStringError.CreateRes(@RsTabs_StopExpected) - else - if num >= 0 then - Result.Add(num); - StrSkipChars(cur, CharIsWhiteSpace); - hadComma := cur^ = ','; - if hadComma then - Inc(cur); - until (cur^ = #0) or (cur^ = '+') or (cur^ = ']'); - if hadComma then - raise EJclStringError.CreateRes(@RsTabs_StopExpected) - else - if openBracket and (cur^ <> ']') then - raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected); - end; - - procedure ParseTabWidth; - var - num: SizeInt; - begin - StrSkipChars(cur, CharIsWhiteSpace); - if cur^ = '+' then - begin - Inc(cur); - StrSkipChars(cur, CharIsWhiteSpace); - num := ParseNumber; - if (num < 0) then - raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected) - else - Result.TabWidth := num; - end; - end; - - procedure ParseZeroBasedFlag; - begin - StrSkipChars(cur, CharIsWhiteSpace); - if cur^ = '0' then - begin - Inc(cur); - if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then - begin - Result.ZeroBased := True; - StrSkipChars(cur, CharIsWhiteSpace); - end - else - Dec(cur); - end; - end; - -begin - Result := TJclTabSet.Create; - try - Result.ZeroBased := False; - cur := PChar(S); - ParseZeroBasedFlag; - ParseStops; - ParseTabWidth; - except - // clean up the partially complete instance (to avoid memory leaks)... - Result.Free; - // ... and re-raise the exception - raise; - end; -end; - -function TJclTabSet.GetCount: SizeInt; -begin - if Self <> nil then - Result := Length(TTabSetData(FData).FStops) - else - Result := 0; -end; - -function TJclTabSet.GetStops(Index: SizeInt): SizeInt; -begin - if Self <> nil then - begin - if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then - begin - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - end - else - Result := TTabSetData(FData).FStops[Index]; - end - else - begin - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - end; -end; - -function TJclTabSet.GetTabWidth: SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FWidth - else - Result := 0; -end; - -function TJclTabSet.GetZeroBased: Boolean; -begin - Result := (Self = nil) or TTabSetData(FData).FZeroBased; -end; - -procedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); -var - nextTab: SizeInt; -begin - if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state) - raise ArgumentOutOfRangeException.Create('StartColumn'); - if (TargetColumn < StartColumn) then // target lies before the starting column - raise ArgumentOutOfRangeException.Create('TargetColumn'); - TabsNeeded := 0; - repeat - nextTab := TabFrom(StartColumn); - if nextTab <= TargetColumn then - begin - Inc(TabsNeeded); - StartColumn := nextTab; - end; - until nextTab > TargetColumn; - SpacesNeeded := TargetColumn - StartColumn; -end; - -function TJclTabSet.Optimize(const S: string): string; -begin - Result := Optimize(S, StartColumn); -end; - -function TJclTabSet.Optimize(const S: string; Column: SizeInt): string; -var - sb: TJclStringBuilder; - head: PChar; - cur: PChar; - tgt: SizeInt; - - procedure AppendOptimalWhiteSpace(Target: SizeInt); - var - tabCount: SizeInt; - spaceCount: SizeInt; - begin - if cur > head then - begin - OptimalFillInfo(Column, Target, tabCount, spaceCount); - if tabCount > 0 then - sb.Append(#9, tabCount); - if spaceCount > 0 then - sb.Append(' ', spaceCount); - end; - end; - -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - sb := TJclStringBuilder.Create(Length(S)); - try - cur := PChar(s); - while cur^ <> #0 do - begin - // locate first whitespace character - head := cur; - while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do - Inc(cur); - // output non whitespace characters - if cur > head then - sb.Append(head, 0, cur - head); - // advance column - Inc(Column, cur - head); - // initialize target column indexer - tgt := Column; - // locate end of whitespace sequence - while CharIsWhiteSpace(cur^) do - begin - if CharIsReturn(cur^) then - begin - // append optimized whitespace sequence... - AppendOptimalWhiteSpace(tgt); - // ...set the column back to the start of the line... - Column := StartColumn; - // ...reset target column indexer... - tgt := Column; - // ...add the line break character... - sb.Append(cur^); - end - else - if cur^ = #9 then - tgt := TabFrom(tgt) // expand the tab - else - Inc(tgt); // a normal whitespace; taking up 1 column - Inc(cur); - end; - AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence... - Column := tgt; // ...and memorize the column for the next iteration - end; - Result := sb.ToString; // convert result to a string - finally - sb.Free; - end; -end; - -procedure TJclTabSet.RemoveAt(Index: SizeInt); -begin - if Self <> nil then - TTabSetData(FData).RemoveAt(Index) - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetStops(Index, Value: SizeInt); -begin - if Self <> nil then - TTabSetData(FData).SetStops(Index, Value) - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetTabWidth(Value: SizeInt); -begin - if Self <> nil then - begin - TTabSetData(FData).FWidth := Value; - TTabSetData(FData).CalcRealWidth; - end - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetZeroBased(Value: Boolean); -var - shift: SizeInt; - idx: SizeInt; -begin - if Self <> nil then - begin - if Value <> TTabSetData(FData).FZeroBased then - begin - TTabSetData(FData).FZeroBased := Value; - if Value then - shift := -1 - else - shift := 1; - for idx := 0 to High(TTabSetData(FData).FStops) do - TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift; - end; - end - else - raise NullReferenceException.Create; -end; - -function TJclTabSet.InternalTabStops: TDynSizeIntArray; -begin - if Self <> nil then - Result := TTabSetData(FData).FStops - else - Result := nil; -end; - -function TJclTabSet.InternalTabWidth: SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FRealWidth - else - Result := 2; -end; - -function TJclTabSet.NewReference: TJclTabSet; -begin - if Self <> nil then - Result := TJclTabSet.Create(FData) - else - Result := nil; -end; - -function TJclTabSet.StartColumn: SizeInt; -begin - if GetZeroBased then - Result := 0 - else - Result := 1; -end; - -function TJclTabSet.TabFrom(Column: SizeInt): SizeInt; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - Result := FindStop(Column); - if Result < 0 then - Result := not Result - else - Inc(Result); - if Result >= GetCount then - begin - if GetCount > 0 then - Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)] - else - Result := StartColumn; - while Result <= Column do - Inc(Result, ActualTabWidth); - end - else - Result := TTabSetData(FData).FStops[Result]; -end; - -function TJclTabSet.ToString: string; -begin - Result := ToString(TabSetFormatting_Full); -end; - -function TJclTabSet.ToString(FormattingOptions: SizeInt): string; -var - sb: TJclStringBuilder; - idx: SizeInt; - - function WantBrackets: Boolean; - begin - Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0; - end; - - function EmptyBrackets: Boolean; - begin - Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0; - end; - - function IncludeAutoWidth: Boolean; - begin - Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0; - end; - - function IncludeTabWidth: Boolean; - begin - Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0; - end; - - function IncludeStops: Boolean; - begin - Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0; - end; - -begin - sb := TJclStringBuilder.Create; - try - // output the fixed tabulation positions if requested... - if IncludeStops then - begin - // output each individual tabulation position - for idx := 0 to GetCount - 1 do - begin - sb.Append(TabStops[idx]); - sb.Append(','); - end; - // remove the final comma if any tabulation positions where outputted - if sb.Length <> 0 then - sb.Remove(sb.Length - 1, 1); - // bracket the tabulation positions if requested - if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then - begin - sb.Insert(0, '['); - sb.Append(']'); - end; - end; - // output the tab width if requested.... - if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then - begin - // separate the tab width from any outputted tabulation positions with a whitespace - if sb.Length > 0 then - sb.Append(' '); - // flag tab width - sb.Append('+'); - // finally, output the tab width - sb.Append(ActualTabWidth); - end; - // flag zero-based tabset by outputting a 0 (zero) as the first character. - if ZeroBased then - sb.Insert(0, string('0 ')); - Result := StrTrimCharRight(sb.ToString, ' '); - finally - sb.Free; - end; -end; - -function TJclTabSet.UpdatePosition(const S: string): SizeInt; -var - Line: SizeInt; -begin - Result := StartColumn; - Line := -1; - UpdatePosition(S, Result, Line); -end; - -function TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt; -var - Line: SizeInt; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - Result := Column; - Line := -1; - UpdatePosition(S, Result, Line); -end; - -function TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; -var - prevChar: Char; - cur: PChar; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - // initialize loop - cur := PChar(S); - // iterate until end of string (the Null-character) - while cur^ <> #0 do - begin - // check for line-breaking characters - if CharIsReturn(cur^) then - begin - // Column moves back all the way to the left - Column := StartColumn; - // If this is the first line-break character or the same line-break character, increment the Line parameter - Inc(Line); - // check if it's the first of a two-character line-break - prevChar := cur^; - Inc(cur); - // if it isn't a two-character line-break, undo the previous advancement - if (cur^ = prevChar) or not CharIsReturn(cur^) then - Dec(cur); - end - else // check for tab character and expand it - if cur^ = #9 then - Column := TabFrom(Column) - else // a normal character; increment column - Inc(Column); - // advance pointer - Inc(cur); - end; - // set the result to the newly calculated column - Result := Column; -end; - -//=== { NullReferenceException } ============================================= - -constructor NullReferenceException.Create; -begin - CreateRes(@RsArg_NullReferenceException); -end; - -function CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt; -var - Cur1, Len1, - Cur2, Len2: SizeInt; - - function IsRealNumberChar(ch: Char): Boolean; - begin - Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+'); - end; - - procedure NumberCompare; - var - IsReallyNumber: Boolean; - FirstDiffBreaks: Boolean; - Val1, Val2: SizeInt; - begin - Result := 0; - IsReallyNumber := False; - // count leading spaces in S1 - while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do - begin - Dec(Result); - Inc(Cur1); - end; - // count leading spaces in S2 (canceling them out against the ones in S1) - while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do - begin - Inc(Result); - Inc(Cur2); - end; - - // if spaces match, or both strings are actually followed by a numeric character, continue the checks - if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then - begin - // Check signed number - if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then - Result := 1 - else - if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then - Result := -1 - else - Result := 0; - - if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then - Inc(Cur1); - if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then - Inc(Cur2); - - FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0'); - while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do - begin - IsReallyNumber := True; - Val1 := StrToInt(S1[Cur1]); - Val2 := StrToInt(S2[Cur2]); - - if (Result = 0) and (Val1 < Val2) then - Result := -1 - else - if (Result = 0) and (Val1 > Val2) then - Result := 1; - if FirstDiffBreaks and (Result <> 0) then - Break; - Inc(Cur1); - Inc(Cur2); - end; - - if IsReallyNumber then - begin - if not FirstDiffBreaks then - begin - if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then - Result := 1 - else - if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then - Result := -1; - end; - end; - end; - end; - - procedure SetByCompareLength; - var - Remain1: SizeInt; - Remain2: SizeInt; - begin - // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be - // completely equal, or S2 could be longer) - Remain1 := Len1 - Cur1 + 1; - Remain2 := Len2 - Cur2 + 1; - if Remain1 < 0 then - Remain1 := 0; - if Remain2 < 0 then - Remain2 := 0; - - if Remain1 < Remain2 then - Result := -1 - else - if Remain1 > Remain2 then - Result := 1; - end; - -begin - Cur1 := 1; - Len1 := Length(S1); - Cur2 := 1; - Len2 := Length(S2); - Result := 0; - - while (Result = 0) do - begin - if (Cur1 > Len1) or (Cur2 > Len2) then - begin - SetByCompareLength; - Break; - end - else - if (Cur1 <= Len1) and (Cur2 > Len2) then - Result := 1 - else - if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then - Result := -1 - else - if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then - Result := 1 - else - if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then - NumberCompare - else - begin - if CaseInsensitive then - Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1) - else - Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1); - Inc(Cur1); - Inc(Cur2); - end; - end; -end; - -function CompareNaturalStr(const S1, S2: string): SizeInt; overload; -begin - Result := CompareNatural(S1, S2, False); -end; - -function CompareNaturalText(const S1, S2: string): SizeInt; overload; -begin - Result := CompareNatural(S1, S2, True); -end; - -initialization - {$IFNDEF UNICODE_RTL_DATABASE} - LoadCharTypes; // this table first - LoadCaseMap; // or this function does not work - {$ENDIF ~UNICODE_RTL_DATABASE} - {$IFDEF UNITVERSIONING} - RegisterUnitVersion(HInstance, UnitVersioning); - {$ENDIF UNITVERSIONING} - -{$IFDEF UNITVERSIONING} -finalization - UnregisterUnitVersion(HInstance); -{$ENDIF UNITVERSIONING} - -end. - +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 JclStrings.pas. } +{ } +{ The Initial Developer of the Original Code is Marcel van Brakel. } +{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. } +{ } +{ Contributor(s): } +{ Alexander Radchenko } +{ Andreas Hausladen (ahuser) } +{ Anthony Steele } +{ Azret Botash } +{ Barry Kelly } +{ Huanlin Tsai } +{ Jack N.A. Bakker } +{ Jean-Fabien Connault (cycocrew) } +{ John C Molyneux } +{ Kiriakos Vlahos } +{ Leonard Wennekers } +{ Marcel Bestebroer } +{ Martin Kimmings } +{ Martin Kubecka } +{ Massimo Maria Ghisalberti } +{ Matthias Thoma (mthoma) } +{ Michael Winter } +{ Nick Hodges } +{ Olivier Sannier (obones) } +{ Pelle F. S. Liljendal } +{ Petr Vones (pvones) } +{ Rik Barker (rikbarker) } +{ Robert Lee } +{ Robert Marquardt (marquardt) } +{ Robert Rossmair (rrossmair) } +{ Andreas Schmidt } +{ Sean Farrow (sfarrow) } +{ } +{**************************************************************************************************} +{ } +{ Various character and string routines (searching, testing and transforming) } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit JclStrings; + +{$I jcl.inc} + +interface + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Winapi.Windows, + {$ENDIF MSWINDOWS} + {$IFDEF UNICODE_RTL_DATABASE} + System.Character, + {$ENDIF UNICODE_RTL_DATABASE} + System.Classes, System.SysUtils, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF MSWINDOWS} + {$IFDEF UNICODE_RTL_DATABASE} + Character, + {$ENDIF UNICODE_RTL_DATABASE} + Classes, SysUtils, + {$ENDIF ~HAS_UNITSCOPE} + JclAnsiStrings, + JclWideStrings, + JclBase; + +// Exceptions +type + EJclStringError = class(EJclError); + +// Character constants and sets + +const + // Misc. often used character definitions + NativeNull = Char(#0); + NativeSoh = Char(#1); + NativeStx = Char(#2); + NativeEtx = Char(#3); + NativeEot = Char(#4); + NativeEnq = Char(#5); + NativeAck = Char(#6); + NativeBell = Char(#7); + NativeBackspace = Char(#8); + NativeTab = Char(#9); + NativeLineFeed = JclBase.NativeLineFeed; + NativeVerticalTab = Char(#11); + NativeFormFeed = Char(#12); + NativeCarriageReturn = JclBase.NativeCarriageReturn; + NativeCrLf = JclBase.NativeCrLf; + NativeSo = Char(#14); + NativeSi = Char(#15); + NativeDle = Char(#16); + NativeDc1 = Char(#17); + NativeDc2 = Char(#18); + NativeDc3 = Char(#19); + NativeDc4 = Char(#20); + NativeNak = Char(#21); + NativeSyn = Char(#22); + NativeEtb = Char(#23); + NativeCan = Char(#24); + NativeEm = Char(#25); + NativeEndOfFile = Char(#26); + NativeEscape = Char(#27); + NativeFs = Char(#28); + NativeGs = Char(#29); + NativeRs = Char(#30); + NativeUs = Char(#31); + NativeSpace = Char(' '); + NativeComma = Char(','); + NativeBackslash = Char('\'); + NativeForwardSlash = Char('/'); + + NativeDoubleQuote = Char('"'); + NativeSingleQuote = Char(''''); + + NativeLineBreak = JclBase.NativeLineBreak; + +const + // CharType return values + C1_UPPER = $0001; // Uppercase + C1_LOWER = $0002; // Lowercase + C1_DIGIT = $0004; // Decimal digits + C1_SPACE = $0008; // Space characters + C1_PUNCT = $0010; // Punctuation + C1_CNTRL = $0020; // Control characters + C1_BLANK = $0040; // Blank characters + C1_XDIGIT = $0080; // Hexadecimal digits + C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic + + {$IFDEF MSWINDOWS} + {$IFDEF SUPPORTS_EXTSYM} + {$EXTERNALSYM C1_UPPER} + {$EXTERNALSYM C1_LOWER} + {$EXTERNALSYM C1_DIGIT} + {$EXTERNALSYM C1_SPACE} + {$EXTERNALSYM C1_PUNCT} + {$EXTERNALSYM C1_CNTRL} + {$EXTERNALSYM C1_BLANK} + {$EXTERNALSYM C1_XDIGIT} + {$EXTERNALSYM C1_ALPHA} + {$ENDIF SUPPORTS_EXTSYM} + {$ENDIF MSWINDOWS} + +type + TCharValidator = function(const C: Char): Boolean; + +function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload; +function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; + +// String Test Routines +function StrIsAlpha(const S: string): Boolean; +function StrIsAlphaNum(const S: string): Boolean; +function StrIsAlphaNumUnderscore(const S: string): Boolean; +function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; +function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; +function StrConsistsOfNumberChars(const S: string): Boolean; +function StrIsDigit(const S: string): Boolean; +function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; +function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; +function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; + +// String Transformation Routines +function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; +function StrCharPosLower(const S: string; CharPos: SizeInt): string; +function StrCharPosUpper(const S: string; CharPos: SizeInt): string; +function StrDoubleQuote(const S: string): string; +function StrEnsureNoPrefix(const Prefix, Text: string): string; +function StrEnsureNoSuffix(const Suffix, Text: string): string; +function StrEnsurePrefix(const Prefix, Text: string): string; +function StrEnsureSuffix(const Suffix, Text: string): string; +function StrEscapedToString(const S: string): string; +function StrLower(const S: string): string; +procedure StrLowerInPlace(var S: string); +procedure StrLowerBuff(S: PChar); +procedure StrMove(var Dest: string; const Source: string; const ToIndex, + FromIndex, Count: SizeInt); +function StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string; +function StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string; +function StrProper(const S: string): string; +procedure StrProperBuff(S: PChar); +function StrQuote(const S: string; C: Char): string; +function StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveChars(const S: string; const Chars: array of Char): string; overload; +function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload; +function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload; +function StrKeepChars(const S: string; const Chars: TCharValidator): string; overload; +function StrKeepChars(const S: string; const Chars: array of Char): string; overload; +procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []); +function StrReplaceChar(const S: string; const Source, Replace: Char): string; +function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; +function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; +function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; +function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; +function StrRepeat(const S: string; Count: SizeInt): string; +function StrRepeatLength(const S: string; L: SizeInt): string; +function StrReverse(const S: string): string; +procedure StrReverseInPlace(var S: string); +function StrSingleQuote(const S: string): string; +procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; +procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; +function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; +function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; +function StrStringToEscaped(const S: string): string; +function StrStripNonNumberChars(const S: string): string; +function StrToHex(const Source: string): string; +function StrTrimCharLeft(const S: string; C: Char): string; +function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload; +function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; +function StrTrimCharRight(const S: string; C: Char): string; +function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload; +function StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload; +function StrTrimQuotes(const S: string): string; +function StrUpper(const S: string): string; +procedure StrUpperInPlace(var S: string); +procedure StrUpperBuff(S: PChar); + +// String Management +procedure StrAddRef(var S: string); +procedure StrDecRef(var S: string); +function StrLength(const S: string): SizeInt; +function StrRefCount(const S: string): SizeInt; + +// String Search and Replace Routines +function StrCharCount(const S: string; C: Char): SizeInt; overload; +function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload; +function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload; +function StrStrCount(const S, SubS: string): SizeInt; +function StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt; +function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt; +function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +procedure StrFillChar(var S; Count: SizeInt; C: Char); +function StrRepeatChar(C: Char; Count: SizeInt): string; +function StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt; +function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; +function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; +function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt; +function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; +function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; +function StrILastPos(const SubStr, S: string): SizeInt; +function StrIPos(const SubStr, S: string): SizeInt; +function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +function StrIsOneOf(const S: string; const List: array of string): Boolean; +function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +function StrLastPos(const SubStr, S: string): SizeInt; +function StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt; +function StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean; +function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; +function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; +function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +function StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt; +function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; + +// String Extraction +// Returns the String before SubStr +function StrAfter(const SubStr, S: string): string; +/// Returns the string after SubStr +function StrBefore(const SubStr, S: string): string; +/// Splits a string at SubStr, returns true when SubStr is found, Left contains the +/// string before the SubStr and Rigth the string behind SubStr +function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; +/// Returns the string between Start and Stop +function StrBetween(const S: string; const Start, Stop: Char): string; +/// Returns the left N characters of the string +function StrChopRight(const S: string; N: SizeInt): string; +/// Returns the left Count characters of the string +function StrLeft(const S: string; Count: SizeInt): string; +/// Returns the string starting from position Start for the Count Characters +function StrMid(const S: string; Start, Count: SizeInt): string; +/// Returns the string starting from position N to the end +function StrRestOf(const S: string; N: SizeInt): string; +/// Returns the right Count characters of the string +function StrRight(const S: string; Count: SizeInt): string; + +// Character Test Routines +function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} +function CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} +function CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharType(const C: Char): Word; + +// Character Transformation Routines +function CharHex(const C: Char): Byte; +function CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharToggleCase(const C: Char): Char; + +// Character Search and Replace +function CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; +function CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; +function CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt; +function CharReplace(var S: string; const Search, Replace: Char): SizeInt; + +// PCharVector +type + PCharVector = ^PChar; + +function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; +function PCharVectorCount(Source: PCharVector): SizeInt; +procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); +procedure FreePCharVector(var Dest: PCharVector); + +// MultiSz Routines +type + PMultiSz = PChar; + PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz; + PWideMultiSz = JclWideStrings.PWideMultiSz; + + TAnsiStrings = JclAnsiStrings.TJclAnsiStrings; + TWideStrings = JclWideStrings.TJclWideStrings; + TAnsiStringList = JclAnsiStrings.TJclAnsiStringList; + TWideStringList = JclWideStrings.TJclWideStringList; + +function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; +procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); +function MultiSzLength(const Source: PMultiSz): SizeInt; +procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); +procedure FreeMultiSz(var Dest: PMultiSz); +function MultiSzDup(const Source: PMultiSz): PMultiSz; + +function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; + {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} + +function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; + {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} + +// TStrings Manipulation +procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; overload; +function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: + Boolean = True): string; overload; +procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True); +procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True); +procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True); +function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; + +// Miscellaneous +// (OF) moved to JclSysUtils +// function BooleanToStr(B: Boolean): string; + // AnsiString here because it is binary data +function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; +procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; + Append: Boolean = False); + +function StrToken(var S: string; Separator: Char): string; +procedure StrTokens(const S: string; const List: TStrings); +procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); +function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload; +function StrWord(var S: PChar; out Word: string): Boolean; overload; +function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload; +function StrIdent(var S: PChar; out Ident: string): Boolean; overload; +function StrToFloatSafe(const S: string): Float; +function StrToIntSafe(const S: string): Integer; +procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; + +function ArrayOf(List: TStrings): TDynStringArray; overload; + +type + FormatException = class(EJclError); + ArgumentException = class(EJclError); + ArgumentNullException = class(EJclError); + ArgumentOutOfRangeException = class(EJclError); + + IToString = interface + ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] + function ToString: string; + end; + + TCharDynArray = array of Char; + + // The TStringBuilder class is a Delphi implementation of the .NET + // System.Text.StringBuilder. + // It is zero based and the method that allow an TObject (Append, Insert, + // AppendFormat) are limited to IToString implementors. + // This class is not threadsafe. Any instance of TStringBuilder should not + // be used in different threads at the same time. + TJclStringBuilder = class(TInterfacedObject, IToString) + private + FChars: TCharDynArray; + FLength: SizeInt; + FMaxCapacity: SizeInt; + + function GetCapacity: SizeInt; + procedure SetCapacity(const Value: SizeInt); + function GetChars(Index: SizeInt): Char; + procedure SetChars(Index: SizeInt; const Value: Char); + procedure Set_Length(const Value: SizeInt); + protected + function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; + function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; + public + constructor Create(const Value: string; Capacity: SizeInt = 16); overload; + constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload; + constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload; + + function Append(const Value: string): TJclStringBuilder; overload; + function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload; + function Append(Value: Boolean): TJclStringBuilder; overload; + function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload; + function Append(const Value: array of Char): TJclStringBuilder; overload; + function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; + function Append(Value: Cardinal): TJclStringBuilder; overload; + function Append(Value: Integer): TJclStringBuilder; overload; + function Append(Value: Double): TJclStringBuilder; overload; + function Append(Value: Int64): TJclStringBuilder; overload; + function Append(Obj: TObject): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload; + + function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload; + function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload; + function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; + overload; + function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload; + + function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; + overload; + function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; + overload; + + function Remove(StartIndex, Length: SizeInt): TJclStringBuilder; + function EnsureCapacity(Capacity: SizeInt): SizeInt; + + { IToString } + function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} + + property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default; + property Chars: TCharDynArray read FChars; + property Length: SizeInt read FLength write Set_Length; + property Capacity: SizeInt read GetCapacity write SetCapacity; + property MaxCapacity: SizeInt read FMaxCapacity; + end; + + {$IFDEF RTL200_UP} + TStringBuilder = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.TStringBuilder; + {$ELSE ~RTL200_UP} + TStringBuilder = TJclStringBuilder; + {$ENDIF ~RTL200_UP} + +// DotNetFormat() uses the .NET format style: "{argX}" +function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; + +// TJclTabSet +type + TJclTabSet = class (TInterfacedObject, IToString) + private + FData: TObject; + function GetCount: SizeInt; + function GetStops(Index: SizeInt): SizeInt; + function GetTabWidth: SizeInt; + function GetZeroBased: Boolean; + procedure SetStops(Index, Value: SizeInt); + procedure SetTabWidth(Value: SizeInt); + procedure SetZeroBased(Value: Boolean); + protected + function FindStop(Column: SizeInt): SizeInt; + function InternalTabStops: TDynSizeIntArray; + function InternalTabWidth: SizeInt; + procedure RemoveAt(Index: SizeInt); + public + constructor Create; overload; + constructor Create(Data: TObject); overload; + constructor Create(TabWidth: SizeInt); overload; + constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload; + constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload; + destructor Destroy; override; + + // cloning and referencing + function Clone: TJclTabSet; + function NewReference: TJclTabSet; + + // Tab stops manipulation + function Add(Column: SizeInt): SizeInt; + function Delete(Column: SizeInt): SizeInt; + + // Usage + function Expand(const S: string): string; overload; + function Expand(const S: string; Column: SizeInt): string; overload; + procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); + function Optimize(const S: string): string; overload; + function Optimize(const S: string; Column: SizeInt): string; overload; + function StartColumn: SizeInt; + function TabFrom(Column: SizeInt): SizeInt; + function UpdatePosition(const S: string): SizeInt; overload; + function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload; + function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload; + + { IToString } + function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} + // Conversions + function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload; + class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC} + + // Properties + property ActualTabWidth: SizeInt read InternalTabWidth; + property Count: SizeInt read GetCount; + property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default; + property TabWidth: SizeInt read GetTabWidth write SetTabWidth; + property ZeroBased: Boolean read GetZeroBased write SetZeroBased; + end; + +// Formatting constants +const + TabSetFormatting_SurroundStopsWithBrackets = 1; + TabSetFormatting_EmptyBracketsIfNoStops = 2; + TabSetFormatting_NoTabStops = 4; + TabSetFormatting_NoTabWidth = 8; + TabSetFormatting_AutoTabWidth = 16; + // common combinations + TabSetFormatting_Default = 0; + TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or + TabSetFormatting_EmptyBracketsIfNoStops; + TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth; + // aliases + TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth; + TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops; + TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default; + +// Tab expansion routines +function StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +// Tab optimization routines +function StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; + +// move to JclBase? +type + NullReferenceException = class(EJclError) + public + constructor Create; overload; + end; + +procedure StrResetLength(var S: WideString); overload; +procedure StrResetLength(var S: AnsiString); overload; +procedure StrResetLength(S: TJclStringBuilder); overload; +{$IFDEF SUPPORTS_UNICODE_STRING} +procedure StrResetLength(var S: UnicodeString); overload; +{$ENDIF SUPPORTS_UNICODE_STRING} + +// natural comparison functions +function CompareNaturalStr(const S1, S2: string): SizeInt; +function CompareNaturalText(const S1, S2: string): SizeInt; + +{$IFNDEF UNICODE_RTL_DATABASE} +// internal structures published to make function inlining working +const + MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set + StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars + StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars + StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars + StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table + +var + StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings + StrCaseMapReady: Boolean = False; // true if case map exists + StrCharTypes: array [Char] of Word; +{$ENDIF ~UNICODE_RTL_DATABASE} + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNIT_LIBC} + Libc, + {$ENDIF HAS_UNIT_LIBC} + {$IFDEF SUPPORTS_UNICODE} + {$IFDEF HAS_UNITSCOPE} + System.StrUtils, + {$ELSE ~HAS_UNITSCOPE} + StrUtils, + {$ENDIF ~HAS_UNITSCOPE} + {$ENDIF SUPPORTS_UNICODE} + JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils; + +//=== Internal =============================================================== + +type + TStrRec = packed record + RefCount: Longint; + Length: Longint; + end; + PStrRec = ^TStrRec; + +{$IFNDEF UNICODE_RTL_DATABASE} +procedure LoadCharTypes; +var + CurrChar: Char; + CurrType: Word; +begin + for CurrChar := Low(CurrChar) to High(CurrChar) do + begin + {$IFDEF MSWINDOWS} + CurrType := 0; + GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, CurrType); + {$DEFINE CHAR_TYPES_INITIALIZED} + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + CurrType := 0; + if isupper(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_UPPER; + if islower(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_LOWER; + if isdigit(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_DIGIT; + if isspace(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_SPACE; + if ispunct(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_PUNCT; + if iscntrl(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_CNTRL; + if isblank(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_BLANK; + if isxdigit(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_XDIGIT; + if isalpha(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_ALPHA; + {$DEFINE CHAR_TYPES_INITIALIZED} + {$ENDIF LINUX} + StrCharTypes[CurrChar] := CurrType; + {$IFNDEF CHAR_TYPES_INITIALIZED} + Implement case map initialization here + {$ENDIF ~CHAR_TYPES_INITIALIZED} + end; +end; + +procedure LoadCaseMap; +var + CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char; +begin + if not StrCaseMapReady then + begin + for CurrChar := Low(Char) to High(Char) do + begin + {$IFDEF MSWINDOWS} + LoCaseChar := CurrChar; + UpCaseChar := CurrChar; + {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuff(@LoCaseChar, 1); + {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuff(@UpCaseChar, 1); + {$DEFINE CASE_MAP_INITIALIZED} + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + LoCaseChar := Char(tolower(Byte(CurrChar))); + UpCaseChar := Char(toupper(Byte(CurrChar))); + {$DEFINE CASE_MAP_INITIALIZED} + {$ENDIF LINUX} + {$IFNDEF CASE_MAP_INITIALIZED} + Implement case map initialization here + {$ENDIF ~CASE_MAP_INITIALIZED} + if CharIsUpper(CurrChar) then + ReCaseChar := LoCaseChar + else + if CharIsLower(CurrChar) then + ReCaseChar := UpCaseChar + else + ReCaseChar := CurrChar; + StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar; + StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar; + StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar; + end; + StrCaseMapReady := True; + end; +end; + +// Uppercases or Lowercases a give string depending on the +// passed offset. (UpOffset or LoOffset) + +procedure StrCase(var Str: string; const Offset: SizeInt); +var + P: PChar; + I, L: SizeInt; +begin + L := Length(Str); + if L > 0 then + begin + UniqueString(Str); + P := PChar(Str); + for I := 1 to L do + begin + P^ := StrCaseMap[Offset + Ord(P^)]; + Inc(P); + end; + end; +end; + +// Internal utility function +// Uppercases or Lowercases a give null terminated string depending on the +// passed offset. (UpOffset or LoOffset) + +procedure StrCaseBuff(S: PChar; const Offset: SizeInt); +var + C: Char; +begin + if S <> nil then + begin + repeat + C := S^; + S^ := StrCaseMap[Offset + Ord(C)]; + Inc(S); + until C = #0; + end; +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +function StrEndW(Str: PWideChar): PWideChar; +begin + Result := Str; + while Result^ <> #0 do + Inc(Result); +end; + +function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; +var + idx: SizeInt; +begin + Result := ArrayContainsChar(Chars, C, idx); +end; + +function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; +{ optimized version for sorted arrays +var + I, L, H: SizeInt; +begin + L := Low(Chars); + H := High(Chars); + while L <= H do + begin + I := (L + H) div 2; + if C = Chars[I] then + begin + Result := True; + Exit; + end + else + if C < Chars[I] then + H := I - 1 + else + // C > Chars[I] + L := I + 1; + end; + Result := False; +end;} +begin + Index := High(Chars); + while (Index >= Low(Chars)) and (Chars[Index] <> C) do + Dec(Index); + Result := Index >= Low(Chars); +end; + +// String Test Routines +function StrIsAlpha(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsAlpha(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrIsAlphaNum(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsAlphaNum(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrConsistsofNumberChars(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsNumberChar(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; +var + I: SizeInt; +begin + Result := False; + if CheckAll then + begin + // this will not work with the current definition of the validator. The validator would need to check each character + // it requires against the string (which is currently not provided to the Validator). The current implementation of + // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon- + // sistent with the documentation and the array-based overload. + for I := 1 to Length(S) do + begin + Result := Chars(S[I]); + if not Result then + Break; + end; + end + else + begin + for I := 1 to Length(S) do + begin + Result := Chars(S[I]); + if Result then + Break; + end; + end; +end; + +function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; +var + I: SizeInt; +begin + if CheckAll then + begin + Result := True; + I := High(Chars); + while (I >= 0) and Result do + begin + Result := CharPos(S, Chars[I]) > 0; + Dec(I); + end; + end + else + begin + Result := False; + for I := 1 to Length(S) do + begin + Result := ArrayContainsChar(Chars, S[I]); + if Result then + Break; + end; + end; +end; + +function StrIsAlphaNumUnderscore(const S: string): Boolean; +var + I: SizeInt; + C: Char; +begin + for I := 1 to Length(S) do + begin + C := S[I]; + + if not (CharIsAlphaNum(C) or (C = '_')) then + begin + Result := False; + Exit; + end; + end; + + Result := Length(S) > 0; +end; + +function StrIsDigit(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsDigit(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + begin + Result := ValidChars(S[I]); + if not Result then + Exit; + end; + + Result := Length(S) > 0; +end; + +function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + begin + Result := ArrayContainsChar(ValidChars, S[I]); + if not Result then + Exit; + end; + + Result := Length(S) > 0; +end; + +function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; +begin + Result := StrCompare(S1, S2, CaseSensitive) = 0; +end; + +//=== String Transformation Routines ========================================= + +function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; +begin + if Length(S) < L then + begin + Result := StringOfChar(C, (L - Length(S)) div 2) + S; + Result := Result + StringOfChar(C, L - Length(Result)); + end + else + Result := S; +end; + +function StrCharPosLower(const S: string; CharPos: SizeInt): string; +begin + Result := S; + if (CharPos > 0) and (CharPos <= Length(S)) then + Result[CharPos] := CharLower(Result[CharPos]); +end; + +function StrCharPosUpper(const S: string; CharPos: SizeInt): string; +begin + Result := S; + if (CharPos > 0) and (CharPos <= Length(S)) then + Result[CharPos] := CharUpper(Result[CharPos]); +end; + +function StrDoubleQuote(const S: string): string; +begin + Result := NativeDoubleQuote + S + NativeDoubleQuote; +end; + +function StrEnsureNoPrefix(const Prefix, Text: string): string; +var + PrefixLen: SizeInt; +begin + PrefixLen := Length(Prefix); + if Copy(Text, 1, PrefixLen) = Prefix then + Result := Copy(Text, PrefixLen + 1, Length(Text)) + else + Result := Text; +end; + +function StrEnsureNoSuffix(const Suffix, Text: string): string; +var + SuffixLen: SizeInt; + StrLength: SizeInt; +begin + SuffixLen := Length(Suffix); + StrLength := Length(Text); + if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then + Result := Copy(Text, 1, StrLength - SuffixLen) + else + Result := Text; +end; + +function StrEnsurePrefix(const Prefix, Text: string): string; +var + PrefixLen: SizeInt; +begin + PrefixLen := Length(Prefix); + if Copy(Text, 1, PrefixLen) = Prefix then + Result := Text + else + Result := Prefix + Text; +end; + +function StrEnsureSuffix(const Suffix, Text: string): string; +var + SuffixLen: SizeInt; +begin + SuffixLen := Length(Suffix); + if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then + Result := Text + else + Result := Text + Suffix; +end; + +function StrEscapedToString(const S: string): string; + procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); + const + HexDigits = string('0123456789abcdefABCDEF'); + var + StartI, Val, N: SizeInt; + begin + StartI := I; + N := Pos(S[I + 1], HexDigits) - 1; + if N < 0 then + // '\x' without hex digit following is not escape sequence + Dest := Dest + '\x' + else + begin + Inc(I); // Jump over x + if N >= 16 then + N := N - 6; + Val := N; + // Same for second digit + if I < Len then + begin + N := Pos(S[I + 1], HexDigits) - 1; + if N >= 0 then + begin + Inc(I); // Jump over first digit + if N >= 16 then + N := N - 6; + Val := Val * 16 + N; + end; + end; + + if Val > Ord(High(Char)) then + raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); + + Dest := Dest + Char(Val); + end; + end; + + procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); + const + OctDigits = string('01234567'); + var + StartI, Val, N: SizeInt; + begin + StartI := I; + // first digit + Val := Pos(S[I], OctDigits) - 1; + if I < Len then + begin + N := Pos(S[I + 1], OctDigits) - 1; + if N >= 0 then + begin + Inc(I); + Val := Val * 8 + N; + end; + if I < Len then + begin + N := Pos(S[I + 1], OctDigits) - 1; + if N >= 0 then + begin + Inc(I); + Val := Val * 8 + N; + end; + end; + end; + + if Val > Ord(High(Char)) then + raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); + + Dest := Dest + Char(Val); + end; + +var + I, Len: SizeInt; +begin + Result := ''; + I := 1; + Len := Length(S); + while I <= Len do + begin + if not ((S[I] = '\') and (I < Len)) then + Result := Result + S[I] + else + begin + Inc(I); // Jump over escape character + case S[I] of + 'a': + Result := Result + NativeBell; + 'b': + Result := Result + NativeBackspace; + 'f': + Result := Result + NativeFormFeed; + 'n': + Result := Result + NativeLineFeed; + 'r': + Result := Result + NativeCarriageReturn; + 't': + Result := Result + NativeTab; + 'v': + Result := Result + NativeVerticalTab; + '\': + Result := Result + '\'; + '"': + Result := Result + '"'; + '''': + Result := Result + ''''; // Optionally escaped + '?': + Result := Result + '?'; // Optionally escaped + 'x': + if I < Len then + // Start of hex escape sequence + HandleHexEscapeSeq(S, I, Len, Result) + else + // '\x' at end of string is not escape sequence + Result := Result + '\x'; + '0'..'7': + // start of octal escape sequence + HandleOctEscapeSeq(S, I, Len, Result); + else + // no escape sequence + Result := Result + '\' + S[I]; + end; + end; + Inc(I); + end; +end; + +function StrLower(const S: string): string; +begin + Result := S; + StrLowerInPlace(Result); +end; + +procedure StrLowerInPlace(var S: string); +{$IFDEF UNICODE_RTL_DATABASE} +var + P: PChar; + I, L: SizeInt; +begin + L := Length(S); + if L > 0 then + begin + UniqueString(S); + P := PChar(S); + for I := 1 to L do + begin + P^ := TCharacter.ToLower(P^); + Inc(P); + end; + end; +end; +{$ELSE ~UNICODE_RTL_DATABASE} +begin + StrCase(S, StrLoOffset); +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +procedure StrLowerBuff(S: PChar); +begin + {$IFDEF UNICODE_RTL_DATABASE} + if S <> nil then + begin + repeat + S^ := TCharacter.ToLower(S^); + Inc(S); + until S^ = #0; + end; + {$ELSE ~UNICODE_RTL_DATABASE} + StrCaseBuff(S, StrLoOffset); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +procedure StrMove(var Dest: string; const Source: string; + const ToIndex, FromIndex, Count: SizeInt); +begin + // Check strings + if (Source = '') or (Length(Dest) = 0) then + Exit; + + // Check FromIndex + if (FromIndex <= 0) or (FromIndex > Length(Source)) or + (ToIndex <= 0) or (ToIndex > Length(Dest)) or + ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then + { TODO : Is failure without notice the proper thing to do here? } + Exit; + + // Move + Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char)); +end; + +function StrPadLeft(const S: string; Len: SizeInt; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + if L < Len then + Result := StringOfChar(C, Len - L) + S + else + Result := S; +end; + +function StrPadRight(const S: string; Len: SizeInt; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + if L < Len then + Result := S + StringOfChar(C, Len - L) + else + Result := S; +end; + +function StrProper(const S: string): string; +begin + Result := StrLower(S); + if Result <> '' then + Result[1] := UpCase(Result[1]); +end; + +procedure StrProperBuff(S: PChar); +begin + if (S <> nil) and (S^ <> #0) then + begin + StrLowerBuff(S); + S^ := CharUpper(S^); + end; +end; + +function StrQuote(const S: string; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + Result := S; + if L > 0 then + begin + if Result[1] <> C then + begin + Result := C + Result; + Inc(L); + end; + if Result[L] <> C then + Result := Result + C; + end; +end; + +function StrRemoveChars(const S: string; const Chars: TCharValidator): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if not Chars(Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRemoveChars(const S: string; const Chars: array of Char): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if not ArrayContainsChar(Chars, Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; +var + Len : SizeInt; + I: SizeInt; +begin + Len := Length(S); + I := 1; + while (I <= Len) and Chars(s[I]) do + Inc(I); + Result := Copy (s, I, Len-I+1); +end; + +function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; +var + Len : SizeInt; + I: SizeInt; +begin + Len := Length(S); + I := 1; + while (I <= Len) and ArrayContainsChar(Chars, s[I]) do + Inc(I); + Result := Copy (s, I, Len-I+1); +end; + +function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; +var + Len : SizeInt; +begin + Len := Length(S); + while (Len > 0) and Chars(s[Len]) do + Dec(Len); + Result := Copy (s, 1, Len); +end; + +function StrRemoveEndChars(const S: string; const Chars: array of Char): string; +var + Len : SizeInt; +begin + Len := Length(S); + while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do + Dec(Len); + Result := Copy (s, 1, Len); +end; + +function StrKeepChars(const S: string; const Chars: TCharValidator): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if Chars(Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrKeepChars(const S: string; const Chars: array of Char): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if ArrayContainsChar(Chars, Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRepeat(const S: string; Count: SizeInt): string; +var + Len, Index: SizeInt; + Dest, Source: PChar; +begin + Len := Length(S); + SetLength(Result, Count * Len); + Dest := PChar(Result); + Source := PChar(S); + if Dest <> nil then + for Index := 0 to Count - 1 do + begin + Move(Source^, Dest^, Len * SizeOf(Char)); + Inc(Dest, Len); + end; +end; + +function StrRepeatLength(const S: string; L: SizeInt): string; +var + Len: SizeInt; + Dest: PChar; +begin + Result := ''; + Len := Length(S); + + if (Len > 0) and (S <> '') then + begin + SetLength(Result, L); + Dest := PChar(Result); + while (L > 0) do + begin + Move(S[1], Dest^, Min(L, Len) * SizeOf(Char)); + Inc(Dest, Len); + Dec(L, Len); + end; + end; +end; + +procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags); +var + SearchStr: string; + ResultStr: string; { result string } + SourcePtr: PChar; { pointer into S of character under examination } + SourceMatchPtr: PChar; { pointers into S and Search when first character has } + SearchMatchPtr: PChar; { been matched and we're probing for a complete match } + ResultPtr: PChar; { pointer into Result of character being written } + ResultIndex, + SearchLength, { length of search string } + ReplaceLength, { length of replace string } + BufferLength, { length of temporary result buffer } + ResultLength: SizeInt; { length of result string } + C: Char; { first character of search string } + IgnoreCase: Boolean; +begin + if Search = '' then + begin + if S = '' then + begin + S := Replace; + Exit; + end + else + raise EJclStringError.CreateRes(@RsBlankSearchString); + end; + + if S <> '' then + begin + IgnoreCase := rfIgnoreCase in Flags; + if IgnoreCase then + SearchStr := StrUpper(Search) + else + SearchStr := Search; + { avoid having to call Length() within the loop } + SearchLength := Length(Search); + ReplaceLength := Length(Replace); + ResultLength := Length(S); + BufferLength := ResultLength; + SetLength(ResultStr, BufferLength); + { get pointers to begin of source and result } + ResultPtr := PChar(ResultStr); + SourcePtr := PChar(S); + C := SearchStr[1]; + { while we haven't reached the end of the string } + while True do + begin + { copy characters until we find the first character of the search string } + if IgnoreCase then + while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end + else + while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + { did we find that first character or did we hit the end of the string? } + if SourcePtr^ = #0 then + Break + else + begin + { continue comparing, +1 because first character was matched already } + SourceMatchPtr := SourcePtr + 1; + SearchMatchPtr := PChar(SearchStr) + 1; + if IgnoreCase then + while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do + begin + Inc(SourceMatchPtr); + Inc(SearchMatchPtr); + end + else + while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do + begin + Inc(SourceMatchPtr); + Inc(SearchMatchPtr); + end; + { did we find a complete match? } + if SearchMatchPtr^ = #0 then + begin + // keep track of result length + Inc(ResultLength, ReplaceLength - SearchLength); + if ReplaceLength > 0 then + begin + // increase buffer size if required + if ResultLength > BufferLength then + begin + BufferLength := ResultLength * 2; + ResultIndex := ResultPtr - PChar(ResultStr) + 1; + SetLength(ResultStr, BufferLength); + ResultPtr := @ResultStr[ResultIndex]; + end; + { append replace to result and move past the search string in source } + Move((@Replace[1])^, ResultPtr^, ReplaceLength * SizeOf(Char)); + end; + Inc(SourcePtr, SearchLength); + Inc(ResultPtr, ReplaceLength); + { replace all instances or just one? } + if not (rfReplaceAll in Flags) then + begin + { just one, copy until end of source and break out of loop } + while SourcePtr^ <> #0 do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + Break; + end; + end + else + begin + { copy current character and start over with the next } + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + end; + end; + { set result length and copy result into S } + SetLength(ResultStr, ResultLength); + S := ResultStr; + end; +end; + +function StrReplaceChar(const S: string; const Source, Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if Result[I] = Source then + Result[I] := Replace; +end; + +function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if Chars(Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceButChars(const S: string; const Chars: TCharValidator; + Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if not Chars(Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if not ArrayContainsChar(Chars, Result[I]) then + Result[I] := Replace; +end; + +function StrReverse(const S: string): string; +begin + Result := S; + StrReverseInplace(Result); +end; + +procedure StrReverseInPlace(var S: string); +{ TODO -oahuser : Warning: This is dangerous for unicode surrogates } +var + P1, P2: PChar; + C: Char; +begin + UniqueString(S); + P1 := PChar(S); + P2 := P1 + (Length(S) - 1); + while P1 < P2 do + begin + C := P1^; + P1^ := P2^; + P2^ := C; + Inc(P1); + Dec(P2); + end; +end; + +function StrSingleQuote(const S: string): string; +begin + Result := NativeSingleQuote + S + NativeSingleQuote; +end; + +procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); +begin + while Chars(S^) do + Inc(S); +end; + +procedure StrSkipChars(var S: PChar; const Chars: array of Char); +begin + while ArrayContainsChar(Chars, S^) do + Inc(S); +end; + +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); +begin + while Chars(S[Index]) do + Inc(Index); +end; + +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); +begin + while ArrayContainsChar(Chars, S[Index]) do + Inc(Index); +end; + +function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; +var + Source, Dest: PChar; + Index, Len: SizeInt; + InternalDelimiters: TCharValidator; +begin + Result := ''; + if Assigned(Delimiters) then + InternalDelimiters := Delimiters + else + InternalDelimiters := CharIsSpace; + + if S <> '' then + begin + Result := S; + UniqueString(Result); + + Len := Length(S); + Source := PChar(S); + Dest := PChar(Result); + Inc(Dest); + + for Index := 2 to Len do + begin + if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then + Dest^ := CharUpper(Dest^); + Inc(Dest); + Inc(Source); + end; + Result[1] := CharUpper(Result[1]); + end; +end; + +function StrSmartCase(const S: string; const Delimiters: array of Char): string; +var + Source, Dest: PChar; + Index, Len: SizeInt; +begin + Result := ''; + + if S <> '' then + begin + Result := S; + UniqueString(Result); + + Len := Length(S); + Source := PChar(S); + Dest := PChar(Result); + Inc(Dest); + + for Index := 2 to Len do + begin + if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then + Dest^ := CharUpper(Dest^); + Inc(Dest); + Inc(Source); + end; + Result[1] := CharUpper(Result[1]); + end; +end; + +function StrStringToEscaped(const S: string): string; +var + I: SizeInt; +begin + Result := ''; + for I := 1 to Length(S) do + begin + case S[I] of + NativeBackspace: + Result := Result + '\b'; + NativeBell: + Result := Result + '\a'; + NativeCarriageReturn: + Result := Result + '\r'; + NAtiveFormFeed: + Result := Result + '\f'; + NativeLineFeed: + Result := Result + '\n'; + NativeTab: + Result := Result + '\t'; + NativeVerticalTab: + Result := Result + '\v'; + NativeBackSlash: + Result := Result + '\\'; + NativeDoubleQuote: + Result := Result + '\"'; + else + // Characters < ' ' are escaped with hex sequence + if S[I] < #32 then + Result := Result + Format('\x%.2x', [SizeInt(S[I])]) + else + Result := Result + S[I]; + end; + end; +end; + +function StrStripNonNumberChars(const S: string): string; +var + I: SizeInt; + C: Char; +begin + Result := ''; + for I := 1 to Length(S) do + begin + C := S[I]; + if CharIsNumberChar(C) then + Result := Result + C; + end; +end; + +function StrToHex(const Source: string): string; +var + Index: SizeInt; + C, L, N: SizeInt; + BL, BH: Byte; + S: string; +begin + Result := ''; + if Source <> '' then + begin + S := Source; + L := Length(S); + if Odd(L) then + begin + S := '0' + S; + Inc(L); + end; + Index := 1; + SetLength(Result, L div 2); + C := 1; + N := 1; + while C <= L do + begin + BH := CharHex(S[Index]); + Inc(Index); + BL := CharHex(S[Index]); + Inc(Index); + Inc(C, 2); + if (BH = $FF) or (BL = $FF) then + begin + Result := ''; + Exit; + end; + Result[N] := Char((BH shl 4) or BL); + Inc(N); + end; + end; +end; + +function StrTrimCharLeft(const S: string; C: Char): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and (S[I] = C) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and Chars(S[I]) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and ArrayContainsChar(Chars, S[I]) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharRight(const S: string; C: Char): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and (S[I] = C) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and Chars(S[I]) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimCharsRight(const S: string; const Chars: array of Char): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and ArrayContainsChar(Chars, S[I]) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimQuotes(const S: string): string; +var + First, Last: Char; + L: SizeInt; +begin + L := Length(S); + if L > 1 then + begin + First := S[1]; + Last := S[L]; + if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) then + Result := Copy(S, 2, L - 2) + else + Result := S; + end + else + Result := S; +end; + +function StrUpper(const S: string): string; +begin + Result := S; + StrUpperInPlace(Result); +end; + +procedure StrUpperInPlace(var S: string); +{$IFDEF UNICODE_RTL_DATABASE} +var + P: PChar; + I, L: SizeInt; +begin + L := Length(S); + if L > 0 then + begin + UniqueString(S); + P := PChar(S); + for I := 1 to L do + begin + P^ := TCharacter.ToUpper(P^); + Inc(P); + end; + end; +end; +{$ELSE ~UNICODE_RTL_DATABASE} +begin + StrCase(S, StrUpOffset); +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +procedure StrUpperBuff(S: PChar); +begin + {$IFDEF UNICODE_RTL_DATABASE} + if S <> nil then + begin + repeat + S^ := TCharacter.ToUpper(S^); + Inc(S); + until S^ = #0; + end; + {$ELSE ~UNICODE_RTL_DATABASE} + StrCaseBuff(S, StrUpOffset); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== String Management ====================================================== + +procedure StrAddRef(var S: string); +var + P: PStrRec; +begin + P := Pointer(S); + if P <> nil then + begin + Dec(P); + if P^.RefCount = -1 then + UniqueString(S) + else + LockedInc(P^.RefCount); + end; +end; + +procedure StrDecRef(var S: string); +var + P: PStrRec; +begin + P := Pointer(S); + if P <> nil then + begin + Dec(P); + case P^.RefCount of + -1, 0: { nothing } ; + 1: + begin + Finalize(S); + Pointer(S) := nil; + end; + else + LockedDec(P^.RefCount); + end; + end; +end; + +function StrLength(const S: string): SizeInt; +var + P: PStrRec; +begin + Result := 0; + P := Pointer(S); + if P <> nil then + begin + Dec(P); + Result := P^.Length and (not $80000000 shr 1); + end; +end; + +function StrRefCount(const S: string): SizeInt; +var + P: PStrRec; +begin + Result := 0; + P := Pointer(S); + if P <> nil then + begin + Dec(P); + Result := P^.RefCount; + end; +end; + +procedure StrResetLength(var S: WideString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; + +procedure StrResetLength(var S: AnsiString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; + +procedure StrResetLength(S: TJclStringBuilder); +var + I: SizeInt; +begin + if S <> nil then + for I := 0 to S.Length - 1 do + if S[I] = #0 then + begin + S.Length := I; + Exit; + end; +end; + +{$IFDEF SUPPORTS_UNICODE_STRING} +procedure StrResetLength(var S: UnicodeString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; +{$ENDIF SUPPORTS_UNICODE_STRING} + +//=== String Search and Replace Routines ===================================== + +function StrCharCount(const S: string; C: Char): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if S[I] = C then + Inc(Result); +end; + +function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if Chars(S[I]) then + Inc(Result); +end; + +function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, S[I]) then + Inc(Result); +end; + +function StrStrCount(const S, SubS: string): SizeInt; +var + I: SizeInt; +begin + Result := 0; + if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then + Exit; + if Length(SubS) = 1 then + begin + Result := StrCharCount(S, SubS[1]); + Exit; + end; + I := StrSearch(SubS, S, 1); + + if I > 0 then + Inc(Result); + + while (I > 0) and (Length(S) > I + Length(SubS)) do + begin + I := StrSearch(SubS, S, I + 1); + + if I > 0 then + Inc(Result); + end; +end; + +(* +{ 1} Test(StrCompareRange('', '', 1, 5), 0); +{ 2} Test(StrCompareRange('A', '', 1, 5), -1); +{ 3} Test(StrCompareRange('AB', '', 1, 5), -1); +{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1); +{ 5} Test(StrCompareRange('', 'A', 1, 5), -1); +{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1); +{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1); +{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2); +{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32); +{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0); +{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1); +{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1); +{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32); +{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32); +{15} Test(StrCompareRange('', '', 1, 0), 0); +{16} Test(StrCompareRange('A', 'A', 1, 0), -2); +{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2); +{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0); +{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0); +{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1); +*) +function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +var + Len1, Len2: SizeInt; + I: SizeInt; + C1, C2: Char; +begin + if Pointer(S1) = Pointer(S2) then + begin + if (Count <= 0) and (S1 <> '') then + Result := -2 // no work + else + Result := 0; + end + else + if (S1 = '') or (S2 = '') then + Result := -1 // null string + else + if Count <= 0 then + Result := -2 // no work + else + begin + Len1 := Length(S1); + Len2 := Length(S2); + + if (Index - 1) + Count > Len1 then + Result := -2 + else + begin + if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it + Count := Len2 - (Index - 1); + + if CaseSensitive then + begin + for I := 0 to Count - 1 do + begin + C1 := S1[Index + I]; + C2 := S2[Index + I]; + if C1 <> C2 then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + end; + end + else + begin + for I := 0 to Count - 1 do + begin + C1 := S1[Index + I]; + C2 := S2[Index + I]; + if C1 <> C2 then + begin + C1 := CharLower(C1); + C2 := CharLower(C2); + if C1 <> C2 then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + end; + end; + end; + Result := 0; + end; + end; +end; + +function StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt; +var + Len1, Len2: SizeInt; +begin + if Pointer(S1) = Pointer(S2) then + Result := 0 + else + begin + Len1 := Length(S1); + Len2 := Length(S2); + Result := Len1 - Len2; + if Result = 0 then + Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive); + end; +end; + +function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +begin + Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive); +end; + +procedure StrFillChar(var S; Count: SizeInt; C: Char); +{$IFDEF SUPPORTS_UNICODE} +asm + // 32 --> EAX S + // EDX Count + // ECX C + // 64 --> RCX S + // RDX Count + // R8W C + {$IFDEF CPU32} + DEC EDX + JS @@Leave +@@Loop: + MOV [EAX], CX + ADD EAX, 2 + DEC EDX + JNS @@Loop + {$ENDIF CPU32} + {$IFDEF CPU64} + DEC RDX + JS @@Leave +@@Loop: + MOV WORD PTR [RCX], R8W + ADD RCX, 2 + DEC RDX + JNS @@Loop + {$ENDIF CPU64} +@@Leave: +end; +{$ELSE ~SUPPORTS_UNICODE} +begin + if Count > 0 then + FillChar(S, Count, C); +end; +{$ENDIF ~SUPPORTS_UNICODE} + +function StrRepeatChar(C: Char; Count: SizeInt): string; +begin + SetLength(Result, Count); + if Count > 0 then + StrFillChar(Result[1], Count, C); +end; + +function StrFind(const Substr, S: string; const Index: SizeInt): SizeInt; +var + pos: SizeInt; +begin + if (SubStr <> '') and (S <> '') then + begin + pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1)); + if pos = 0 then + Result := 0 + else + Result := Index + Pos - 1; + end + else + Result := 0; +end; + +function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; +begin + Result := StrPrefixIndex(S, Prefixes) > -1; +end; + +function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; +begin + Result := StrSuffixIndex(S, Suffixes) > -1; +end; + +function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean): SizeInt; +var + I: SizeInt; +begin + Result := -1; + for I := Low(List) to High(List) do + begin + if StrCompare(S, List[I], CaseSensitive) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; +begin + Result := StrIPrefixIndex(S, Prefixes) > -1; +end; + +function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; +begin + Result := StrISuffixIndex(S, Suffixes) > -1; +end; + +function StrILastPos(const SubStr, S: string): SizeInt; +begin + Result := StrLastPos(StrUpper(SubStr), StrUpper(S)); +end; + +function StrIPos(const SubStr, S: string): SizeInt; +begin + Result := Pos(StrUpper(SubStr), StrUpper(S)); +end; + +function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Prefixes) to High(Prefixes) do + begin + Test := StrLeft(S, Length(Prefixes[I])); + if CompareText(Test, Prefixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrIsOneOf(const S: string; const List: array of string): Boolean; +begin + Result := StrIndex(S, List) > -1; +end; + +function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Suffixes) to High(Suffixes) do + begin + Test := StrRight(S, Length(Suffixes[I])); + if CompareText(Test, Suffixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrLastPos(const SubStr, S: string): SizeInt; +var + Last, Current: PChar; +begin + Result := 0; + Last := nil; + Current := PChar(S); + + while (Current <> nil) and (Current^ <> #0) do + begin + Current := StrPos(PChar(Current), PChar(SubStr)); + if Current <> nil then + begin + Last := Current; + Inc(Current); + end; + end; + if Last <> nil then + Result := Abs(PChar(S) - Last) + 1; +end; + +// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*) +// (*) acts like (?) + +function StrMatch(const Substr, S: string; Index: SizeInt): SizeInt; +var + SI, SubI, SLen, SubLen: SizeInt; + SubC: Char; +begin + SLen := Length(S); + SubLen := Length(Substr); + Result := 0; + if (Index > SLen) or (SubLen = 0) then + Exit; + while Index <= SLen do + begin + SubI := 1; + SI := Index; + while (SI <= SLen) and (SubI <= SubLen) do + begin + SubC := Substr[SubI]; + if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then + begin + Inc(SI); + Inc(SubI); + end + else + Break; + end; + if SubI > SubLen then + begin + Result := Index; + Break; + end; + Inc(Index); + end; +end; + +// Derived from "Like" by Michael Winter +function StrMatches(const Substr, S: string; const Index: SizeInt): Boolean; +var + StringPtr: PChar; + PatternPtr: PChar; + StringRes: PChar; + PatternRes: PChar; +begin + if SubStr = '' then + raise EJclStringError.CreateRes(@RsBlankSearchString); + + Result := SubStr = '*'; + + if Result or (S = '') then + Exit; + + if (Index <= 0) or (Index > Length(S)) then + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + + StringPtr := PChar(@S[Index]); + PatternPtr := PChar(SubStr); + StringRes := nil; + PatternRes := nil; + + repeat + repeat + case PatternPtr^ of + #0: + begin + Result := StringPtr^ = #0; + if Result or (StringRes = nil) or (PatternRes = nil) then + Exit; + + StringPtr := StringRes; + PatternPtr := PatternRes; + Break; + end; + '*': + begin + Inc(PatternPtr); + PatternRes := PatternPtr; + Break; + end; + '?': + begin + if StringPtr^ = #0 then + Exit; + Inc(StringPtr); + Inc(PatternPtr); + end; + else + begin + if StringPtr^ = #0 then + Exit; + if StringPtr^ <> PatternPtr^ then + begin + if (StringRes = nil) or (PatternRes = nil) then + Exit; + StringPtr := StringRes; + PatternPtr := PatternRes; + Break; + end + else + begin + Inc(StringPtr); + Inc(PatternPtr); + end; + end; + end; + until False; + + repeat + case PatternPtr^ of + #0: + begin + Result := True; + Exit; + end; + '*': + begin + Inc(PatternPtr); + PatternRes := PatternPtr; + end; + '?': + begin + if StringPtr^ = #0 then + Exit; + Inc(StringPtr); + Inc(PatternPtr); + end; + else + begin + repeat + if StringPtr^ = #0 then + Exit; + if StringPtr^ = PatternPtr^ then + Break; + Inc(StringPtr); + until False; + Inc(StringPtr); + StringRes := StringPtr; + Inc(PatternPtr); + Break; + end; + end; + until False; + until False; +end; + +function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; +var + I, P: SizeInt; +begin + if N < 1 then + begin + Result := 0; + Exit; + end; + + Result := StrSearch(SubStr, S, 1); + I := 1; + while I < N do + begin + P := StrSearch(SubStr, S, Result + 1); + if P = 0 then + begin + Result := 0; + Break; + end + else + begin + Result := P; + Inc(I); + end; + end; +end; + +function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; +var + I, P: SizeInt; +begin + if N < 1 then + begin + Result := 0; + Exit; + end; + + Result := StrFind(SubStr, S, 1); + I := 1; + while I < N do + begin + P := StrFind(SubStr, S, Result + 1); + if P = 0 then + begin + Result := 0; + Break; + end + else + begin + Result := P; + Inc(I); + end; + end; +end; + +function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Prefixes) to High(Prefixes) do + begin + Test := StrLeft(S, Length(Prefixes[I])); + if CompareStr(Test, Prefixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt; +var + SP, SPI, SubP: PChar; + SLen: SizeInt; +begin + SLen := Length(S); + if Index <= SLen then + begin + SP := PChar(S); + SubP := PChar(Substr); + SPI := SP; + Inc(SPI, Index); + Dec(SPI); + SPI := StrPos(SPI, SubP); + if SPI <> nil then + Result := SPI - SP + 1 + else + Result := 0; + end + else + Result := 0; +end; + +function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Suffixes) to High(Suffixes) do + begin + Test := StrRight(S, Length(Suffixes[I])); + if CompareStr(Test, Suffixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +//=== String Extraction ====================================================== + +function StrAfter(const SubStr, S: string): string; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos + if P <= 0 then + Result := '' // substr not found -> nothing after it + else + Result := StrRestOf(S, P + Length(SubStr)); +end; + +function StrBefore(const SubStr, S: string): string; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); + if P <= 0 then + Result := S + else + Result := StrLeft(S, P - 1); +end; + +function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); + Result:= p > 0; + if Result then + begin + Left := StrLeft(S, P - 1); + Right := StrRestOf(S, P + Length(SubStr)); + end + else + begin + Left := ''; + Right := ''; + end; +end; + +function StrBetween(const S: string; const Start, Stop: Char): string; +var + PosStart, PosEnd: SizeInt; + L: SizeInt; +begin + PosStart := Pos(Start, S); + PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart. + + if (PosStart > 0) and (PosEnd > PosStart) then + begin + L := PosEnd - PosStart; + Result := Copy(S, PosStart + 1, L - 1); + end + else + Result := ''; +end; + +function StrChopRight(const S: string; N: SizeInt): string; +begin + Result := Copy(S, 1, Length(S) - N); +end; + +function StrLeft(const S: string; Count: SizeInt): string; +begin + Result := Copy(S, 1, Count); +end; + +function StrMid(const S: string; Start, Count: SizeInt): string; +begin + Result := Copy(S, Start, Count); +end; + +function StrRestOf(const S: string; N: SizeInt): string; +begin + Result := Copy(S, N, (Length(S) - N + 1)); +end; + +function StrRight(const S: string; Count: SizeInt): string; +begin + Result := Copy(S, Length(S) - Count + 1, Count); +end; + +//=== Character (do we have it ;) ============================================ + +function CharEqualNoCase(const C1, C2: Char): Boolean; +begin + //if they are not equal chars, may be same letter different case + Result := (C1 = C2) or + (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2))); +end; + + +function CharIsAlpha(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLetter(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_ALPHA) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsAlphaNum(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLetterOrDigit(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsBlank(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx + Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_BLANK) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsControl(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsControl(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_CNTRL) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsDelete(const C: Char): Boolean; +begin + Result := (C = #8); +end; + +function CharIsDigit(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsDigit(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_DIGIT) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsFracDigit(const C: Char): Boolean; +begin + Result := (C = '.') or CharIsDigit(C); +end; + +function CharIsHexDigit(const C: Char): Boolean; +begin + case C of + 'A'..'F', + 'a'..'f': + Result := True; + else + Result := CharIsDigit(C); + end; +end; + +function CharIsLower(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLower(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_LOWER) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsNumberChar(const C: Char): Boolean; +begin + Result := CharIsDigit(C) or (C = '+') or (C = '-') or (C = JclFormatSettings.DecimalSeparator); +end; + +function CharIsNumber(const C: Char): Boolean; +begin + Result := CharIsDigit(C) or (C = JclFormatSettings.DecimalSeparator); +end; + +function CharIsPrintable(const C: Char): Boolean; +begin + Result := not CharIsControl(C); +end; + +function CharIsPunctuation(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsPunctuation(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_PUNCT) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsReturn(const C: Char): Boolean; +begin + Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); +end; + +function CharIsSpace(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsWhiteSpace(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_SPACE) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsUpper(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsUpper(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_UPPER) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsValidIdentifierLetter(const C: Char): Boolean; +begin + case C of + {$IFDEF SUPPORTS_UNICODE} + // from XML specifications + #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D, + #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF, + #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs? + #$00B7, #$0300..#$036F, #$203F..#$2040, + {$ENDIF SUPPORTS_UNICODE} + '0'..'9', 'A'..'Z', 'a'..'z', '_': + Result := True; + else + Result := False; + end; +end; + +function CharIsWhiteSpace(const C: Char): Boolean; +begin + case C of + NativeTab, + NativeLineFeed, + NativeVerticalTab, + NativeFormFeed, + NativeCarriageReturn, + NativeSpace: + Result := True; + else + Result := False; + end; +end; + +function CharIsWildcard(const C: Char): Boolean; +begin + case C of + '*', '?': + Result := True; + else + Result := False; + end; +end; + +function CharType(const C: Char): Word; +begin + {$IFDEF UNICODE_RTL_DATABASE} + GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCharTypes[C]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== PCharVector ============================================================ + +function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; +var + I: SizeInt; + S: string; + List: array of PChar; +begin + Assert(Source <> nil); + Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar)); + SetLength(List, Source.Count + SizeOf(Char)); + for I := 0 to Source.Count - 1 do + begin + S := Source[I]; + List[I] := StrAlloc(Length(S) + SizeOf(Char)); + StrPCopy(List[I], S); + end; + List[Source.Count] := nil; + Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar)); + Result := Dest; +end; + +function PCharVectorCount(Source: PCharVector): SizeInt; +begin + Result := 0; + if Source <> nil then + begin + while Source^ <> nil do + begin + Inc(Source); + Inc(Result); + end; + end; +end; + +procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); +var + I, Count: SizeInt; + List: array of PChar; +begin + Assert(Dest <> nil); + if Source <> nil then + begin + Count := PCharVectorCount(Source); + SetLength(List, Count); + Move(Source^, List[0], Count * SizeOf(PChar)); + Dest.BeginUpdate; + try + Dest.Clear; + for I := 0 to Count - 1 do + Dest.Add(List[I]); + finally + Dest.EndUpdate; + end; + end; +end; + +procedure FreePCharVector(var Dest: PCharVector); +var + I, Count: SizeInt; + List: array of PChar; +begin + if Dest <> nil then + begin + Count := PCharVectorCount(Dest); + SetLength(List, Count); + Move(Dest^, List[0], Count * SizeOf(PChar)); + for I := 0 to Count - 1 do + StrDispose(List[I]); + FreeMem(Dest, (Count + 1) * SizeOf(PChar)); + Dest := nil; + end; +end; + +//=== Character Transformation Routines ====================================== + +function CharHex(const C: Char): Byte; +begin + case C of + '0'..'9': + Result := Ord(C) - Ord('0'); + 'a'..'f': + Result := Ord(C) - Ord('a') + 10; + 'A'..'F': + Result := Ord(C) - Ord('A') + 10; + else + Result := $FF; + end; +end; + +function CharLower(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.ToLower(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrLoOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharToggleCase(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + if CharIsLower(C) then + Result := CharUpper(C) + else if CharIsUpper(C) then + Result := CharLower(C) + else + Result := C; + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrReOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharUpper(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.ToUpper(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrUpOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== Character Search and Replace =========================================== + +function CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + for Result := Length(S) downto Index do + if S[Result] = C then + Exit; + end; + Result := 0; +end; + +function CharPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + for Result := Index to Length(S) do + if S[Result] = C then + Exit; + end; + Result := 0; +end; + +function CharIPos(const S: string; C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + C := CharUpper(C); + for Result := Index to Length(S) do + if CharUpper(S[Result]) = C then + Exit; + end; + Result := 0; +end; + +function CharReplace(var S: string; const Search, Replace: Char): SizeInt; +var + P: PChar; + Index, Len: SizeInt; +begin + Result := 0; + if Search <> Replace then + begin + UniqueString(S); + P := PChar(S); + Len := Length(S); + for Index := 0 to Len - 1 do + begin + if P^ = Search then + begin + P^ := Replace; + Inc(Result); + end; + Inc(P); + end; + end; +end; + +//=== MultiSz ================================================================ + +function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; +var + I, TotalLength: SizeInt; + P: PMultiSz; +begin + Assert(Source <> nil); + TotalLength := 1; + for I := 0 to Source.Count - 1 do + if Source[I] = '' then + raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem) + else + Inc(TotalLength, StrLen(PChar(Source[I])) + 1); + AllocateMultiSz(Dest, TotalLength); + P := Dest; + for I := 0 to Source.Count - 1 do + begin + P := StrECopy(P, PChar(Source[I])); + Inc(P); + end; + P^ := #0; + Result := Dest; +end; + +procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); +var + P: PMultiSz; +begin + Assert(Dest <> nil); + Dest.BeginUpdate; + try + Dest.Clear; + if Source <> nil then + begin + P := Source; + while P^ <> #0 do + begin + Dest.Add(P); + P := StrEnd(P); + Inc(P); + end; + end; + finally + Dest.EndUpdate; + end; +end; + +function MultiSzLength(const Source: PMultiSz): SizeInt; +var + P: PMultiSz; +begin + Result := 0; + if Source <> nil then + begin + P := Source; + repeat + Inc(Result, StrLen(P) + 1); + P := StrEnd(P); + Inc(P); + until P^ = #0; + Inc(Result); + end; +end; + +procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); +begin + if Len > 0 then + GetMem(Dest, Len * SizeOf(Char)) + else + Dest := nil; +end; + +procedure FreeMultiSz(var Dest: PMultiSz); +begin + if Dest <> nil then + FreeMem(Dest); + Dest := nil; +end; + +function MultiSzDup(const Source: PMultiSz): PMultiSz; +var + Len: SizeInt; +begin + if Source <> nil then + begin + Len := MultiSzLength(Source); + Result := nil; + AllocateMultiSz(Result, Len); + Move(Source^, Result^, Len * SizeOf(Char)); + end + else + Result := nil; +end; + +function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; +begin + Result := JclAnsiStrings.StringsToMultiSz(Dest, Source); +end; + +procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); +begin + JclAnsiStrings.MultiSzToStrings(Dest, Source); +end; + +function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; +begin + Result := JclAnsiStrings.MultiSzLength(Source); +end; + +procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); +begin + JclAnsiStrings.AllocateMultiSz(Dest, Len); +end; + +procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); +begin + JclAnsiStrings.FreeMultiSz(Dest); +end; + +function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; +begin + Result := JclAnsiStrings.MultiSzDup(Source); +end; + +function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; +begin + Result := JclWideStrings.StringsToMultiSz(Dest, Source); +end; + +procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); +begin + JclWideStrings.MultiSzToStrings(Dest, Source); +end; + +function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; +begin + Result := JclWideStrings.MultiSzLength(Source); +end; + +procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); +begin + JclWideStrings.AllocateMultiSz(Dest, Len); +end; + +procedure FreeWideMultiSz(var Dest: PWideMultiSz); +begin + JclWideStrings.FreeMultiSz(Dest); +end; + +function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; +begin + Result := JclWideStrings.MultiSzDup(Source); +end; + +//=== TStrings Manipulation ================================================== + +procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +var + I, L: SizeInt; + Left: string; +begin + Assert(List <> nil); + List.BeginUpdate; + try + List.Clear; + L := Length(Sep); + I := Pos(Sep, S); + while I > 0 do + begin + Left := StrLeft(S, I - 1); + if (Left <> '') or AllowEmptyString then + List.Add(Left); + Delete(S, 1, I + L - 1); + I := Pos(Sep, S); + end; + if S <> '' then + List.Add(S); // Ignore empty strings at the end. + finally + List.EndUpdate; + end; +end; + +procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +var + I, L: SizeInt; + LowerCaseStr: string; + Left: string; +begin + Assert(List <> nil); + LowerCaseStr := StrLower(S); + Sep := StrLower(Sep); + L := Length(Sep); + I := Pos(Sep, LowerCaseStr); + List.BeginUpdate; + try + List.Clear; + while I > 0 do + begin + Left := StrLeft(S, I - 1); + if (Left <> '') or AllowEmptyString then + List.Add(Left); + Delete(S, 1, I + L - 1); + Delete(LowerCaseStr, 1, I + L - 1); + I := Pos(Sep, LowerCaseStr); + end; + if S <> '' then + List.Add(S); // Ignore empty strings at the end. + finally + List.EndUpdate; + end; +end; + +function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; +var + I, L: SizeInt; +begin + Result := ''; + for I := 0 to List.Count - 1 do + begin + if (List[I] <> '') or AllowEmptyString then + begin + // don't combine these into one addition, somehow it hurts performance + Result := Result + List[I]; + Result := Result + Sep; + end; + end; + // remove terminating separator + if List.Count > 0 then + begin + L := Length(Sep); + Delete(Result, Length(Result) - L + 1, L); + end; +end; + +function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: + Boolean = True): string; +var + I, L, N: SizeInt; +begin + Result := ''; + if List.Count > NumberOfItems then + N := NumberOfItems + else + N := List.Count; + for I := 0 to N - 1 do + begin + if (List[I] <> '') or AllowEmptyString then + begin + // don't combine these into one addition, somehow it hurts performance + Result := Result + List[I]; + Result := Result + Sep; + end; + end; + // remove terminating separator + if N > 0 then + begin + L := Length(Sep); + Delete(Result, Length(Result) - L + 1, L); + end; +end; + +procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := Trim(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := TrimRight(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := TrimLeft(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; +begin + Assert(Strings <> nil); + Result := Unique and (Strings.IndexOf(S) <> -1); + if not Result then + Result := Strings.Add(S) > -1; +end; + +//=== Miscellaneous ========================================================== + +function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; +var + fs: TFileStream; + Len: SizeInt; +begin + fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + Len := fs.Size; + SetLength(Result, Len); + if Len > 0 then + fs.ReadBuffer(Result[1], Len); + finally + fs.Free; + end; +end; + +procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; + Append: Boolean); +var + FS: TFileStream; + Len: SizeInt; +begin + if Append and FileExists(filename) then + FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite) + else + FS := TFileStream.Create(FileName, fmCreate); + try + if Append then + FS.Seek(0, soEnd); // faster than .Position := .Size + Len := Length(Contents); + if Len > 0 then + FS.WriteBuffer(Contents[1], Len); + finally + FS.Free; + end; +end; + +function StrToken(var S: string; Separator: Char): string; +var + I: SizeInt; +begin + I := Pos(Separator, S); + if I <> 0 then + begin + Result := Copy(S, 1, I - 1); + Delete(S, 1, I); + end + else + begin + Result := S; + S := ''; + end; +end; + +procedure StrTokens(const S: string; const List: TStrings); +var + Start: PChar; + Token: string; + Done: Boolean; +begin + Assert(List <> nil); + if List = nil then + Exit; + + List.BeginUpdate; + try + List.Clear; + Start := Pointer(S); + repeat + Done := JclStrings.StrWord(Start, Token); + if Token <> '' then + List.Add(Token); + until Done; + finally + List.EndUpdate; + end; +end; + +function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; +var + Start: SizeInt; + C: Char; +begin + Word := ''; + if (S = '') then + begin + Result := True; + Exit; + end; + Start := Index; + Result := False; + while True do + begin + C := S[Index]; + case C of + #0: + begin + if Start <> 0 then + Word := Copy(S, Start, Index - Start); + Result := True; + Exit; + end; + NativeSpace, NativeLineFeed, NativeCarriageReturn: + begin + if Start <> 0 then + begin + Word := Copy(S, Start, Index - Start); + Exit; + end + else + begin + while CharIsWhiteSpace(C) do + begin + Inc(Index); + C := S[Index]; + end; + end; + end; + else + if Start = 0 then + Start := Index; + Inc(Index); + end; + end; +end; + +function StrWord(var S: PChar; out Word: string): Boolean; +var + Start: PChar; +begin + Word := ''; + if S = nil then + begin + Result := True; + Exit; + end; + Start := nil; + Result := False; + while True do + begin + case S^ of + #0: + begin + if Start <> nil then + SetString(Word, Start, S - Start); + Result := True; + Exit; + end; + NativeSpace, NativeLineFeed, NativeCarriageReturn: + begin + if Start <> nil then + begin + SetString(Word, Start, S - Start); + Exit; + end + else + while CharIsWhiteSpace(S^) do + Inc(S); + end; + else + if Start = nil then + Start := S; + Inc(S); + end; + end; +end; + +function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; +var + Start: SizeInt; + C: Char; +begin + Ident := ''; + if (S = '') then + begin + Result := True; + Exit; + end; + Start := Index; + Result := False; + while True do + begin + C := S[Index]; + if CharIsValidIdentifierLetter(C) then + begin + if Start = 0 then + Start := Index; + end + else + if C = #0 then + begin + if Start <> 0 then + Ident := Copy(S, Start, Index - Start); + Result := True; + Exit; + end + else + begin + if Start <> 0 then + begin + Ident := Copy(S, Start, Index - Start); + Exit; + end; + end; + Inc(Index); + end; +end; + +function StrIdent(var S: PChar; out Ident: string): Boolean; +var + Start: PChar; + C: Char; +begin + Ident := ''; + if S = nil then + begin + Result := True; + Exit; + end; + Start := nil; + Result := False; + while True do + begin + C := S^; + if CharIsValidIdentifierLetter(C) then + begin + if Start = nil then + Start := S; + end + else + if C = #0 then + begin + if Start <> nil then + SetString(Ident, Start, S - Start); + Result := True; + Exit; + end + else + begin + if Start <> nil then + begin + SetString(Ident, Start, S - Start); + Exit; + end + end; + Inc(S); + end; +end; + +procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); +var + Token: string; +begin + Assert(List <> nil); + + if List = nil then + Exit; + + List.BeginUpdate; + try + List.Clear; + while S <> '' do + begin + Token := StrToken(S, Separator); + List.Add(Token); + end; + finally + List.EndUpdate; + end; +end; + +function StrToFloatSafe(const S: string): Float; +var + Temp: string; + I, J, K: SizeInt; + SwapSeparators, IsNegative: Boolean; + DecSep, ThouSep, C: Char; +begin + DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator; + ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator; + Temp := S; + SwapSeparators := False; + + IsNegative := False; + J := 0; + for I := 1 to Length(Temp) do + begin + C := Temp[I]; + if C = '-' then + IsNegative := not IsNegative + else + if (C <> ' ') and (C <> '(') and (C <> '+') then + begin + // if it appears prior to any digit, it has to be a decimal separator + SwapSeparators := Temp[I] = ThouSep; + J := I; + Break; + end; + end; + + if not SwapSeparators then + begin + K := CharPos(Temp, DecSep); + SwapSeparators := + // if it appears prior to any digit, it has to be a decimal separator + (K > J) and + // if it appears multiple times, it has to be a thousand separator + ((StrCharCount(Temp, DecSep) > 1) or + // we assume (consistent with Windows Platform SDK documentation), + // that thousand separators appear only to the left of the decimal + (K < CharPos(Temp, ThouSep))); + end; + + if SwapSeparators then + begin + // assume a numerical string from a different locale, + // where DecimalSeparator and ThousandSeparator are exchanged + for I := 1 to Length(Temp) do + if Temp[I] = DecSep then + Temp[I] := ThouSep + else + if Temp[I] = ThouSep then + Temp[I] := DecSep; + end; + + Temp := StrKeepChars(Temp, CharIsNumber); + + if Length(Temp) > 0 then + begin + if Temp[1] = DecSep then + Temp := '0' + Temp; + if Temp[Length(Temp)] = DecSep then + Temp := Temp + '0'; + Result := StrToFloat(Temp); + if IsNegative then + Result := -Result; + end + else + Result := 0.0; +end; + +function StrToIntSafe(const S: string): Integer; +begin + Result := Trunc(StrToFloatSafe(S)); +end; + +procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; +begin + Index := Max(1, Min(Index, StrLen + 1)); + Count := Max(0, Min(Count, StrLen + 1 - Index)); +end; + +function ArrayOf(List: TStrings): TDynStringArray; +var + I: SizeInt; +begin + if List <> nil then + begin + SetLength(Result, List.Count); + for I := 0 to List.Count - 1 do + Result[I] := List[I]; + end + else + Result := nil; +end; + +const + BoolToStr: array [Boolean] of string = ('false', 'true'); + +type + TInterfacedObjectAccess = class(TInterfacedObject); + +procedure MoveChar(const Source; var Dest; Count: SizeInt); +begin + if Count > 0 then + Move(Source, Dest, Count * SizeOf(Char)); +end; + +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); +end; + +function DotNetFormat(const Fmt: string; const Args: array of const): string; +var + F, P: PChar; + Len, Capacity, Count: SizeInt; + Index: SizeInt; + ErrorCode: Integer; + S: string; + + procedure Grow(Count: SizeInt); + begin + if Len + Count > Capacity then + begin + Capacity := Capacity * 5 div 3 + Count; + SetLength(Result, Capacity); + end; + end; + + function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; + begin + Result := True; + while AClass <> nil do + begin + if CompareText(AClass.ClassName, ClassName) = 0 then + Exit; + AClass := AClass.ClassParent; + end; + Result := False; + end; + + function GetStringOf(const V: TVarData; Index: SizeInt): string; overload; + begin + case V.VType of + varEmpty, varNull: + raise ArgumentNullException.CreateRes(@RsArgumentIsNull); + varSmallInt: + Result := IntToStr(V.VSmallInt); + varInteger: + Result := IntToStr(V.VInteger); + varSingle: + Result := FloatToStr(V.VSingle); + varDouble: + Result := FloatToStr(V.VDouble); + varCurrency: + Result := CurrToStr(V.VCurrency); + varDate: + Result := DateTimeToStr(V.VDate); + varOleStr: + Result := V.VOleStr; + varBoolean: + Result := BoolToStr[V.VBoolean <> False]; + varByte: + Result := IntToStr(V.VByte); + varWord: + Result := IntToStr(V.VWord); + varShortInt: + Result := IntToStr(V.VShortInt); + varLongWord: + Result := IntToStr(V.VLongWord); + varInt64: + Result := IntToStr(V.VInt64); + varString: + Result := string(V.VString); + {$IFDEF SUPPORTS_UNICODE_STRING} + varUString: + Result := string(V.VUString); + {$ENDIF SUPPORTS_UNICODE_STRING} + {varArray, + varDispatch, + varError, + varUnknown, + varAny, + varByRef:} + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + + function GetStringOf(Index: SizeInt): string; overload; + var + V: TVarRec; + Intf: IToString; + begin + V := Args[Index]; + if (V.VInteger = 0) and + (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, + vtInterface, vtInt64]) then + raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); + + case V.VType of + vtInteger: + Result := IntToStr(V.VInteger); + vtBoolean: + Result := BoolToStr[V.VBoolean]; + vtChar: + Result := string(AnsiString(V.VChar)); + vtExtended: + Result := FloatToStr(V.VExtended^); + vtString: + Result := string(V.VString^); + vtPointer: + Result := IntToHex(TJclAddr(V.VPointer), 8); + vtPChar: + Result := string(AnsiString(V.VPChar)); + vtObject: + if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then + begin + Result := Intf.ToString; + Pointer(Intf) := nil; // do not release the object + // undo the RefCount change + Dec(TInterfacedObjectAccess(V.VObject).FRefCount); + end + else + if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then + Result := Intf.ToString + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + vtClass: + Result := V.VClass.ClassName; + vtWideChar: + Result := V.VWideChar; + vtPWideChar: + Result := V.VPWideChar; + vtAnsiString: + Result := string(V.VAnsiString); + vtCurrency: + Result := CurrToStr(V.VCurrency^); + vtVariant: + Result := GetStringOf(TVarData(V.VVariant^), Index); + vtInterface: + if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then + Result := IToString(Intf).ToString + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + vtWideString: + Result := WideString(V.VWideString); + vtInt64: + Result := IntToStr(V.VInt64^); + {$IFDEF SUPPORTS_UNICODE_STRING} + vtUnicodeString: + Result := UnicodeString(V.VUnicodeString); + {$ENDIF SUPPORTS_UNICODE_STRING} + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + +begin + if Length(Args) = 0 then + begin + Result := Fmt; + Exit; + end; + Len := 0; + Capacity := Length(Fmt); + SetLength(Result, Capacity); + if Capacity = 0 then + raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); + + P := Pointer(Fmt); + F := P; + while True do + begin + if (P[0] = #0) or (P[0] = '{') then + begin + Count := P - F; + Inc(P); + if (P[-1] <> #0) and (P[0] = '{') then + Inc(Count); // include '{' + + if Count > 0 then + begin + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + end; + + if P[-1] = #0 then + Break; + + if P[0] <> '{' then + begin + F := P; + Inc(P); + while (P[0] <> #0) and (P[0] <> '}') do + Inc(P); + SetString(S, F, P - F); + Val(S, Index, ErrorCode); + if ErrorCode <> 0 then + raise FormatException.CreateRes(@RsFormatException); + if (Index < 0) or (Index > High(Args)) then + raise FormatException.CreateRes(@RsFormatException); + S := GetStringOf(Index); + if S <> '' then + begin + Grow(Length(S)); + MoveChar(S[1], Result[Len + 1], Length(S)); + Inc(Len, Length(S)); + end; + + if P[0] = #0 then + Break; + end; + F := P + 1; + end + else + if (P[0] = '}') and (P[1] = '}') then + begin + Count := P - F + 1; + Inc(P); // skip next '}' + + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + F := P + 1; + end; + + Inc(P); + end; + + SetLength(Result, Len); +end; + +//=== { TJclStringBuilder } ===================================================== + +constructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt); +begin + inherited Create; + SetLength(FChars, Capacity); + FMaxCapacity := MaxCapacity; +end; + +constructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt); +begin + Create(Capacity); + Append(Value); +end; + +constructor TJclStringBuilder.Create(const Value: string; StartIndex, + Length, Capacity: SizeInt); +begin + Create(Capacity); + Append(Value, StartIndex + 1, Length); +end; + +function TJclStringBuilder.ToString: string; +begin + if FLength > 0 then + SetString(Result, PChar(@FChars[0]), FLength) + else + Result := ''; +end; + +function TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt; +begin + if System.Length(FChars) < Capacity then + SetCapacity(Capacity); + Result := System.Length(FChars); +end; + +procedure TJclStringBuilder.SetCapacity(const Value: SizeInt); +begin + if Value <> System.Length(FChars) then + begin + SetLength(FChars, Value); + if Value < FLength then + FLength := Value; + end; +end; + +function TJclStringBuilder.GetChars(Index: SizeInt): Char; +begin + Result := FChars[Index]; +end; + +procedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char); +begin + FChars[Index] := Value; +end; + +procedure TJclStringBuilder.Set_Length(const Value: SizeInt); +begin + FLength := Value; +end; + +function TJclStringBuilder.GetCapacity: SizeInt; +begin + Result := System.Length(FChars); +end; + +function TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder; +var + Capacity: SizeInt; +begin + if (Count > 0) and (RepeatCount > 0) then + begin + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + if Count = 1 then + FChars[FLength] := Value[0] + else + MoveChar(Value[0], FChars[FLength], Count); + Inc(FLength, Count); + Dec(RepeatCount); + until RepeatCount <= 0; + end; + Result := Self; +end; + +function TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count, + RepeatCount: SizeInt): TJclStringBuilder; +var + Capacity: SizeInt; +begin + if (Index < 0) or (Index > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + + if Index = FLength then + AppendPChar(Value, Count, RepeatCount) + else + if (Count > 0) and (RepeatCount > 0) then + begin + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); + if Count = 1 then + FChars[Index] := Value[0] + else + MoveChar(Value[0], FChars[Index], Count); + Inc(FLength, Count); + + Dec(RepeatCount); + + Inc(Index, Count); // little optimization + until RepeatCount <= 0; + end; + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(@Value[0], Len); + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; +begin + Result := AppendPChar(@Value, 1, RepeatCount); +end; + +function TJclStringBuilder.Append(const Value: string): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(Pointer(Value), Len); + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder; +begin + Result := Append(BoolToStr[Value]); +end; + +function TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Integer): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Double): TJclStringBuilder; +begin + Result := Append(FloatToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Int64): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder; +begin + Result := Append(DotNetFormat('{0}', [Obj])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, Args)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, @Value[0], Len); + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, Pointer(Value), Len, Count); + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; +begin + Result := Insert(Index, BoolToStr[Value]); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char; + StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder; +begin + Result := Insert(Index, FloatToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; +begin + Result := Insert(Index, DotNetFormat('{0}', [Obj])); +end; + +function TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder; +begin + if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Length > 0 then + begin + MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length)); + Dec(FLength, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, + Count: SizeInt): TJclStringBuilder; +var + I: SizeInt; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if (Count > 0) and (OldChar <> NewChar) then + begin + for I := StartIndex to StartIndex + Length - 1 do + if FChars[I] = OldChar then + FChars[I] := NewChar; + end; + Result := Self; +end; + +function TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder; +var + I: SizeInt; + Offset: SizeInt; + NewLen, OldLen, Capacity: SizeInt; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if OldValue = '' then + raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); + + if (Count > 0) and (OldValue <> NewValue) then + begin + OldLen := System.Length(OldValue); + NewLen := System.Length(NewValue); + Offset := NewLen - OldLen; + Capacity := System.Length(FChars); + for I := StartIndex to StartIndex + Length - 1 do + if FChars[I] = OldValue[1] then + begin + if OldLen > 1 then + if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then + Continue; + if Offset <> 0 then + begin + if FLength - OldLen + NewLen > MaxCurrency then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Offset then + begin + Capacity := Capacity * 5 div 3 + Offset; + SetLength(FChars, Capacity); + end; + if Offset < 0 then + MoveChar(FChars[I - Offset], FChars[I], FLength - I) + else + MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I); + Inc(FLength, Offset); + end; + if NewLen > 0 then + begin + if (OldLen = 1) and (NewLen = 1) then + FChars[I] := NewValue[1] + else + MoveChar(NewValue[1], FChars[I], NewLen); + end; + end; + end; + Result := Self; +end; + +function StrExpandTabs(S: string): string; +begin + // use an empty tab set, which will default to a tab width of 2 + Result := TJclTabSet(nil).Expand(s); +end; + +function StrExpandTabs(S: string; TabWidth: SizeInt): string; +var + TabSet: TJclTabSet; +begin + // create a tab set with no tab stops and the given tab width + TabSet := TJclTabSet.Create(TabWidth); + try + Result := TabSet.Expand(S); + finally + TabSet.Free; + end; +end; + +function StrExpandTabs(S: string; TabSet: TJclTabSet): string; +begin + // use the provided tab set to perform the expansion + Result := TabSet.Expand(S); +end; + +function StrOptimizeTabs(S: string): string; +begin + // use an empty tab set, which will default to a tab width of 2 + Result := TJclTabSet(nil).Optimize(s); +end; + +function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; +var + TabSet: TJclTabSet; +begin + // create a tab set with no tab stops and the given tab width + TabSet := TJclTabSet.Create(TabWidth); + try + Result := TabSet.Optimize(S); + finally + TabSet.Free; + end; +end; + +function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; +begin + // use the provided tab set to perform the optimization + Result := TabSet.Optimize(S); +end; + +// === { TTabSetData } =================================================== + +type + TTabSetData = class + public + FStops: TDynSizeIntArray; + FRealWidth: SizeInt; + FRefCount: SizeInt; + FWidth: SizeInt; + FZeroBased: Boolean; + constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); + + function Add(Column: SizeInt): SizeInt; + function AddRef: SizeInt; + procedure CalcRealWidth; + function FindStop(Column: SizeInt): SizeInt; + function ReleaseRef: SizeInt; + procedure RemoveAt(Index: SizeInt); + procedure SetStops(Index, Value: SizeInt); + end; + +constructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); +var + idx: SizeInt; +begin + inherited Create; + FRefCount := 1; + for idx := 0 to High(Tabstops) do + Add(Tabstops[idx]); + FWidth := TabWidth; + FZeroBased := ZeroBased; + CalcRealWidth; +end; + +function TTabSetData.Add(Column: SizeInt): SizeInt; +var + I: SizeInt; +begin + if Column < Ord(FZeroBased) then + raise ArgumentOutOfRangeException.Create('Column'); + Result := FindStop(Column); + if Result < 0 then + begin + // the column doesn't exist; invert the result of FindStop to get the correct index position + Result := not Result; + // increase the tab stop array + SetLength(FStops, Length(FStops) + 1); + // shift rooms after the insert position + for I := High(FStops) - 1 downto Result do + FStops[I + 1] := FStops[I]; + // add the tab stop at the correct location + FStops[Result] := Column; + CalcRealWidth; + end + else + begin + raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); + end; +end; + +function TTabSetData.AddRef: SizeInt; +begin + Result := LockedInc(FRefCount); +end; + +procedure TTabSetData.CalcRealWidth; +begin + if FWidth < 1 then + begin + if Length(FStops) > 1 then + FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))] + else + if Length(FStops) = 1 then + FRealWidth := FStops[0] + else + FRealWidth := 2; + end + else + FRealWidth := FWidth; +end; + +function TTabSetData.FindStop(Column: SizeInt): SizeInt; +begin + Result := High(FStops); + while (Result >= 0) and (FStops[Result] > Column) do + Dec(Result); + if (Result >= 0) and (FStops[Result] <> Column) then + Result := not Succ(Result); +end; + +function TTabSetData.ReleaseRef: SizeInt; +begin + Result := LockedDec(FRefCount); + if Result <= 0 then + Destroy; +end; + +procedure TTabSetData.RemoveAt(Index: SizeInt); +var + I: SizeInt; +begin + for I := Index to High(FStops) - 1 do + FStops[I] := FStops[I + 1]; + SetLength(FStops, High(FStops)); + CalcRealWidth; +end; + +procedure TTabSetData.SetStops(Index, Value: SizeInt); +var + temp: SizeInt; +begin + if (Index < 0) or (Index >= Length(FStops)) then + begin + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + end + else + begin + temp := FindStop(Value); + if temp < 0 then + begin + // remove existing tab stop... + RemoveAt(Index); + // now add the new tab stop + Add(Value); + end + else + if temp <> Index then + begin + // new tab stop already present at another index + raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); + end; + end; +end; + +//=== { TJclTabSet } ===================================================== + +constructor TJclTabSet.Create; +begin + // no tab stops, tab width set to auto + Create([], True, 0); +end; + +constructor TJclTabSet.Create(TabWidth: SizeInt); +begin + // no tab stops, specified tab width + Create([], True, TabWidth); +end; + +constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); +begin + // specified tab stops, tab width equal to distance between last two tab stops + Create(Tabstops, ZeroBased, 0); +end; + +constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); +begin + inherited Create; + FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth); +end; + +constructor TJclTabSet.Create(Data: TObject); +begin + inherited Create; + // add a reference to the data + TTabSetData(Data).AddRef; + // assign the data to this instance + FData := TTabSetData(Data); +end; + +destructor TJclTabSet.Destroy; +begin + // release the reference to the tab set data + TTabSetData(FData).ReleaseRef; + // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction + FData := nil; + // really destroy the instance + inherited Destroy; +end; + +function TJclTabSet.Add(Column: SizeInt): SizeInt; +begin + if Self = nil then + raise NullReferenceException.Create; + Result := TTabSetData(FData).Add(Column); +end; + +function TJclTabSet.Clone: TJclTabSet; +begin + if Self <> nil then + Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth) + else + Result := nil; +end; + +function TJclTabSet.Delete(Column: SizeInt): SizeInt; +begin + Result := TTabSetData(FData).FindStop(Column); + if Result >= 0 then + TTabSetData(FData).RemoveAt(Result); +end; + +function TJclTabSet.Expand(const S: string): string; +begin + Result := Expand(s, StartColumn); +end; + +function TJclTabSet.Expand(const S: string; Column: SizeInt): string; +var + sb: TJclStringBuilder; + head: PChar; + cur: PChar; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + sb := TJclStringBuilder.Create(Length(S)); + try + cur := PChar(S); + while cur^ <> #0 do + begin + head := cur; + while (cur^ <> #0) and (cur^ <> #9) do + begin + if CharIsReturn(cur^) then + Column := StartColumn + else + Inc(Column); + Inc(cur); + end; + if cur > head then + sb.Append(head, 0, cur - head); + if cur^ = #9 then + begin + sb.Append(' ', TabFrom(Column) - Column); + Column := TabFrom(Column); + Inc(cur); + end; + end; + Result := sb.ToString; + finally + sb.Free; + end; +end; + +function TJclTabSet.FindStop(Column: SizeInt): SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FindStop(Column) + else + Result := -1; +end; + +class function TJclTabSet.FromString(const S: string): TJclTabSet; +var + cur: PChar; + + function ParseNumber: Integer; + var + head: PChar; + begin + StrSkipChars(cur, CharIsWhiteSpace); + head := cur; + while CharIsDigit(cur^) do + Inc(cur); + Result := -1; + if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then + Result := -1; + end; + + procedure ParseStops; + var + openBracket, hadComma: Boolean; + num: SizeInt; + begin + StrSkipChars(cur, CharIsWhiteSpace); + openBracket := cur^ = '['; + hadComma := False; + if openBracket then + Inc(cur); + repeat + num := ParseNumber; + if (num < 0) and hadComma then + raise EJclStringError.CreateRes(@RsTabs_StopExpected) + else + if num >= 0 then + Result.Add(num); + StrSkipChars(cur, CharIsWhiteSpace); + hadComma := cur^ = ','; + if hadComma then + Inc(cur); + until (cur^ = #0) or (cur^ = '+') or (cur^ = ']'); + if hadComma then + raise EJclStringError.CreateRes(@RsTabs_StopExpected) + else + if openBracket and (cur^ <> ']') then + raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected); + end; + + procedure ParseTabWidth; + var + num: SizeInt; + begin + StrSkipChars(cur, CharIsWhiteSpace); + if cur^ = '+' then + begin + Inc(cur); + StrSkipChars(cur, CharIsWhiteSpace); + num := ParseNumber; + if (num < 0) then + raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected) + else + Result.TabWidth := num; + end; + end; + + procedure ParseZeroBasedFlag; + begin + StrSkipChars(cur, CharIsWhiteSpace); + if cur^ = '0' then + begin + Inc(cur); + if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then + begin + Result.ZeroBased := True; + StrSkipChars(cur, CharIsWhiteSpace); + end + else + Dec(cur); + end; + end; + +begin + Result := TJclTabSet.Create; + try + Result.ZeroBased := False; + cur := PChar(S); + ParseZeroBasedFlag; + ParseStops; + ParseTabWidth; + except + // clean up the partially complete instance (to avoid memory leaks)... + Result.Free; + // ... and re-raise the exception + raise; + end; +end; + +function TJclTabSet.GetCount: SizeInt; +begin + if Self <> nil then + Result := Length(TTabSetData(FData).FStops) + else + Result := 0; +end; + +function TJclTabSet.GetStops(Index: SizeInt): SizeInt; +begin + if Self <> nil then + begin + if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then + begin + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + end + else + Result := TTabSetData(FData).FStops[Index]; + end + else + begin + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + end; +end; + +function TJclTabSet.GetTabWidth: SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FWidth + else + Result := 0; +end; + +function TJclTabSet.GetZeroBased: Boolean; +begin + Result := (Self = nil) or TTabSetData(FData).FZeroBased; +end; + +procedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); +var + nextTab: SizeInt; +begin + if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state) + raise ArgumentOutOfRangeException.Create('StartColumn'); + if (TargetColumn < StartColumn) then // target lies before the starting column + raise ArgumentOutOfRangeException.Create('TargetColumn'); + TabsNeeded := 0; + repeat + nextTab := TabFrom(StartColumn); + if nextTab <= TargetColumn then + begin + Inc(TabsNeeded); + StartColumn := nextTab; + end; + until nextTab > TargetColumn; + SpacesNeeded := TargetColumn - StartColumn; +end; + +function TJclTabSet.Optimize(const S: string): string; +begin + Result := Optimize(S, StartColumn); +end; + +function TJclTabSet.Optimize(const S: string; Column: SizeInt): string; +var + sb: TJclStringBuilder; + head: PChar; + cur: PChar; + tgt: SizeInt; + + procedure AppendOptimalWhiteSpace(Target: SizeInt); + var + tabCount: SizeInt; + spaceCount: SizeInt; + begin + if cur > head then + begin + OptimalFillInfo(Column, Target, tabCount, spaceCount); + if tabCount > 0 then + sb.Append(#9, tabCount); + if spaceCount > 0 then + sb.Append(' ', spaceCount); + end; + end; + +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + sb := TJclStringBuilder.Create(Length(S)); + try + cur := PChar(s); + while cur^ <> #0 do + begin + // locate first whitespace character + head := cur; + while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do + Inc(cur); + // output non whitespace characters + if cur > head then + sb.Append(head, 0, cur - head); + // advance column + Inc(Column, cur - head); + // initialize target column indexer + tgt := Column; + // locate end of whitespace sequence + while CharIsWhiteSpace(cur^) do + begin + if CharIsReturn(cur^) then + begin + // append optimized whitespace sequence... + AppendOptimalWhiteSpace(tgt); + // ...set the column back to the start of the line... + Column := StartColumn; + // ...reset target column indexer... + tgt := Column; + // ...add the line break character... + sb.Append(cur^); + end + else + if cur^ = #9 then + tgt := TabFrom(tgt) // expand the tab + else + Inc(tgt); // a normal whitespace; taking up 1 column + Inc(cur); + end; + AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence... + Column := tgt; // ...and memorize the column for the next iteration + end; + Result := sb.ToString; // convert result to a string + finally + sb.Free; + end; +end; + +procedure TJclTabSet.RemoveAt(Index: SizeInt); +begin + if Self <> nil then + TTabSetData(FData).RemoveAt(Index) + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetStops(Index, Value: SizeInt); +begin + if Self <> nil then + TTabSetData(FData).SetStops(Index, Value) + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetTabWidth(Value: SizeInt); +begin + if Self <> nil then + begin + TTabSetData(FData).FWidth := Value; + TTabSetData(FData).CalcRealWidth; + end + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetZeroBased(Value: Boolean); +var + shift: SizeInt; + idx: SizeInt; +begin + if Self <> nil then + begin + if Value <> TTabSetData(FData).FZeroBased then + begin + TTabSetData(FData).FZeroBased := Value; + if Value then + shift := -1 + else + shift := 1; + for idx := 0 to High(TTabSetData(FData).FStops) do + TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift; + end; + end + else + raise NullReferenceException.Create; +end; + +function TJclTabSet.InternalTabStops: TDynSizeIntArray; +begin + if Self <> nil then + Result := TTabSetData(FData).FStops + else + Result := nil; +end; + +function TJclTabSet.InternalTabWidth: SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FRealWidth + else + Result := 2; +end; + +function TJclTabSet.NewReference: TJclTabSet; +begin + if Self <> nil then + Result := TJclTabSet.Create(FData) + else + Result := nil; +end; + +function TJclTabSet.StartColumn: SizeInt; +begin + if GetZeroBased then + Result := 0 + else + Result := 1; +end; + +function TJclTabSet.TabFrom(Column: SizeInt): SizeInt; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + Result := FindStop(Column); + if Result < 0 then + Result := not Result + else + Inc(Result); + if Result >= GetCount then + begin + if GetCount > 0 then + Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)] + else + Result := StartColumn; + while Result <= Column do + Inc(Result, ActualTabWidth); + end + else + Result := TTabSetData(FData).FStops[Result]; +end; + +function TJclTabSet.ToString: string; +begin + Result := ToString(TabSetFormatting_Full); +end; + +function TJclTabSet.ToString(FormattingOptions: SizeInt): string; +var + sb: TJclStringBuilder; + idx: SizeInt; + + function WantBrackets: Boolean; + begin + Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0; + end; + + function EmptyBrackets: Boolean; + begin + Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0; + end; + + function IncludeAutoWidth: Boolean; + begin + Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0; + end; + + function IncludeTabWidth: Boolean; + begin + Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0; + end; + + function IncludeStops: Boolean; + begin + Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0; + end; + +begin + sb := TJclStringBuilder.Create; + try + // output the fixed tabulation positions if requested... + if IncludeStops then + begin + // output each individual tabulation position + for idx := 0 to GetCount - 1 do + begin + sb.Append(TabStops[idx]); + sb.Append(','); + end; + // remove the final comma if any tabulation positions where outputted + if sb.Length <> 0 then + sb.Remove(sb.Length - 1, 1); + // bracket the tabulation positions if requested + if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then + begin + sb.Insert(0, '['); + sb.Append(']'); + end; + end; + // output the tab width if requested.... + if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then + begin + // separate the tab width from any outputted tabulation positions with a whitespace + if sb.Length > 0 then + sb.Append(' '); + // flag tab width + sb.Append('+'); + // finally, output the tab width + sb.Append(ActualTabWidth); + end; + // flag zero-based tabset by outputting a 0 (zero) as the first character. + if ZeroBased then + sb.Insert(0, string('0 ')); + Result := StrTrimCharRight(sb.ToString, ' '); + finally + sb.Free; + end; +end; + +function TJclTabSet.UpdatePosition(const S: string): SizeInt; +var + Line: SizeInt; +begin + Result := StartColumn; + Line := -1; + UpdatePosition(S, Result, Line); +end; + +function TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt; +var + Line: SizeInt; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + Result := Column; + Line := -1; + UpdatePosition(S, Result, Line); +end; + +function TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; +var + prevChar: Char; + cur: PChar; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + // initialize loop + cur := PChar(S); + // iterate until end of string (the Null-character) + while cur^ <> #0 do + begin + // check for line-breaking characters + if CharIsReturn(cur^) then + begin + // Column moves back all the way to the left + Column := StartColumn; + // If this is the first line-break character or the same line-break character, increment the Line parameter + Inc(Line); + // check if it's the first of a two-character line-break + prevChar := cur^; + Inc(cur); + // if it isn't a two-character line-break, undo the previous advancement + if (cur^ = prevChar) or not CharIsReturn(cur^) then + Dec(cur); + end + else // check for tab character and expand it + if cur^ = #9 then + Column := TabFrom(Column) + else // a normal character; increment column + Inc(Column); + // advance pointer + Inc(cur); + end; + // set the result to the newly calculated column + Result := Column; +end; + +//=== { NullReferenceException } ============================================= + +constructor NullReferenceException.Create; +begin + CreateRes(@RsArg_NullReferenceException); +end; + +function CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt; +var + Cur1, Len1, + Cur2, Len2: SizeInt; + + function IsRealNumberChar(ch: Char): Boolean; + begin + Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+'); + end; + + procedure NumberCompare; + var + IsReallyNumber: Boolean; + FirstDiffBreaks: Boolean; + Val1, Val2: SizeInt; + begin + Result := 0; + IsReallyNumber := False; + // count leading spaces in S1 + while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do + begin + Dec(Result); + Inc(Cur1); + end; + // count leading spaces in S2 (canceling them out against the ones in S1) + while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do + begin + Inc(Result); + Inc(Cur2); + end; + + // if spaces match, or both strings are actually followed by a numeric character, continue the checks + if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then + begin + // Check signed number + if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then + Result := 1 + else + if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then + Result := -1 + else + Result := 0; + + if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then + Inc(Cur1); + if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then + Inc(Cur2); + + FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0'); + while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do + begin + IsReallyNumber := True; + Val1 := StrToInt(S1[Cur1]); + Val2 := StrToInt(S2[Cur2]); + + if (Result = 0) and (Val1 < Val2) then + Result := -1 + else + if (Result = 0) and (Val1 > Val2) then + Result := 1; + if FirstDiffBreaks and (Result <> 0) then + Break; + Inc(Cur1); + Inc(Cur2); + end; + + if IsReallyNumber then + begin + if not FirstDiffBreaks then + begin + if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then + Result := 1 + else + if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then + Result := -1; + end; + end; + end; + end; + + procedure SetByCompareLength; + var + Remain1: SizeInt; + Remain2: SizeInt; + begin + // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be + // completely equal, or S2 could be longer) + Remain1 := Len1 - Cur1 + 1; + Remain2 := Len2 - Cur2 + 1; + if Remain1 < 0 then + Remain1 := 0; + if Remain2 < 0 then + Remain2 := 0; + + if Remain1 < Remain2 then + Result := -1 + else + if Remain1 > Remain2 then + Result := 1; + end; + +begin + Cur1 := 1; + Len1 := Length(S1); + Cur2 := 1; + Len2 := Length(S2); + Result := 0; + + while (Result = 0) do + begin + if (Cur1 > Len1) or (Cur2 > Len2) then + begin + SetByCompareLength; + Break; + end + else + if (Cur1 <= Len1) and (Cur2 > Len2) then + Result := 1 + else + if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then + Result := -1 + else + if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then + Result := 1 + else + if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then + NumberCompare + else + begin + if CaseInsensitive then + Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1) + else + Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1); + Inc(Cur1); + Inc(Cur2); + end; + end; +end; + +function CompareNaturalStr(const S1, S2: string): SizeInt; overload; +begin + Result := CompareNatural(S1, S2, False); +end; + +function CompareNaturalText(const S1, S2: string): SizeInt; overload; +begin + Result := CompareNatural(S1, S2, True); +end; + +initialization + {$IFNDEF UNICODE_RTL_DATABASE} + LoadCharTypes; // this table first + LoadCaseMap; // or this function does not work + {$ENDIF ~UNICODE_RTL_DATABASE} + {$IFDEF UNITVERSIONING} + RegisterUnitVersion(HInstance, UnitVersioning); + {$ENDIF UNITVERSIONING} + +{$IFDEF UNITVERSIONING} +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} + +end. + From 8cf6bf15dc85fd11b1b22256702e79190d6f88b0 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 13:43:17 +0400 Subject: [PATCH 04/12] JclStringBuilder should know about TObject.ToString --- jcl/source/common/JclStrings.pas | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index e2e511eecf..6a2ad1d590 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -414,6 +414,7 @@ ArgumentException = class(EJclError); ArgumentNullException = class(EJclError); ArgumentOutOfRangeException = class(EJclError); +// IFomattable in .Net: http://msdn.microsoft.com/en-us/library/system.string.format.aspx IToString = interface ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] function ToString: string; @@ -424,7 +425,7 @@ ArgumentOutOfRangeException = class(EJclError); // The TStringBuilder class is a Delphi implementation of the .NET // System.Text.StringBuilder. // It is zero based and the method that allow an TObject (Append, Insert, - // AppendFormat) are limited to IToString implementors. + // AppendFormat) are limited to IToString implementors or newer Delphi RTL. // This class is not threadsafe. Any instance of TStringBuilder should not // be used in different threads at the same time. TJclStringBuilder = class(TInterfacedObject, IToString) @@ -3985,7 +3986,11 @@ function DotNetFormat(const Fmt: string; const Args: array of const): string; if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then Result := Intf.ToString else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); +{$IFDEF RTL200_UP} + Result := V.VObject.ToString; +{$Else} + raise ArgumentNullException.CreateResFmt(V.VObject.ClassName + ': ' + @RsDotNetFormatArgumentNotSupported, [Index]); +{$EndIf} vtClass: Result := V.VClass.ClassName; vtWideChar: From 01daed225cdf449216ded8660a99a5712bf0f0f2 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 13:44:32 +0400 Subject: [PATCH 05/12] only use JclStringBuilder is stock one is missed --- jcl/source/common/JclStringLists.pas | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/jcl/source/common/JclStringLists.pas b/jcl/source/common/JclStringLists.pas index b47bf4526c..eb385f8b51 100644 --- a/jcl/source/common/JclStringLists.pas +++ b/jcl/source/common/JclStringLists.pas @@ -611,12 +611,13 @@ function TJclStringList.First: string; function TJclStringList.Join(const ASeparator: string): string; var I: Integer; - SB: TJclStringBuilder; + SB: TStringBuilder; // Implemented by JclStrings, if missed in RTL begin if Count <= 0 then Result := '' else begin - SB := TJclStringBuilder.Create(First); // Capacity: Sum([Strings]) + (Count-1) * [ASeparator] ? Worth it? + SB := TStringBuilder.Create(First); + // Warming up ? Worth it ? Capacity: Sum([Strings]) + (Count-1) * [ASeparator] ? try for I := 1 to LastIndex do SB.Append(ASeparator).Append(Strings[i]); From 932a6cc93c22070df8711beeab1b18a4797a560d Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 16:02:18 +0400 Subject: [PATCH 06/12] Making String Contains/Consists set function more consistent: * CharIsNumberChar should account for ThousandSeparators too, if accounts for DecimalSeparator Work on #5898 #5893 * StrIsDigit is awful Engrish * StrIsSubset is nothing but another name for StrConsistsOfChars * StrIsDigit is nothing but another name for StrConsistsOfChars with proper filters * StrConsistsOfNumberChars is nothing but another name for StrConsistsOfChars with proper filters * there are three kinds of checks: ** target only contains given chars ** target contains some of given chars ** target contains (among other) all the given chars One boolean value was ambiguous to separate those tasks. Now there are three distinct name schemes. * ToDO : make StrIsDigit and StrConsistsOfNumberChars permit empty strings ??? --- jcl/source/common/JclStrings.pas | 210 +++++++++++++++++++++++-------- 1 file changed, 158 insertions(+), 52 deletions(-) diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 6a2ad1d590..912fcb84c5 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -171,16 +171,30 @@ function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; // String Test Routines +// TODO: think of some choosen N, so that: If both string length and array length > N - then pre-sort the array +// and use optimized (binary search) CharInArray, if not - then use linear search as now. function StrIsAlpha(const S: string): Boolean; function StrIsAlphaNum(const S: string): Boolean; function StrIsAlphaNumUnderscore(const S: string): Boolean; -function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; -function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; function StrConsistsOfNumberChars(const S: string): Boolean; -function StrIsDigit(const S: string): Boolean; -function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; -function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; +function StrConsistsOfDigits(const S: string): Boolean; function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; +function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; deprecated 'Use StrConsistsOfChars'; +function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; deprecated 'Use StrConsistsOfChars'; + +function StrIsDigit(const S: string): Boolean; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfDigits'; +// mixing two very separate goals is confusing and using CharValidator can not be implemented at all +function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; +function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; + // String Transformation Routines function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; @@ -229,7 +243,7 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator): string function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; function StrStringToEscaped(const S: string): string; function StrStripNonNumberChars(const S: string): string; -function StrToHex(const Source: string): string; +function StrToHex(const Source: string): AnsiString; function StrTrimCharLeft(const S: string; C: Char): string; function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload; function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; @@ -854,21 +868,123 @@ function StrIsAlphaNum(const S: string): Boolean; end; end; -function StrConsistsofNumberChars(const S: string): Boolean; +function StrIsDigit(const S: string): Boolean; +begin + Result := StrConsistsOfDigits(S) +end; + +function StrConsistsOfDigits(const S: string): Boolean; +begin + Result := StrConsistsOfChars(S, CharIsDigit, False); +end; + +function StrConsistsOfNumberChars(const S: string): Boolean; +begin + Result := StrConsistsOfChars(S, CharIsNumberChar, False ); +end; + +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; +var + I: SizeInt; +begin + Result := False; + for I := 1 to Length(Chars) do + if CharPos(S, Chars[I]) <= 0 then exit; + Result := True; +end; + +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; +var + I: SizeInt; +begin + Result := False; + for I := Low(Chars) to High(Chars) do + if CharPos(S, Chars[I]) <= 0 then exit; + Result := True; +end; + +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; var I: SizeInt; begin - Result := S <> ''; for I := 1 to Length(S) do - begin - if not CharIsNumberChar(S[I]) then - begin - Result := False; - Exit; - end; + if Chars(S[I]) then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, S[I]) then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + if CharPos(Chars, S[I]) > 0 then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if not Chars(S[I]) then Exit; + Result := True; end; end; +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if not ArrayContainsChar(Chars, S[I]) then Exit; + Result := True; + end; +end; + +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if CharPos(Chars, S[I]) <= 0 then Exit; + Result := True; + end; +end; + + function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; var I: SizeInt; @@ -943,47 +1059,34 @@ function StrIsAlphaNumUnderscore(const S: string): Boolean; Result := Length(S) > 0; end; -function StrIsDigit(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsDigit(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; -var - I: SizeInt; +//var +// I: SizeInt; begin - for I := 1 to Length(S) do - begin - Result := ValidChars(S[I]); - if not Result then - Exit; - end; - - Result := Length(S) > 0; + Result := StrConsistsOfChars(S, ValidChars, False); +// for I := 1 to Length(S) do +// begin +// Result := ValidChars(S[I]); +// if not Result then +// Exit; +// end; +// +// Result := Length(S) > 0; end; function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; -var - I: SizeInt; +//var +// I: SizeInt; begin - for I := 1 to Length(S) do - begin - Result := ArrayContainsChar(ValidChars, S[I]); - if not Result then - Exit; - end; - - Result := Length(S) > 0; + Result := StrConsistsOfChars(S, ValidChars, False); +// for I := 1 to Length(S) do +// begin +// Result := ArrayContainsChar(ValidChars, S[I]); +// if not Result then +// Exit; +// end; +// +// Result := Length(S) > 0; end; function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; @@ -1831,7 +1934,7 @@ function StrStripNonNumberChars(const S: string): string; end; end; -function StrToHex(const Source: string): string; +function StrToHex(const Source: string): AnsiString; var Index: SizeInt; C, L, N: SizeInt; @@ -1864,7 +1967,7 @@ function StrToHex(const Source: string): string; Result := ''; Exit; end; - Result[N] := Char((BH shl 4) or BL); + Result[N] := AnsiChar((BH shl 4) or BL); Inc(N); end; end; @@ -2875,7 +2978,10 @@ function CharIsLower(const C: Char): Boolean; function CharIsNumberChar(const C: Char): Boolean; begin - Result := CharIsDigit(C) or (C = '+') or (C = '-') or (C = JclFormatSettings.DecimalSeparator); + Result := CharIsDigit(C) or (C = '+') or (C = '-') + or ((C <> #0) and (C = JclFormatSettings.DecimalSeparator)) + or ((C <> #0) and (C = JclFormatSettings.ThousandSeparator)); + // #0 is a special value to 'disable' xxxxSeparator, semantically similar to empty string end; function CharIsNumber(const C: Char): Boolean; From e0a67ef8bcf5c10553a8a83ac78690554b060546 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 16:49:39 +0400 Subject: [PATCH 07/12] #0006081 - crash because of dangling pointers and FreeAndNil --- jcl/source/common/JclStringLists.pas | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/jcl/source/common/JclStringLists.pas b/jcl/source/common/JclStringLists.pas index eb385f8b51..a6cccee949 100644 --- a/jcl/source/common/JclStringLists.pas +++ b/jcl/source/common/JclStringLists.pas @@ -695,8 +695,10 @@ function TJclStringList._Release: Integer; FSelfAsInterface := nil; end else - if Result = 0 then - Destroy; + if Result = 0 then begin + pointer(FSelfAsInterface) := nil; // should work in .create / FreeAndNil scenario + Destroy; + end; end; {$IFDEF JCL_PCRE} @@ -747,6 +749,10 @@ function TJclStringList.MatchRegEx(const S, APattern: string): Boolean; destructor TJclStringList.Destroy; begin + if (FRefCount = 1) and (FSelfAsInterface <> nil) then begin + pointer(FSelfAsInterface) := nil; + FRefCount := 0; // should work in .Create -> FreeAndNil scenario + end; if CanFreeObjects then FreeObjects(False); {$IFDEF JCL_PCRE} @@ -855,6 +861,7 @@ constructor TJclStringList.Create; inherited Create; if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then System.Error(reIntfCastError); + // InterlockedDecrement(FRefCount); // should work w/o dangling pointers - bug #6081 end; function TJclStringList.GetLists(Index: Integer): IJclStringList; From 2739a084ed26711a4e7c34fd3949635cfbcd38b5 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Tue, 12 Feb 2013 17:13:53 +0400 Subject: [PATCH 08/12] 1) XE2 cannot override on different float types, even in Win32 2) tests for JclStringLists, including Join via StringBuilder --- qa/automated/dunit/JclTests.dpr | 78 +- qa/automated/dunit/JclTests.res | Bin 1604 -> 2040 bytes qa/automated/dunit/units/TestJclMath.pas | 2452 +++---- qa/automated/dunit/units/TestJclStrings.pas | 7046 ++++++++++--------- 4 files changed, 5009 insertions(+), 4567 deletions(-) diff --git a/qa/automated/dunit/JclTests.dpr b/qa/automated/dunit/JclTests.dpr index b0c498d3f5..dfd9c3c007 100644 --- a/qa/automated/dunit/JclTests.dpr +++ b/qa/automated/dunit/JclTests.dpr @@ -1,39 +1,41 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ DUnit Test } -{ } -{ Last Update: $Date$ } -{ } -{ 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. } -{ } -{**************************************************************************************************} - -program JclTests; - -uses - Forms, - GUITestRunner, - TestJcl8087 in 'units\TestJcl8087.pas', - TestJclMath in 'units\TestJclMath.pas', - TestJclStrings in 'units\TestJclStrings.pas', - TestJclDateTime in 'units\TestJclDateTime.pas', - TestJclEDI in 'units\TestJclEDI.pas', - TestJclEDI_ANSIX12 in 'units\TestJclEDI_ANSIX12.pas', - TestJclContainer in 'units\TestJclContainer.pas', - TestJclNotify in 'units\TestJclNotify.pas', - TestJclDebug in 'units\TestJclDebug.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.Run; - GUITestRunner.RunRegisteredTests; +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test } +{ } +{ Last Update: $Date$ } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +program JclTests; + +uses + Forms, + GUITestRunner, + TestJcl8087 in 'units\TestJcl8087.pas', + TestJclMath in 'units\TestJclMath.pas', + TestJclStrings in 'units\TestJclStrings.pas', + TestJclDateTime in 'units\TestJclDateTime.pas', + TestJclContainer in 'units\TestJclContainer.pas', + TestJclNotify in 'units\TestJclNotify.pas', + TestJclDebug in 'units\TestJclDebug.pas', + JclMath in '..\..\..\jcl\source\common\JclMath.pas', + JclStringLists in '..\..\..\jcl\source\common\JclStringLists.pas', + JclStrings in '..\..\..\jcl\source\common\JclStrings.pas', + JclFileUtils in '..\..\..\jcl\source\common\JclFileUtils.pas'; + +{$R *.res} + +begin + Application.Initialize; + Application.Run; + GUITestRunner.RunRegisteredTests; end. \ No newline at end of file diff --git a/qa/automated/dunit/JclTests.res b/qa/automated/dunit/JclTests.res index c76f3a52784a2d717e30975cf47b9b5e14325e3c..e72554b4a0f0e0344d3800c9b68c52c0585342d5 100644 GIT binary patch delta 962 zcmZuw&2G~`5MJX1;R-}AR7eQ1EH|V$Nt*`R+O$!XqKHdEPGZLu9c#R^Gdq9Z?0&oX_x2}D_B4brLTEZ&1%?e!3mLVU z0KYvg`>2}+LUR+!zUzs_8G5f#@8ozbiK7|WXJmb^yjsrkh@nFV(nf;A)Zhn1I}#HHd_Q!=5jA! zBb&TFJ!m{7SSp8kPRJRxNkS#reRgZba-^iuFibE6VA3YBVB69?qmd&UQQ!(Lxv$cO z%cE^aM&_hVaOAMSr&7JCrh`}*TOJ)#=0WCUwy$VZZ;@zW08^2A01hfpNgiQNDj7qK z=Kb&2pG$L}M-gX@ea@8Np`5wQJxWBnW-I?Hrg1zB1NQ|@ zPWd|um~}U|Hiz9#yVG%9zwP;zqhac>QS6K$`QwUuEVxUh C3jcEe delta 519 zcmZ9Iu}Z^G6o&uXri6lG7R5!3EjT!oQVOD-)G8`P9mJtqw6#W)7}7dqs*hmE;OrAP zxby*h3s)b(!L9!HGy(O($-Ot{`_K9B`CfRRd$Q9oz~_izs%AshsV zal+k4U&@{#V(yl=D~#Cvn7THOBp0Ac?EzeP%(odsQW5VVS(my%IBE_>WJ{wSK^q+c zmxLWg%zFbh+Oly?S;SqJ^H}JHoK4GmHBe4I*2Y@|HLOFg3SB6A3fQ$zaloS9pH~3u z!gQD)NLIf%WMl1iz$PQ91Z@1{&Ph1XmVL2$hv7wr=J07&#LXJ#1JO3}G3F*` 0 then - CheckEquals(System.ArcTan(X), JclMath.ArcTan(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcTan2; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Cos; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(System.Cos(X), JclMath.Cos(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Cot; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Csc; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Sec; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Sin; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(System.Sin(X), JclMath.Sin(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._SinCos; -var - x, s, c: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - SinCos(x, s, c); - - CheckEquals(System.Sin(X), s, PrecisionTolerance); - CheckEquals(System.Cos(X), c, PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Tan; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(Math.Tan(X), JclMath.Tan(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - - -//================================================================================================== -// Hyperbolic -//================================================================================================== - - -//================================================================================================== -// Miscellaneous -//================================================================================================== - -procedure TMathMiscTest._Ackermann; -begin - CheckEquals(1, Ackermann(0,0)); - CheckEquals(7, Ackermann(2,2)); - CheckEquals(5, Ackermann(3,0)); - CheckEquals(61, Ackermann(3,3)); - CheckEquals(125, Ackermann(3,4)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Ceiling; -var - i: Integer; - e: Extended; - -begin - RandSeed := 12321; - for i := 1 to 2000 do - begin - e := random(100000) / (random(230000)+1); - CheckEquals(Math.Ceil(e), JclMath.Ceiling(e), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Factorial; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Fibonacci; -begin - CheckEquals(0, Fibonacci(0)); - CheckEquals(1, Fibonacci(1)); - CheckEquals(1, Fibonacci(2)); - CheckEquals(2, Fibonacci(3)); - CheckEquals(3, Fibonacci(4)); - CheckEquals(5, Fibonacci(5)); - CheckEquals(8, Fibonacci(6)); - CheckEquals(13, Fibonacci(7)); - CheckEquals(21, Fibonacci(8)); - CheckEquals(34, Fibonacci(9)); - CheckEquals(55, Fibonacci(10)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Floor; -var - i: Integer; - e: Extended; - -begin - RandSeed := 12321; - for i := 1 to 2000 do - begin - e := random(100000) / random(230000); - CheckEquals(Math.Floor(e), JclMath.Floor(e)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._GCD; -begin - CheckEquals(1, GCD(2,5), PrecisionTolerance); - CheckEquals(4, GCD(8,4), PrecisionTolerance); - CheckEquals(3, GCD(801,48), PrecisionTolerance); - CheckEquals(2 , GCD(80,98), PrecisionTolerance); - CheckEquals(0 , GCD(0,0), PrecisionTolerance); - CheckEquals(5 , GCD(100,5), PrecisionTolerance); - CheckEquals(50 , GCD(100,50), PrecisionTolerance); - CheckEquals(100, GCD(18700,700), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._ISqrt; -var - i,v : Integer; - -begin - for i := 1 to 10000 do - begin - v := ISqrt(i); - CheckEquals(integer(trunc(sqrt(i))),v); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._LCM; -begin - CheckEquals(0, LCM(0,0), PrecisionTolerance); - CheckEquals(300, LCM(100,150), PrecisionTolerance); - CheckEquals(600, LCM(200,150), PrecisionTolerance); - CheckEquals(400, LCM(400,50), PrecisionTolerance); - CheckEquals(10, LCM(10,10), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._NormalizeA; -begin - -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Pythagoras; -var - i: Integer; - a,b,c : Extended; - -begin - RandSeed := 86543; - - for i := 1 to 10000 do - begin - a := random(100000) / (random(20000)+1); - b := random(200000) / (random(24000)+1); - c := sqrt(a*a + b*b); - CheckEquals(c, Pythagoras(a,b), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Sgn; -var - i: Integer; - v: Integer; - -begin - RandSeed := 86543; - - for i := 1 to 10000 do - begin - v := random(MaxInt-1)+1; - CheckEquals(1, Sgn(v)); - CheckEquals(-1, Sgn(-v)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Signe; -begin -end; - - -//================================================================================================== -// Rational -//================================================================================================== - -procedure TMathRationalTest._Assign; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := 1; - - RN1.Assign(n, d); - CheckEquals(n, RN1.Numerator); - CheckEquals(d, RN1.Denominator); - - RN2.Assign(RN1); - CheckEquals(n, RN2.Numerator); - CheckEquals(d, RN2.Denominator); - end; - - RN1.AssignOne; - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.AssignZero; - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Add; -begin - RN2.AssignOne; - RN1.Assign(5,5); - RN1.Add(RN2); - - CheckEquals(2, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(-5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(-5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(-3,7); RN2.Add(RN1); - CheckEquals(-23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(6,9); RN2.Add(3); - CheckEquals(11, RN2.Numerator); - CheckEquals(3, RN2.Denominator); - - RN2.Assign(2,2); RN2.Add(0.25); - CheckEquals(5, RN2.Numerator); - CheckEquals(4, RN2.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsEqual; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - RN2.Assign(RN1); - CheckEquals(True, RN2.IsEqual(RN1)); - CheckEquals(True, RN2.IsEqual(n, d)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsOne; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - CheckEquals(False, RN1.IsOne); - end; - - RN1.Assign(1); - CheckEquals(True, RN1.IsOne); - - RN1.AssignOne; - CheckEquals(True, RN1.IsOne); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsZero; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - CheckEquals(False, RN1.IsZero); - end; - - RN1.Assign(0); - CheckEquals(True, RN1.IsZero); - - RN1.Assignzero; - CheckEquals(True, RN1.IsZero); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Subtract; -begin - RN2.AssignOne; - RN1.Assign(5,5); - RN1.Subtract(RN2); - - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(6,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(-23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(11, RN2.Numerator); - CheckEquals(7, RN2.Denominator); - - RN2.Assign(18,9); RN2.Subtract(19); - CheckEquals(-17, RN2.Numerator); - CheckEquals(1, RN2.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Multiply; -begin - RN2.AssignOne; RN1.Assign(5,5); RN1.Multiply(RN2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Multiply(RN1); - CheckEquals(6, RN2.Numerator); - CheckEquals(7, RN2.Denominator); - - RN2.Assign(1,9); RN1.Assign(3,7); RN2.Multiply(RN1); - CheckEquals(1, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.AssignZero; RN1.Assign(5,5); RN1.Multiply(RN2); - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Divide; -begin - RN2.AssignOne; RN1.Assign(5,5); RN1.Divide(RN2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Divide(RN1); - CheckEquals(14, RN2.Numerator); - CheckEquals(3, RN2.Denominator); - - RN2.Assign(1,9); RN1.Assign(3,7); RN2.Divide(RN1); - CheckEquals(7, RN2.Numerator); - CheckEquals(27, RN2.Denominator); - - RN1.Assign(5,5); RN1.Divide(2); - CheckEquals(1, RN1.Numerator); - CheckEquals(2, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Power; -begin - RN2.Assign(18,9); RN1.Assign(18,9); RN2.Power(RN1); - CheckEquals(4, RN2.Numerator); - CheckEquals(1, RN2.Denominator); - - RN1.Assign(5,5); RN1.Power(2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(7,5); RN1.Power(2); - CheckEquals(49, RN1.Numerator); - CheckEquals(25, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._AsFloat; -var - e: extended; - i: Integer; - -begin - RandSeed := 123; - for i := 1 to 2000 do - begin - e := random(10000) / (random(1000)+1); - RN1.AsFloat := e; CheckEquals(e, RN1.AsFloat, 0.05); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._AsString; -var - i, i1, i2: Integer; - -begin - RandSeed := 123; - for i := 1 to 2000 do - begin - i1 := random(10000)+1; - i2 := random(1000)+1; - Rn1.AsString := inttostr(i1) + ' / ' + inttostr(i2); - RN2.Assign(i1,i2); - CheckEquals(True, RN2.IsEqual(RN1)); - end; - - Rn1.AsString := '6 / 2';; - CheckEquals(3, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Sqr; -begin - RN1.Assign(5,5); RN1.Sqr; - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(18,9); RN1.Sqr; - CheckEquals(4, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(1,5); RN1.Sqr; - CheckEquals(1, RN1.Numerator); - CheckEquals(25, RN1.Denominator); - - RN1.Assign(3,5); RN1.Sqr; - CheckEquals(9, RN1.Numerator); - CheckEquals(25, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Sqrt; -begin - RN1.Assign(0,1); RN1.Sqrt; - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(144,9); RN1.Sqrt; - CheckEquals(4, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest.SetUp; -begin - RN1 := TJclRational.Create; - RN2 := TJclRational.Create; - RN3 := TJclRational.Create; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest.TearDown; -begin - FreeAndNil(RN1); - FreeAndNil(RN2); - FreeAndNil(RN3); -end; - -//================================================================================================== -// Exponential -//================================================================================================== - -procedure TMathExponentialTest._Exp; -var - i: Integer; - e: extended; - -begin - RandSeed := 73162; - - for i := 1 to 100 do - begin - e := Random(1000) / (Random(1000) + 1); - CheckEquals(System.exp(e),JclMath.exp(e), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._Power; -var - Base, Exponent: extended; - i: Integer; - -begin - RandSeed := 73162; - - for i := 1 to 100 do - begin - Base := Random(10); - Exponent := Random(10); - - CheckEquals(Math.Power(Base, Exponent),JclMath.Power(Base, Exponent), PrecisionTolerance); - end; - -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._PowerInt; -begin - CheckEquals(1, PowerInt(0,0), PrecisionTolerance); - CheckEquals(4, PowerInt(2,2), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._TenToY; -begin - CheckEquals(1,JclMath.TenToY(0), PrecisionTolerance); - CheckEquals(10,JclMath.TenToY(1), PrecisionTolerance); - CheckEquals(100,JclMath.TenToY(2), PrecisionTolerance); - CheckEquals(1000,JclMath.TenToY(3), PrecisionTolerance); - CheckEquals(0.1,JclMath.TenToY(-1), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._TwoToY; -begin - CheckEquals(1,JclMath.TwoToY(0), PrecisionTolerance); - CheckEquals(2,JclMath.TwoToY(1), PrecisionTolerance); - CheckEquals(4,JclMath.TwoToY(2), PrecisionTolerance); - CheckEquals(8,JclMath.TwoToY(3), PrecisionTolerance); -end; - -//================================================================================================== -// FlatSet -//================================================================================================== - -procedure TMathASetTest._Invert; -begin - TSetCrack(ASet).SetBit(1, True); - TSetCrack(ASet).SetBit(2, False); - TSetCrack(ASet).Invert; - CheckEquals(False, TSetCrack(ASet).GetBit(1)); - CheckEquals(True, TSetCrack(ASet).GetBit(2)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest._SetGet; -var - i,t : Integer; - -begin - for i := 0 to 1000 do - begin - TSetCrack(ASet).SetBit(i, True); - CheckEquals(True, TSetCrack(ASet).GetBit(i)); - TSetCrack(ASet).SetBit(i, False); - CheckEquals(False, TSetCrack(ASet).GetBit(i)); - end; - - for i := 0 to 20 do - begin - TSetCrack(ASet).SetBit(i, True); - - for t := 0 to i do - CheckEquals(True, TSetCrack(ASet).GetBit(t)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest._SetGetRange; -var - i: Integer; - b: Boolean; - -begin - TSetCrack(ASet).SetRange(0, 100, True); - - for i := 0 to 100 do - CheckEquals(True, TSetCrack(ASet).GetBit(i)); - - B := TSetCrack(ASet).GetRange(0, 100, True); - CheckEquals(True, B); - - TSetCrack(ASet).SetRange(50, 101, False); - - for i := 50 to 101 do - CheckEquals(False, TSetCrack(ASet).GetBit(i)); - - B := TSetCrack(ASet).GetRange(50, 101, False); - CheckEquals(True, B); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathFlatSetTest.SetUp; -begin - ASet := TJclFlatSet.Create; - TSetCrack(ASet).SetBit(1, True); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest.TearDown; -begin - ASet.Free; -end; - -//================================================================================================== -// Prime numbers -//================================================================================================== - -procedure TMathPrimeTest._IsPrime; - - function GetFactor(N: Longint): Longint; { from a usenet post - completely tested } - var - I,M,Act: Word; - begin - if N<=0 then - RunError(215); { Arithmetic Overflow if zero or below } - if Lo(N) and 1=0 then begin { can be divided by 2? } - GetFactor:=2; - Exit; - end; - if N mod 3=0 then begin { can be divided by 3? } - GetFactor:=3; - Exit; - end; - Act:=5; { next number to be tested } - I:=2; { next increment of the test number } - M:=Trunc(Sqrt(N)); - while (Act<=M) and (N mod Act>0) do begin { test for division } - Inc(Act,I); - I:=6-I; { alternate I between 2 and 4 } - end; - if Act > M then { factor found? } - GetFactor := N { no } - else - GetFactor:=Act; { yes } - end; - - function IsPrimeAlternative(N: Longint): Boolean; - begin - Result :=(N>1) and (GetFactor(N)=N); - end; - -var - i: Integer; - tm: TPrimalityTestMethod; - -begin - for tm := Low(TPrimalityTestMethod) to High(TPrimalityTestMethod) do - begin - SetPrimalityTest(TPrimalityTestMethod(tm)); - - CheckEquals(False, IsPrime(0)); - CheckEquals(False, IsPrime(1)); - CheckEquals(True, IsPrime(2)); - - for i := 1 to 4000 do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - - for i := MaxInt - 4000 to MaxInt do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - - for i := (MaxInt div 2) - 2000 to (MaxInt div 2) + 2000 do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathPrimeTest._IsRelativePrime; -begin - CheckEquals(True, IsRelativePrime(1,4)); - CheckEquals(True, IsRelativePrime(3,4)); - CheckEquals(True, IsRelativePrime(13,19)); - CheckEquals(True, IsRelativePrime(17,99)); - CheckEquals(False, IsRelativePrime(0,4)); - CheckEquals(False, IsRelativePrime(2,4)); -end; - -//================================================================================================== -// NaN and Inf support -//================================================================================================== - -procedure TMathInfNanSupportTest._IsInfinite; -begin - s := Infinity; - d := JclMath.Infinity; - e := Infinity; - CheckEquals(True, IsInfinite(s)); - CheckEquals(True, IsInfinite(d)); - CheckEquals(True, IsInfinite(e)); - - s := 0; - d := 0; - e := 0; - CheckEquals(False, IsInfinite(s)); - CheckEquals(False, IsInfinite(d)); - CheckEquals(False, IsInfinite(e)); - - s := NaN; - d := NaN; - e := NaN; - CheckEquals(False, IsInfinite(s)); - CheckEquals(False, IsInfinite(d)); - CheckEquals(False, IsInfinite(e)); - - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - CheckEquals(True, IsInfinite(s)); - CheckEquals(True, IsInfinite(d)); - CheckEquals(True, IsInfinite(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._IsNaN; -begin - s := Infinity; - d := JclMath.Infinity; - e := Infinity; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); - - s := 0; - d := 0; - e := 0; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); - - s := NaN; - d := NaN; - e := NaN; - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._IsSpecialValue; -begin - s := Infinity; - d := JclMath.Infinity; - e := Infinity; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); - - s := 0; - d := 0; - e := 0; - CheckEquals(False, IsSpecialValue(s)); - CheckEquals(False, IsSpecialValue(d)); - CheckEquals(False, IsSpecialValue(e)); - - s := NaN; - d := NaN; - e := NaN; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); - - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._MakeQuietNaN; -begin - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - - MakeQuietNaN(s, 0); - MakeQuietNaN(d, 0); - MakeQuietNaN(e, 0); - - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - MakeQuietNaN(s, 1); - MakeQuietNaN(d, 2); - MakeQuietNaN(e, 3); - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._GetNaNTag; -var - i: Integer; - -begin - for i := 1 to 8000 do - begin - MakeQuietNaN(s, i); - MakeQuietNaN(d, i); - MakeQuietNaN(e, i); - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - CheckEquals(i, GetNaNTag(s)); - CheckEquals(i, GetNaNTag(d)); - CheckEquals(i, GetNaNTag(e)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -initialization - RegisterTest('JCLMath', TMathLogarithmicTest.Suite); - RegisterTest('JCLMath', TMathTranscendentalTest.Suite); - RegisterTest('JCLMath', TMathMiscTest.Suite); - RegisterTest('JCLMath', TMathRationalTest.Suite); - RegisterTest('JCLMath', TMathExponentialTest.Suite); - RegisterTest('JCLMath', TMathFlatSetTest.Suite); - RegisterTest('JCLMath', TMathPrimeTest.Suite); - RegisterTest('JCLMath', TMathInfNanSupportTest.Suite); -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test } +{ } +{ Last Update: 19-Jan-2002 } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +unit TestJclMath; + +interface +uses + TestFramework, +{$IFDEF MSWINDOWS} + Windows, +{$ENDIF MSWINDOWS} +{$IFDEF VCL} + Dialogs, +{$ENDIF VCL} + Classes, + SysUtils, + Math, + JclMath; + +{ TMathLogarithmicTest } + +type + TMathLogarithmicTest = class (TTestCase) + published + procedure _LogBase10; + procedure _LogBase2; + procedure _LogBaseN; + end; + +type + TMathTranscendentalTest = class (TTestCase) + published + procedure _ArcCos; + procedure _ArcCot; + procedure _ArcCsc; + procedure _ArcSec; + procedure _ArcSin; + procedure _ArcTan; + procedure _ArcTan2; + procedure _Cos; + procedure _Cot; + procedure _Csc; + procedure _Sec; + procedure _Sin; + procedure _SinCos; + procedure _Tan; + end; + +type + TMathMiscTest = class (TTestCase) + published + procedure _Ackermann; + procedure _Ceiling; + procedure _Factorial; + procedure _Fibonacci; + procedure _Floor; + procedure _GCD; + procedure _ISqrt; + procedure _LCM; + procedure _NormalizeA; + procedure _Pythagoras; + procedure _Sgn; + procedure _Signe; + end; + +type + TMathRationalTest = class(TTestCase) + private + RN1: TJclRational; + RN2: TJclRational; + RN3: TJclRational; + protected + procedure SetUp; override; + procedure TearDown; override; + + published + procedure _Assign; + procedure _Add; + procedure _IsEqual; + procedure _IsZero; + procedure _IsOne; + procedure _Subtract; + procedure _Multiply; + procedure _Divide; + procedure _Power; + procedure _AsFloat; + procedure _AsString; + procedure _Sqr; + procedure _Sqrt; + end; + +type + TMathExponentialTest = class(TTestCase) + published + procedure _Exp; + procedure _Power; + procedure _PowerInt; + procedure _TenToY; + procedure _TwoToY; + end; + +type + TMathPrimeTest = class(TTestCase) + published + procedure _IsPrime; + procedure _IsRelativePrime; + end; + +type + TMathInfNanSupportTest = class(TTestCase) + private + s: single; + d: Double; + e: Extended; + + published + procedure _IsInfinite; + procedure _IsNaN; + procedure _IsSpecialValue; + procedure _MakeQuietNaN; + procedure _GetNaNTag; + end; + +type + TSetCrack = class(TJclASet); + +type + TMathASetTest = class(TTestCase) + protected + ASet: TJclASet; + procedure TearDown; override; + + published + procedure _Invert; + procedure _SetGet; + procedure _SetGetRange; + end; + + TMathFlatSetTest = class(TMathASetTest) + protected + procedure SetUp; override; + end; + +implementation + +//================================================================================================== +// Logarithmic +//================================================================================================== + +procedure TMathLogarithmicTest._LogBase10; +var + x: Extended; + +begin + x := 0.1; + while x < 100 do + begin + CheckEquals(Log10(x), LogBase10(x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathLogarithmicTest._LogBase2; +var + x: Extended; + +begin + x := 0.1; + while x < 100 do + begin + CheckEquals(Math.Log2(x), LogBase2(x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathLogarithmicTest._LogBaseN; +var + x: Extended; + Base: Integer; + +begin + x := 0.1; + for Base := 2 to 60 do + while x < 100 do + begin + CheckEquals(Math.LogN(Base, x), LogBaseN(Base, x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//================================================================================================== +// Transcendental +//================================================================================================== + +procedure TMathTranscendentalTest._ArcCos; +var + x: Extended; + +begin + x := -0.98; + + while x < 1 do + begin + CheckEquals(Math.ArcCos(X), JclMath.ArcCos(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcCot; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcCsc; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcSec; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcSin; +var + x: Extended; + +begin + x := -0.98; + + while x < 1 do + begin + CheckEquals(Math.ArcSin(X), JclMath.ArcSin(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcTan; +var + x: Extended; + +begin + x := -Pi; + + while x < Pi do + begin + if x <> 0 then + CheckEquals(System.ArcTan(X), JclMath.ArcTan(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcTan2; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Cos; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(System.Cos(X), JclMath.Cos(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Cot; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Csc; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Sec; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Sin; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(System.Sin(X), JclMath.Sin(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._SinCos; +var + x, s, c: Extended; + +begin +// x := -Pi; +// +// while x <= Pi do +// begin +// SinCos(x, s, c); +// +// CheckEquals(System.Sin(X), s, PrecisionTolerance); +// CheckEquals(System.Cos(X), c, PrecisionTolerance); +// x := x + 0.1; +// end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Tan; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(Math.Tan(X), JclMath.Tan(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + + +//================================================================================================== +// Hyperbolic +//================================================================================================== + + +//================================================================================================== +// Miscellaneous +//================================================================================================== + +procedure TMathMiscTest._Ackermann; +begin + CheckEquals(1, Ackermann(0,0)); + CheckEquals(7, Ackermann(2,2)); + CheckEquals(5, Ackermann(3,0)); + CheckEquals(61, Ackermann(3,3)); + CheckEquals(125, Ackermann(3,4)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Ceiling; +var + i: Integer; + e: Extended; + +begin + RandSeed := 12321; + for i := 1 to 2000 do + begin + e := random(100000) / (random(230000)+1); + CheckEquals(Math.Ceil(e), JclMath.Ceiling(e), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Factorial; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Fibonacci; +begin + CheckEquals(0, Fibonacci(0)); + CheckEquals(1, Fibonacci(1)); + CheckEquals(1, Fibonacci(2)); + CheckEquals(2, Fibonacci(3)); + CheckEquals(3, Fibonacci(4)); + CheckEquals(5, Fibonacci(5)); + CheckEquals(8, Fibonacci(6)); + CheckEquals(13, Fibonacci(7)); + CheckEquals(21, Fibonacci(8)); + CheckEquals(34, Fibonacci(9)); + CheckEquals(55, Fibonacci(10)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Floor; +var + i: Integer; + e: Extended; + +begin + RandSeed := 12321; + for i := 1 to 2000 do + begin + e := random(100000) / random(230000); + CheckEquals(Math.Floor(e), JclMath.Floor(e)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._GCD; +begin + CheckEquals(1, GCD(2,5), PrecisionTolerance); + CheckEquals(4, GCD(8,4), PrecisionTolerance); + CheckEquals(3, GCD(801,48), PrecisionTolerance); + CheckEquals(2 , GCD(80,98), PrecisionTolerance); + CheckEquals(0 , GCD(0,0), PrecisionTolerance); + CheckEquals(5 , GCD(100,5), PrecisionTolerance); + CheckEquals(50 , GCD(100,50), PrecisionTolerance); + CheckEquals(100, GCD(18700,700), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._ISqrt; +var + i,v : Integer; + +begin + for i := 1 to 10000 do + begin + v := ISqrt(i); + CheckEquals(integer(trunc(sqrt(i))),v); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._LCM; +begin + CheckEquals(0, LCM(0,0), PrecisionTolerance); + CheckEquals(300, LCM(100,150), PrecisionTolerance); + CheckEquals(600, LCM(200,150), PrecisionTolerance); + CheckEquals(400, LCM(400,50), PrecisionTolerance); + CheckEquals(10, LCM(10,10), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._NormalizeA; +begin + +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Pythagoras; +var + i: Integer; + a,b,c : Extended; + +begin + RandSeed := 86543; + + for i := 1 to 10000 do + begin + a := random(100000) / (random(20000)+1); + b := random(200000) / (random(24000)+1); + c := sqrt(a*a + b*b); + CheckEquals(c, Pythagoras(a,b), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Sgn; +var + i: Integer; + v: Integer; + +begin + RandSeed := 86543; + + for i := 1 to 10000 do + begin + v := random(MaxInt-1)+1; + CheckEquals(1, Sgn(v)); + CheckEquals(-1, Sgn(-v)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Signe; +begin +end; + + +//================================================================================================== +// Rational +//================================================================================================== + +procedure TMathRationalTest._Assign; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := 1; + + RN1.Assign(n, d); + CheckEquals(n, RN1.Numerator); + CheckEquals(d, RN1.Denominator); + + RN2.Assign(RN1); + CheckEquals(n, RN2.Numerator); + CheckEquals(d, RN2.Denominator); + end; + + RN1.AssignOne; + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.AssignZero; + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Add; +begin + RN2.AssignOne; + RN1.Assign(5,5); + RN1.Add(RN2); + + CheckEquals(2, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(-5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(-5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(-3,7); RN2.Add(RN1); + CheckEquals(-23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(6,9); RN2.Add(3); + CheckEquals(11, RN2.Numerator); + CheckEquals(3, RN2.Denominator); + + RN2.Assign(2,2); RN2.Add(0.25); + CheckEquals(5, RN2.Numerator); + CheckEquals(4, RN2.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsEqual; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + RN2.Assign(RN1); + CheckEquals(True, RN2.IsEqual(RN1)); + CheckEquals(True, RN2.IsEqual(n, d)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsOne; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + CheckEquals(False, RN1.IsOne); + end; + + RN1.Assign(1); + CheckEquals(True, RN1.IsOne); + + RN1.AssignOne; + CheckEquals(True, RN1.IsOne); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsZero; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + CheckEquals(False, RN1.IsZero); + end; + + RN1.Assign(0); + CheckEquals(True, RN1.IsZero); + + RN1.Assignzero; + CheckEquals(True, RN1.IsZero); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Subtract; +begin + RN2.AssignOne; + RN1.Assign(5,5); + RN1.Subtract(RN2); + + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(6,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(-23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(11, RN2.Numerator); + CheckEquals(7, RN2.Denominator); + + RN2.Assign(18,9); RN2.Subtract(19); + CheckEquals(-17, RN2.Numerator); + CheckEquals(1, RN2.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Multiply; +begin + RN2.AssignOne; RN1.Assign(5,5); RN1.Multiply(RN2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Multiply(RN1); + CheckEquals(6, RN2.Numerator); + CheckEquals(7, RN2.Denominator); + + RN2.Assign(1,9); RN1.Assign(3,7); RN2.Multiply(RN1); + CheckEquals(1, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.AssignZero; RN1.Assign(5,5); RN1.Multiply(RN2); + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Divide; +begin + RN2.AssignOne; RN1.Assign(5,5); RN1.Divide(RN2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Divide(RN1); + CheckEquals(14, RN2.Numerator); + CheckEquals(3, RN2.Denominator); + + RN2.Assign(1,9); RN1.Assign(3,7); RN2.Divide(RN1); + CheckEquals(7, RN2.Numerator); + CheckEquals(27, RN2.Denominator); + + RN1.Assign(5,5); RN1.Divide(2); + CheckEquals(1, RN1.Numerator); + CheckEquals(2, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Power; +begin + RN2.Assign(18,9); RN1.Assign(18,9); RN2.Power(RN1); + CheckEquals(4, RN2.Numerator); + CheckEquals(1, RN2.Denominator); + + RN1.Assign(5,5); RN1.Power(2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(7,5); RN1.Power(2); + CheckEquals(49, RN1.Numerator); + CheckEquals(25, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._AsFloat; +var + e: extended; + i: Integer; + +begin + RandSeed := 123; + for i := 1 to 2000 do + begin + e := random(10000) / (random(1000)+1); + RN1.AsFloat := e; CheckEquals(e, RN1.AsFloat, 0.05); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._AsString; +var + i, i1, i2: Integer; + +begin + RandSeed := 123; + for i := 1 to 2000 do + begin + i1 := random(10000)+1; + i2 := random(1000)+1; + Rn1.AsString := inttostr(i1) + ' / ' + inttostr(i2); + RN2.Assign(i1,i2); + CheckEquals(True, RN2.IsEqual(RN1)); + end; + + Rn1.AsString := '6 / 2';; + CheckEquals(3, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Sqr; +begin + RN1.Assign(5,5); RN1.Sqr; + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(18,9); RN1.Sqr; + CheckEquals(4, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(1,5); RN1.Sqr; + CheckEquals(1, RN1.Numerator); + CheckEquals(25, RN1.Denominator); + + RN1.Assign(3,5); RN1.Sqr; + CheckEquals(9, RN1.Numerator); + CheckEquals(25, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Sqrt; +begin + RN1.Assign(0,1); RN1.Sqrt; + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(144,9); RN1.Sqrt; + CheckEquals(4, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest.SetUp; +begin + RN1 := TJclRational.Create; + RN2 := TJclRational.Create; + RN3 := TJclRational.Create; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest.TearDown; +begin + FreeAndNil(RN1); + FreeAndNil(RN2); + FreeAndNil(RN3); +end; + +//================================================================================================== +// Exponential +//================================================================================================== + +procedure TMathExponentialTest._Exp; +var + i: Integer; + e: extended; + +begin + RandSeed := 73162; + + for i := 1 to 100 do + begin + e := Random(1000) / (Random(1000) + 1); + CheckEquals(System.exp(e),JclMath.exp(e), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._Power; +var + Base, Exponent: extended; + i: Integer; + +begin + RandSeed := 73162; + + for i := 1 to 100 do + begin + Base := Random(10); + Exponent := Random(10); + + CheckEquals(Math.Power(Base, Exponent),JclMath.Power(Base, Exponent), PrecisionTolerance); + end; + +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._PowerInt; +begin + CheckEquals(1, PowerInt(0,0), PrecisionTolerance); + CheckEquals(4, PowerInt(2,2), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._TenToY; +begin + CheckEquals(1,JclMath.TenToY(0), PrecisionTolerance); + CheckEquals(10,JclMath.TenToY(1), PrecisionTolerance); + CheckEquals(100,JclMath.TenToY(2), PrecisionTolerance); + CheckEquals(1000,JclMath.TenToY(3), PrecisionTolerance); + CheckEquals(0.1,JclMath.TenToY(-1), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._TwoToY; +begin + CheckEquals(1,JclMath.TwoToY(0), PrecisionTolerance); + CheckEquals(2,JclMath.TwoToY(1), PrecisionTolerance); + CheckEquals(4,JclMath.TwoToY(2), PrecisionTolerance); + CheckEquals(8,JclMath.TwoToY(3), PrecisionTolerance); +end; + +//================================================================================================== +// FlatSet +//================================================================================================== + +procedure TMathASetTest._Invert; +begin + TSetCrack(ASet).SetBit(1, True); + TSetCrack(ASet).SetBit(2, False); + TSetCrack(ASet).Invert; + CheckEquals(False, TSetCrack(ASet).GetBit(1)); + CheckEquals(True, TSetCrack(ASet).GetBit(2)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest._SetGet; +var + i,t : Integer; + +begin + for i := 0 to 1000 do + begin + TSetCrack(ASet).SetBit(i, True); + CheckEquals(True, TSetCrack(ASet).GetBit(i)); + TSetCrack(ASet).SetBit(i, False); + CheckEquals(False, TSetCrack(ASet).GetBit(i)); + end; + + for i := 0 to 20 do + begin + TSetCrack(ASet).SetBit(i, True); + + for t := 0 to i do + CheckEquals(True, TSetCrack(ASet).GetBit(t)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest._SetGetRange; +var + i: Integer; + b: Boolean; + +begin + TSetCrack(ASet).SetRange(0, 100, True); + + for i := 0 to 100 do + CheckEquals(True, TSetCrack(ASet).GetBit(i)); + + B := TSetCrack(ASet).GetRange(0, 100, True); + CheckEquals(True, B); + + TSetCrack(ASet).SetRange(50, 101, False); + + for i := 50 to 101 do + CheckEquals(False, TSetCrack(ASet).GetBit(i)); + + B := TSetCrack(ASet).GetRange(50, 101, False); + CheckEquals(True, B); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathFlatSetTest.SetUp; +begin + ASet := TJclFlatSet.Create; + TSetCrack(ASet).SetBit(1, True); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest.TearDown; +begin + ASet.Free; +end; + +//================================================================================================== +// Prime numbers +//================================================================================================== + +procedure TMathPrimeTest._IsPrime; + + function GetFactor(N: Longint): Longint; { from a usenet post - completely tested } + var + I,M,Act: Word; + begin + if N<=0 then + RunError(215); { Arithmetic Overflow if zero or below } + if Lo(N) and 1=0 then begin { can be divided by 2? } + GetFactor:=2; + Exit; + end; + if N mod 3=0 then begin { can be divided by 3? } + GetFactor:=3; + Exit; + end; + Act:=5; { next number to be tested } + I:=2; { next increment of the test number } + M:=Trunc(Sqrt(N)); + while (Act<=M) and (N mod Act>0) do begin { test for division } + Inc(Act,I); + I:=6-I; { alternate I between 2 and 4 } + end; + if Act > M then { factor found? } + GetFactor := N { no } + else + GetFactor:=Act; { yes } + end; + + function IsPrimeAlternative(N: Longint): Boolean; + begin + Result :=(N>1) and (GetFactor(N)=N); + end; + +var + i: Integer; + tm: TPrimalityTestMethod; + +begin + for tm := Low(TPrimalityTestMethod) to High(TPrimalityTestMethod) do + begin + SetPrimalityTest(TPrimalityTestMethod(tm)); + + CheckEquals(False, IsPrime(0)); + CheckEquals(False, IsPrime(1)); + CheckEquals(True, IsPrime(2)); + + for i := 1 to 4000 do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + + for i := MaxInt - 4000 to MaxInt do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + + for i := (MaxInt div 2) - 2000 to (MaxInt div 2) + 2000 do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathPrimeTest._IsRelativePrime; +begin + CheckEquals(True, IsRelativePrime(1,4)); + CheckEquals(True, IsRelativePrime(3,4)); + CheckEquals(True, IsRelativePrime(13,19)); + CheckEquals(True, IsRelativePrime(17,99)); + CheckEquals(False, IsRelativePrime(0,4)); + CheckEquals(False, IsRelativePrime(2,4)); +end; + +//================================================================================================== +// NaN and Inf support +//================================================================================================== + +procedure TMathInfNanSupportTest._IsInfinite; +begin +// s := Infinity; +// d := JclMath.Infinity; +// e := Infinity; +// CheckEquals(True, IsInfinite(s)); +// CheckEquals(True, IsInfinite(d)); +// CheckEquals(True, IsInfinite(e)); +// +// s := 0; +// d := 0; +// e := 0; +// CheckEquals(False, IsInfinite(s)); +// CheckEquals(False, IsInfinite(d)); +// CheckEquals(False, IsInfinite(e)); +// +// s := NaN; +// d := NaN; +// e := NaN; +// CheckEquals(False, IsInfinite(s)); +// CheckEquals(False, IsInfinite(d)); +// CheckEquals(False, IsInfinite(e)); +// +// s := NegInfinity; +// d := NegInfinity; +// e := NegInfinity; +// CheckEquals(True, IsInfinite(s)); +// CheckEquals(True, IsInfinite(d)); +// CheckEquals(True, IsInfinite(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._IsNaN; +begin + s := Infinity; + d := JclMath.Infinity; + e := Infinity; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); + + s := 0; + d := 0; + e := 0; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); + + s := NaN; + d := NaN; + e := NaN; + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._IsSpecialValue; +begin + s := Infinity; + d := JclMath.Infinity; + e := Infinity; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); + + s := 0; + d := 0; + e := 0; + CheckEquals(False, IsSpecialValue(s)); + CheckEquals(False, IsSpecialValue(d)); + CheckEquals(False, IsSpecialValue(e)); + + s := NaN; + d := NaN; + e := NaN; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); + + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._MakeQuietNaN; +begin + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + + MakeQuietNaN(s, 0); + MakeQuietNaN(d, 0); + MakeQuietNaN(e, 0); + + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + MakeQuietNaN(s, 1); + MakeQuietNaN(d, 2); + MakeQuietNaN(e, 3); + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._GetNaNTag; +var + i: Integer; + +begin + for i := 1 to 8000 do + begin + MakeQuietNaN(s, i); + MakeQuietNaN(d, i); + MakeQuietNaN(e, i); + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + CheckEquals(i, GetNaNTag(s)); + CheckEquals(i, GetNaNTag(d)); + CheckEquals(i, GetNaNTag(e)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +initialization + RegisterTest('JCLMath', TMathLogarithmicTest.Suite); + RegisterTest('JCLMath', TMathTranscendentalTest.Suite); + RegisterTest('JCLMath', TMathMiscTest.Suite); + RegisterTest('JCLMath', TMathRationalTest.Suite); + RegisterTest('JCLMath', TMathExponentialTest.Suite); + RegisterTest('JCLMath', TMathFlatSetTest.Suite); + RegisterTest('JCLMath', TMathPrimeTest.Suite); + RegisterTest('JCLMath', TMathInfNanSupportTest.Suite); +end. diff --git a/qa/automated/dunit/units/TestJclStrings.pas b/qa/automated/dunit/units/TestJclStrings.pas index 1659ed4089..d748eb567c 100644 --- a/qa/automated/dunit/units/TestJclStrings.pas +++ b/qa/automated/dunit/units/TestJclStrings.pas @@ -1,3303 +1,3743 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ DUnit Test Unit } -{ } -{ Covers: JclStrings } -{ Last Update: $Date$ } -{ } -{ 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. } -{ } -{**************************************************************************************************} - -unit TestJclStrings; - -interface -uses - TestFramework, - {$IFDEF MSWINDOWS} - Windows, - {$ELSE} - Types, - {$ENDIF} - Classes, - SysUtils, - JclStrings; - -{ TJclStringCharacterTestRoutines } - -type - TJclStringCharacterTestRoutines = class(TTestCase) - private - published - procedure _CharEqualNoCase; - procedure _CharIsAlpha; - procedure _CharIsAlphaNum; - procedure _CharIsBlank; - procedure _CharIsControl; - procedure _CharIsDelete; - procedure _CharIsDigit; - procedure _CharIsNumberChar; - procedure _CharIsPrintable; - procedure _CharIsPunctuation; - procedure _CharIsReturn; - procedure _CharIsSpace; - procedure _CharIsWhiteSpace; - procedure _CharIsUpper; - procedure _CharIsLower; -end; - - -{ TJclStringTransformation } - -type - TJclStringTransformation = class (TTestCase) - private - StringArray : array[0..5000] of string; - StringArray2 : array[0..5000] of string; - - published - { String Transformation } - procedure _StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; - procedure _StrContainsChars; - procedure _StrSame; - procedure _StrIsDigit_StrConsistsOfNumberChars_StrIsSubset; - procedure _StrCenter; - procedure _StrCharPosLower; - procedure _StrCharPosUpper; - procedure _StrDoubleQuote; - procedure _StrEnsurePrefix; - procedure _StrEnsureSuffix; - procedure _StrEscapedToString_StrStringToEscaped; - procedure _StrLower_StrLowerInPlace_StrLowerBuff; - procedure _StrMove; - procedure _StrPadLeft; - procedure _StrPadRight; - procedure _StrProper_StrProperBuff; - procedure _StrQuote; - procedure _StrReplace; - procedure _StrReplaceChar; - procedure _StrReplaceChars; - procedure _StrReplacebutChars; - procedure _StrRemoveChars; - procedure _StrKeepChars; - procedure _StrRepeat; - procedure _StrRepeatLength; - procedure _StrReverse_StrReverseInPlace; - procedure _StrSingleQuote; - procedure _StrSmartCase; - procedure _StrStripNonNumberChars; - procedure _StrToHex; - procedure _StrTrimCharLeft; - procedure _StrTrimCharsLeft; - procedure _StrTrimCharRight; - procedure _StrTrimCharsRight; - procedure _StrTrimQuotes; - procedure _StrUpper_StrUpperInPlace_StrUpperBuff; - end; - - { TJclStringManagment } - - TJclStringManagment = class (TTestCase) - published - procedure StringManagement; - end; - - { TJclStringSearchandReplace } - - TJclStringSearchandReplace = class (TTestCase) - private - StringArray: array[0..5000] of string; - StringArray2: array[0..5000] of string; - ResultArray: array[0..5000] of Integer; - fillIdx: Integer; - procedure AddCheck(const s1, s2: string; const res: Integer); - function NormalizeCompareResult(res: Integer): Integer; - procedure TestCompare(idx: Integer; res: Integer; msgFmt: string); - published - procedure _CompareNaturalStr; - procedure _CompareNaturalText; - procedure _StrCharCount; - procedure _StrCharsCount; - procedure _StrStrCount; - procedure _StrCompare; - procedure _StrCompareRange; - procedure _StrFillChar; - procedure _StrFind; - procedure _StrHasPrefix; - procedure _StrIHasPrefix; - procedure _StrIndex; - procedure _StrILastPos; - procedure _StrIPos; - procedure _StrIPrefixIndex; - procedure _StrIsOneOf; - procedure _StrLastPos; - procedure _StrMatch; - procedure _StrNPos; - procedure _StrMatches; - procedure _StrNIPos; - procedure _StrPrefixIndex; - procedure _StrSearch; - end; - - { TJclStringExtraction } - - TJclStringExtraction = class (TTestCase) - published - procedure _StrAfter; - procedure _StrBefore; - procedure _StrBetween; - procedure _StrChopRight; - procedure _StrLeft; - procedure _StrMid; - procedure _StrRight; - procedure _StrRestOf; - end; - - { TJclStringTabSet } - TJclStringTabSet = class(TTestCase) - published - procedure _CalculatedTabWidth; - procedure _Clone; - procedure _Expand; - procedure _FromString; - procedure _NilSet; - procedure _OptimalFill; - procedure _Optimize; - procedure _Referencing; - procedure _TabFrom; - procedure _TabStopAdding; - procedure _TabStopDeleting; - procedure _TabStopModifying; - procedure _ToString; - procedure _UpdatePosition; - procedure _ZeroBased; -end; - - { TJclStringManagment } - - TAnsiStringListTest = class (TTestCase) - published - procedure _SetCommaTextCount; - procedure _GetCommaTextCount; - procedure _GetCommaTextSpacedCount; - procedure _SetCommaTextProperties; - procedure _SetCommaTextQuotedProperties; - procedure _SetCommaTextQuotedSpacedProperties; - procedure _GetCommaTextQuotedProperties; - procedure _SetCommaTextInnerQuotesProperties; - procedure _GetCommaTextInnerQuotesProperties; - procedure _SetDelimitedTextCommaDoubleQuoteFalse; - procedure _GetDelimitedTextCommaDoubleQuoteFalse; - procedure _SetDelimitedTextCommaDoubleQuoteTrue; - procedure _GetDelimitedTextCommaDoubleQuoteTrue; - procedure _SetDelimitedTextFunkyFalse; - procedure _GetDelimitedTextFunkyFalse; - end; - -implementation - -{$IFDEF LINUX} -uses - LibC; -{$ENDIF LINUX} -{$IFDEF WIN32} -const - LibC = 'msvcrt40.dll'; - -function isalnum(C: Integer): LongBool; cdecl; external LibC; -function isalpha(C: Integer): LongBool; cdecl; external LibC; -{$ENDIF WIN32} - -//----------------------------------------------------------------------------------------------- -// Generators -//----------------------------------------------------------------------------------------------- - -procedure GenerateAlpha(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 785378134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - v := random(2); - case v of - 0: s := s + chr(ord('a') + d); - 1: s := s + chr(ord('A') + d); - end; - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaLowerCase(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - s: string; - -begin - RandSeed := 728134; // Everything has to be reproducible - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - s := s + chr(ord('a') + d); - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaUpperCase(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - s: string; - -begin - RandSeed := 728134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - s := s + chr(ord('A') + d); - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaNum(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 785378134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - case random(2) of - 0: begin - v := random(2); - case v of - 0: s := s + chr(ord('a') + d); - 1: s := s + chr(ord('A') + d); - end; - end; - 1: begin - d := random(Ord('9')-Ord('0')); - s := s + chr(ord('0') + d); - end; - end; - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAll(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 781134; // Everything has to be reproducible - v := Len; - - for t := 1 to Count do - begin - s := ''; - - if RandLen then - Len := random(v) + 1; - - for i := 1 to Len do - begin - d := random(255); - s := s + chr(1+d); - end; - - Strings[t-1] := s; - end; -end; - -function StrLower2(const S: AnsiString): AnsiString; -var sTemp: String; -begin - sTemp := S; - StrLowerInPlace(sTemp); - Result := sTemp; -end; - -//================================================================================================== -// TJclStringTransformation -//================================================================================================== - -procedure TJclStringTransformation._StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; -var - i: Integer; - s: String; - -begin - CheckEquals(False, StrIsAlpha(''), 'StrIsAlpha'); // per doc - CheckEquals(False, StrIsAlphaNumUnderscore(''), 'StrIsAlphaNumUnderscore9'); // per doc - CheckEquals(False, StrIsAlphaNum(''), 'StrIsAlphaNum'); // per doc - - GenerateAlpha(2000, 1000, stringarray); - - for i := 1 to 500 do - begin - s := stringarray[i-1]; - CheckEquals(True, StrIsAlpha(s), 'StrIsAlpha'); - CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); - end; - - GenerateAlphaNum(2000, 1000, stringarray, True); - - for i := 1 to 500 do - begin - s := stringarray[i-1]; - CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); - - s := s + '_'; - CheckEquals(False,StrIsAlphaNum(s),'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s),'StrIsAlphaNumUnderscore'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -function ContainsValidator(const C: Char): Boolean; -begin - Result := (C = 'g') or (C = 'r'); -end; - -procedure TJclStringTransformation._StrContainsChars; -begin - CheckEquals(True, StrContainsChars('AbcdefghiJkl', ['g', 'r'], False), 'array, CheckAll set to False'); - CheckEquals(False, StrContainsChars('AbcdefghiJkl', ['g', 'r'], True), 'array, CheckAll set to True, only 1 occurring'); - CheckEquals(True, StrContainsChars('AbcdefghiJklr', ['g', 'r'], True), 'array, CheckAll set to True, both occurring'); - - CheckEquals(True, StrContainsChars('AbcdefghiJkl', ContainsValidator, False), 'validator, CheckAll set to False'); - // CheckAll=True will not work with a validator, at least not with the same meaning as with the array-based tests. - // The tests are disabled for now. - { - CheckEquals(False, StrContainsChars('AbcdefghiJkl', ContainsValidator, True), 'validator, CheckAll set to True, only 1 occurring'); - CheckEquals(True, StrContainsChars('AbcdefghiJklr', ContainsValidator, True), 'validator, CheckAll set to True, both occurring'); - } -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSame; -var - i: Integer; - -begin - // StrSame - CheckEquals(StrSame('',''), True, 'StrSame'); // per doc - CheckEquals(True,StrSame('aaa','AAA'), 'StrSame'); // Case insensitive - - GenerateAll(1000, 500, stringarray, True); - GenerateAll(50, 500, stringarray2, True); - - for i := 1 to 500 do - begin - CheckEquals(True, StrSame(stringarray[i-1], stringarray[i-1]), 'StrSame'); - CheckEquals(False, StrSame(stringarray[i-1], stringarray2[i-1]), 'StrSame'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrIsDigit_StrConsistsOfNumberChars_StrIsSubset; -begin - // StrIsDigit - CheckEquals(StrIsDigit('') , False,'StrIsDigit'); // per doc - - // StrConsistsOfNumberChars - CheckEquals(StrConsistsOfNumberChars('') , False,'StrConsistsOfNumberChars'); // per doc - - // StrIsSubset - CheckEquals(StrIsSubset('',[' ']), False,'StrIsSubset'); // per doc -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCenter; -var - i: Integer; - s, SN: String; - -begin - // StrCenter should return s unchanged. Since the length parameter is - // smaller than (even negative) the acutal length of S. - - S := '1234567890'; - - for i := -100 to 9 do - begin - SN := StrCenter(S, i, '#'); - CheckEquals(SN, S, 'StrCenter'); - end; - - // StrCenter should add the fill pattern. The length is checked. - - for i := 10 to 400 do - begin - SN := StrCenter(S, i, '#'); - CheckEquals(i, Length(SN), 'StrCenter'); - end; - - // StrCenter work tests. - - SN := StrCenter('', 10, '#'); - CheckEquals(Length(SN), 10, 'StrCenter'); - CheckEquals(SN, '##########', 'StrCenter'); - - SN := StrCenter('t', 6, '#'); - CheckEquals(SN, '##t###', 'StrCenter'); - - SN := StrCenter('t', 7, '!'); - CheckEquals(SN, '!!!t!!!', 'StrCenter'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCharPosLower; -begin - CheckEquals('This is a test.', StrCharPosLower('This is a test.', -1)); - CheckEquals('This is a test.', StrCharPosLower('This is a test.', 0)); - CheckEquals('this is a test.', StrCharPosLower('This is a test.', 1)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCharPosUpper; -begin - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', -1)); - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 0)); - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 1)); - CheckEquals('THis is a test.', StrCharPosUpper('This is a test.', 2)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrDoubleQuote; -var - SN, S: string; - i: Integer; - -begin - SN := StrDoubleQuote(''); - CheckEquals('""', SN, 'StrDoubleQuote'); - - SN := StrDoubleQuote('Project JEDI'); - CheckEquals('"Project JEDI"',SN, 'StrDoubleQuote'); - - // Test if String is has been quoted. Since StrDoubleQuote adds quotes also - // when they are already there no special tests are needed. - - GenerateAll(2000,200, StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - CheckEquals('"'+S+'"',StrDoubleQuote(s) ,'StrDoubleQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEnsurePrefix; -var - Prefix, s, SN: String; - I: Integer; - -begin - s := 'TestIt!'; - CheckEquals('TestIt!', StrEnsurePrefix('',S), 'StrEnsurePrefix'); - CheckEquals(StrEnsurePrefix(S,''), 'TestIt!', 'StrEnsurePrefix'); - CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!', 'StrEnsurePrefix'); - - s := 'TestIT!'; - CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!TestIT!','StrEnsurePrefix'); - - // Test StrEnsurePrefix using the Generators. S is the string, Prefix the - // wanted prefix and SN is prefix + s or s if the prefix is already there. - - GenerateAll(2000, 100, StringArray, True); - GenerateAll(20, 100, StringArray2, True); - - for i := 1 to 100 do - begin - S := StringArray[i-1]; - Prefix := StringArray2[i-1]; - - SN := StrEnsurePrefix(Prefix,S); - - if copy(s, 0, length(Prefix)) <> prefix then - Check(SN = prefix+s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])) - else - Check(SN = s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEnsureSuffix; -var - Suffix, s, SN: String; - I: Integer; -begin - s := 'TestIt!'; - CheckEquals(StrEnsureSuffix('',S), 'TestIt!', 'StrEnsureSuffix'); - CheckEquals(StrEnsureSuffix(S,''), 'TestIt!', 'StrEnsureSuffix'); - CheckEquals(StrEnsureSuffix('TestIt!',S), 'TestIt!', 'StrEnsureSuffix'); - - s := 'TestIT!'; - CheckEquals(StrEnsureSuffix('TestIt!',S) , 'TestIT!TestIt!', 'StrEnsureSuffix'); - - // Test StrEnsureSuffix using the Generators. S is the string, Suffix the - // wanted suffix and SN is s + suffix or s if the suffix is already there. - - GenerateAll(2000, 200, StringArray, True); - GenerateAll(20, 200, StringArray2, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - Suffix := StringArray2[i-1]; - - SN := StrEnsureSuffix(suffix,s); - - if copy(s, length(s) - length(suffix), 300) <> suffix then - Check(SN = s + suffix, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])) - else - Check(SN = s, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEscapedToString_StrStringToEscaped; -var - s, sn: string; - i: Integer; - - -begin - S := StrEscapedToString(''); - sn := ''; - CheckEquals(StrEscapedToString(SN), S, 'StrEscapedToString'); - - GenerateAll(1000, 200, StringArray, true); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - sn := StrStringToEscaped(s); - - CheckEquals(StrEscapedToString(SN), s, 'StrEscapedToString'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrLower_StrLowerInPlace_StrLowerBuff; -var - sp: pointer; - i: Integer; - s, sn: string; - -begin - CheckEquals(StrLower(''), '', 'StrLower'); - - { LowerBuff nil tests } - sp := nil; - StrLowerBuff(nil); - StrLowerBuff(sp); - CheckEquals(Integer(sp), Integer(nil), 'StrLowerBuff'); - - { Tests StrLower, StrLowerBuff and StrLowerInPlace against AnsiLowerCase and - against each other. The Testdata consits of only uppercase chars in this test. } - - GenerateAlphaUpperCase(500,500,StringArray, True); - - for i := 1 to 500 do - begin - s := StringArray[i-1]; - SN := s; - StrLowerInPlace(SN); - CheckEquals(StrLower(s), AnsiLowerCase(s), 'StrLower'); - CheckEquals(StrLower(s), SN, 'StrLower'); - - StrLowerBuff(PChar(s)); - CheckEquals(s, SN,'StrLowerBuff'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrMove; -var - Dest: string; - -begin - Dest := 'ATest'; - - StrMove(Dest, 'xxxx', 1, 1, 5); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 4, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', -1, 1, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, -1, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 1, -3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 1, 3); - CheckEquals('xxxst',Dest, 'StrMove'); - - Dest := 'ATest'; - StrMove(Dest, 'abcd', 3, 2, 2); - CheckEquals('ATbct',Dest, 'StrMove'); - - Dest := 'ATest'; - StrMove(Dest, 'abcd', 5, 4, 1); - CheckEquals('ATesd',Dest, 'StrMove'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrPadLeft; -var - S, S3: String; - I, v,t: Integer; - -begin - // -- StrPadLeft -- - - S := ''; - S := StrPadLeft(S, 10, '#'); - CheckEquals(S, '##########','StrPadLeft'); - - s := StrPadLeft(S, -10, '$'); - CheckEquals(S , '##########','StrPadLeft'); - - { StrPadLeft is tested using the Generator. A random number of dollar signs are - added to the string s. The first comparisation test against the length, the - second performs an actual test.} - - GenerateAll(2000,100, StringArray, True); - RandSeed := 123456; - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - v := random(20)+2; - - s3 := StrPadLeft(s, length(s) + v, '$'); - CheckEquals(Length(s3), length(s) + v,'StrPadLeft'); - - for t := 1 to v do - s := '$' + s; - - CheckEquals(s3, s,'StrPadLeft'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrPadRight; -var - S, S3: String; - I, v,t: Integer; - -begin - // -- StrPadRight -- - S := ''; - s := StrPadRight(S, 10, '#'); - CheckEquals(S , '##########','StrPadRight'); - - s := StrPadRight(S, -10, '$'); - CheckEquals(S , '##########','StrPadRight'); - - { StrPadRight is tested using the Generator. A random number of percent char are - added to the string s. The first comparisation test against the length, the - second performs an actual test.} - - GenerateAll(2000,100,StringArray, True); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - v := random(20)+2; - s3 := StrPadRight(s, length(s) + v, '%'); - CheckEquals(Length(s3), length(s) + v,'StrPadRight'); - - for t := 1 to v do - s := s + '%'; - - CheckEquals(s3, s,'StrPadRight'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrProper_StrProperBuff; -var - s, s3: string; - -begin - CheckEquals('', StrProper(''), 'StrProper1'); - CheckEquals('Test', StrProper('Test') , 'StrProper2'); - CheckEquals('Test', StrProper('TeSt'), 'StrProper3'); - CheckEquals('Test', StrProper('TEST'), 'StrProper4'); - CheckEquals('Test1234', StrProper('TeST1234'), 'StrProper5'); - CheckEquals('Test1234', StrProper('teST1234'), 'StrProper6'); - - s := 'TeST'; - s3 := s; - s3 := StrProper(s); - CheckNotEquals(s, s3, 'StrProper7'); - - // check if StrProperBuff can handle a nil pointer - StrProperBuff(nil); - - // check StrProperBuff works as expected - s3 := Copy(s, 1, Length(s)); - StrProperBuff(PChar(s3)); - CheckEquals('Test', s3, 'StrProperBuff.2') -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrQuote; -var - i: Integer; - s: string; - -begin - CheckEquals(StrQuote('','#'), '','StrQuote'); - CheckEquals(StrQuote('a','#'), '#a#','StrQuote'); - CheckEquals(StrQuote('Test','#'), '#Test#','StrQuote'); - CheckEquals(StrQuote('#Test#','#'), '#Test#','StrQuote'); - CheckEquals(StrQuote('"Test"','#'), '#"Test"#','StrQuote'); - CheckEquals(StrQuote('"Test#','"'), '"Test#"','StrQuote'); - - { StrQuote is tested using the Generator. Since it is possible that the char - is already on the left or right side we have to check all four cases.} - - GenerateAll(2000,200,StringArray, True); - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - if (s[1] <> '"') and (s[Length(s)] <> '"') then - CheckEquals(StrQuote(s,'"'), '"'+s+'"','StrQuote') - else - if (s[1] = '"') and (s[Length(s)] = '"') then - CheckEquals(StrQuote(s,'"'), s,'StrQuote') - else - if (s[1] <> '"') and (s[Length(s)] = '"') then - CheckEquals(StrQuote(s,'"'), '"'+s,'StrQuote') - else - if (s[1] = '"') and (s[Length(s)] <> '"') then - CheckEquals(StrQuote(s,'"'), s+'"','StrQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -threadvar - removeset: TSysCharSet; - -function RemoveValidator(const C: Char): Boolean; -begin - Result := C in removeset; -end; - -procedure TJclStringTransformation._StrRemoveChars; -var - i, t, v: Integer; - s, s3, sn: string; -begin - // -- StrRemoveChars -- - CheckEquals(StrRemoveChars('',['e']), '', 'StrRemoveChars 1'); - CheckEquals(StrRemoveChars('Test',['e']), 'Tst', 'StrRemoveChars 2'); - - GenerateAll(20,200,StringArray2, True); - GenerateAll(400,200,StringArray, True); - - { Check StrRemoveChars against a self made one using the Pos function } - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := StringArray[i-1]; - sn := StringArray2[i-1]; - removeset := []; - - for t := 1 to Length(sn) do - begin - if not (sn[t] in removeset) then - removeset := removeset + [Char(sn[t])]; - - v := Pos(sn[t], s3); - - while v > 0 do - begin - Delete(s3, v, 1); - v := Pos(sn[t], s3); - end; - end; - - CheckEquals(s3, StrRemoveChars(s, RemoveValidator), 'StrRemoveChars 3'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -threadvar - keepset: TSysCharSet; - -function KeepValidator(const C: Char): Boolean; -begin - Result := C in keepset; -end; - -procedure TJclStringTransformation._StrKeepChars; -var - i, t: Integer; - s, s3, sn: String; - -begin - CheckEquals('', StrKeepChars('',[]), 'StrKeepChars 0'); - CheckEquals('oieaouoeioao', StrKeepChars('Joint Endeavour of Delphi Innovators',['e', 'a', 'o', 'u', 'i']), 'StrKeepChars 1'); - CheckEquals('oi eaou o ei oao', StrKeepChars('Joint Endeavour of Delphi Innovators',[' ', 'e', 'a', 'o', 'u', 'i']), 'StrKeepChars 2'); - - GenerateAll(20,200,StringArray2, True); - GenerateAll(400,200,StringArray, True); - - { Check StrKeepChars against a self made one } - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := ''; - sn := StringArray2[i-1]; - keepset := []; - - for t := 1 to length(sn) do - begin - if not (sn[t] in keepset) then - keepset := keepset + [Char(sn[t])]; - end; - - for t := 1 to length(s) do - begin - if s[t] in keepset then - s3 := s3 + s[t]; - end; - - CheckEquals(s3, StrKeepChars(s, KeepValidator), 'StrKeepChars 3'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplace; -var - s: string; - -begin - // test 1: Replace on an empty string with an empty search string should result in the replace string - s := ''; - StrReplace(s, '', 'Test', []); - CheckEquals('Test', s, 'StrReplace1'); - - // test 2: replace a short string with a longer string - s := 'This is a test.'; - StrReplace(s, 'is a', 'is a successful', []); - CheckEquals('This is a successful test.', s, 'StrReplace 2'); - - // test 3: replace a long string with a shorter string - s := 'This is a successful little test.'; - StrReplace(s, 'successful little', 'successful', []); - CheckEquals('This is a successful test.', s, 'StrReplace 3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplaceChar; -begin - CheckEquals(StrReplaceChar('', 'a', 'b'),'','StrReplaceChar'); - CheckEquals(StrReplaceChar('', #0, #0),'','StrReplaceChar'); - CheckEquals(StrReplaceChar('ababab', 'a', 'b'),'bbbbbb','StrReplaceChar'); - CheckEquals(StrReplaceChar('ababab', 'b', 'a'),'aaaaaa','StrReplaceChar'); - CheckEquals(StrReplaceChar('xabababx', 'b', 'a'),'xaaaaaax','StrReplaceChar'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplaceChars; -begin - CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); - CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); - CheckEquals(StrReplaceChars('ababab', ['a','b'], 'b'),'bbbbbb','StrReplaceChars'); - CheckEquals(StrReplaceChars('xabababx', ['a','b'], 'b'),'xbbbbbbx','StrReplaceChars'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplacebutChars; -begin - CheckEquals(StrReplaceButChars('', ['a'], 'b'),'','StrReplaceButChars'); - CheckEquals(StrReplaceButChars('xabababx', ['a','b'], 'v'),'vabababv','StrReplaceChars'); - CheckEquals(StrReplaceButChars('TxabababxT', ['a','b'], 'v'),'vvabababvv','StrReplaceChars'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrRepeat; -var - i,t, v: Integer; - s, s3: string; - -begin - CheckEquals(StrRepeat('Test',0) , '', 'StrRepeat'); - CheckEquals(StrRepeat('Test',-1) , '', 'StrRepeat'); - CheckEquals(StrRepeat('Test',-1000) , '', 'StrRepeat'); - CheckEquals(StrRepeat('He',3) , 'HeHeHe', 'StrRepeat'); - CheckEquals(StrRepeat('H e',3) , 'H eH eH e', 'StrRepeat'); - - GenerateAll(50,200,StringArray, True); - - { Check StrRepeat against a self made one } - - RandSeed := 432321; - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := ''; - v := random(20)+1; - - for t := 1 to v do - s3 := s3 + s; - - CheckEquals(StrRepeat(s,v) ,s3, 'StrRepeat'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrRepeatLength; -begin - CheckEquals(StrRepeatLength('Test',0),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',1),'T','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',2),'Te','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',3),'Tes','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',4),'Test','StrRepeatLength'); - CheckEquals(StrRepeatLength('TestTest',8),'TestTest','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',-1),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',-100),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('',-100),'','StrRepeatLength'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReverse_StrReverseInPlace; -var - i,t: Integer; - s, s3: string; - -begin - // -- StrReverse / StrReverseInPlace -- - CheckEquals(StrReverse(''), '', 'StrReverse'); - CheckEquals(StrReverse('a'), 'a', 'StrReverse'); - CheckEquals(StrReverse('ab'), 'ba', 'StrReverse'); - CheckEquals(StrReverse('abc'), 'cba', 'StrReverse'); - - { Check StrReverse against a (slow) self made one } - - GenerateAll(100,200,StringArray, True); - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - SetLength(s3, length(s)); - - for t := 1 to length(s) do - s3[t] := s[(length(s) - t) + 1]; - - s := StrReverse(s); - CheckEquals(s, s3, 'StrReverse'); - - s := StringArray[i-1]; - - StrReverseInPlace(s); - CheckEquals(s, s3, 'StrReverse'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSingleQuote; -var - i: Integer; - s: string; - -begin - CheckEquals(StrSingleQuote(''), '''''', 'StrSingleQuote'); - CheckEquals(StrSingleQuote('Project JEDI'), '''Project JEDI''', 'StrSingleQuote'); - - GenerateAll(2000,200,StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - CheckEquals(StrSingleQuote(s),''''+S+'''', 'StrSingleQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSmartCase; -begin - CheckEquals('', StrSmartCase('', [' ']), 'StrSmartCase1'); - CheckEquals('Project Jedi', StrSmartCase('project jedi', [' ']), 'StrSmartCase2'); - CheckEquals('Project Jedi ', StrSmartCase('project jedi ', [' ']), 'StrSmartCase3'); - CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase4'); - CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase5'); - // test 6: delimiters followed by the same delimiter will not force an upper case on the second delimiter - CheckEquals('XxxxxAx', StrSmartCase('xxxxxAx', [' ','x']), 'StrSmartCase6'); - // test 7: delimiters followed by the another delimiter will not force an upper case on the second delimiter - CheckEquals('Xxx xAx', StrSmartCase('xxx xAx', [' ','x']), 'StrSmartCase7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrStripNonNumberChars; -var - i: Integer; - s: string; - -begin - CheckEquals(StrStripNonNumberChars(''),'','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('123+abcabc+123'),'123++123','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); - - GenerateAlpha(200,50,StringArray, True); - - for i := 1 to 50 do - begin - S := StringArray[i-1]; - CheckEquals(StrStripNonNumberChars(s),'', 'StrStripNonNumberChars'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrToHex; -var - s, sn: string; - -begin - CheckEquals(StrToHex(''),'','StrToHex'); - - SN := '262A32543B'; - SetLength(S,20); - HexToBin(PChar(SN),PChar(S),20); - CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); - - SN := 'FF2A2B2C2D1A2F'; - HexToBin(PChar(SN),PChar(S),20); - CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharLeft; -var - i,t: Integer; - s, s3, sn: string; -begin - CheckEquals('', StrTrimCharLeft('', #0), 'StrTrimCharLeft1'); - CheckEquals('', StrTrimCharLeft('AAAAAAAAAA', 'A'), 'StrTrimCharLeft2'); - - GenerateAll(200, 2000, StringArray); - GenerateAll(1, 2000, StringArray2); - - for i := 1 to 2000 do - begin - S := StringArray[i-1]; - SN := StringArray2[i-1]; - - while S[1] = SN do - s := '#' + s; - - S3 := S; - t := random(100); - - while t <> 0 do - begin - S3 := SN + S3; - dec(t); - end; - - CheckEquals(S, StrTrimCharLeft(S3,SN[1]), 'StrTrimCharLeft3.' + IntToStr(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -function TrimValidator(const C: Char): Boolean; -begin - Result := (C = 'A') or (C = 'B'); -end; - -procedure TJclStringTransformation._StrTrimCharsLeft; -begin - CheckEquals('', StrTrimCharsLeft('', []), 'empty str, empty array'); - CheckEquals('ABC', StrTrimCharsLeft('ABC', []), 'non-empty str, empty array'); - CheckEquals('BCA', StrTrimCharsLeft('ABCA', ['A']), 'ABCA str, A array'); - CheckEquals('CA', StrTrimCharsLeft('ABCA', ['B', 'A']), 'ABCA str, BA array'); - - CheckEquals('CA', StrTrimCharsLeft('ABCA', TrimValidator), 'ABCA str, AB validator'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharRight; -var - i,t: Integer; - s, sn, s3: string; - -begin - // -- StrTrimCharRight -- - CheckEquals('', StrTrimCharRight('', #0), 'StrTrimCharRight1'); - CheckEquals('', StrTrimCharRight('AAAAAAAAAA', 'A'), 'StrTrimCharRight2'); - - GenerateAll(200, 2000, StringArray); - GenerateAll(1, 2000, StringArray2); - - for i := 1 to 2000 do - begin - S := StringArray[i-1]; - SN := StringArray2[i-1]; - - while S[Length(S)] = SN do - s := s + '#'; - - S3 := S; - t := random(100); - - while t <> 0 do - begin - S3 := S3 + SN; - dec(t); - end; - - CheckEquals(S, StrTrimCharRight(S3, SN[1]), 'StrTrimCharRight3.' + IntToStr(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharsRight; -begin - CheckEquals('', StrTrimCharsRight('', []), 'empty str, empty array'); - CheckEquals('ABC', StrTrimCharsRight('ABC', []), 'non-empty str, empty array'); - CheckEquals('ABC', StrTrimCharsRight('ABCA', ['A']), 'ABCA str, A array'); - CheckEquals('AB', StrTrimCharsRight('ABCA', ['C', 'A']), 'ABCA str, CA array'); - - CheckEquals('ABC', StrTrimCharsRight('ABCAABA', TrimValidator), 'ABCAABA str, AB validator'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimQuotes; -var - i: Integer; - s, s3, s4: string; -begin - CheckEquals(StrTrimQuotes(''),'','StrTrimQuotes'); - CheckEquals(StrTrimQuotes('""'),'','StrTrimQuotes'); - CheckEquals(StrTrimQuotes(''''''),'','StrTrimQuotes'); - - CheckEquals(StrTrimQuotes('""TEST""'),'"TEST"','StrTrimQuotes'); - CheckEquals(StrTrimQuotes('''''TEST'''''),'''TEST''','StrTrimQuotes'); - - GenerateAll(200,100,StringArray); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - s3 := StrDoubleQuote(s); - s4 := StrSingleQuote(s); - - CheckEquals(StrTrimQuotes(s3),s,'StrTrimQuotes'); - CheckEquals(StrTrimQuotes(s4),s,'StrTrimQuotes'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrUpper_StrUpperInPlace_StrUpperBuff; -var - i: Integer; - s4, s, s3: string; - -begin - GenerateAll(200,200,StringArray); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S3 := AnsiUpperCase(s); - S4 := S; - StrUpperInPlace(S4); - CheckEquals(StrUpper(S), S3, 'StrUpper'); - CheckEquals(S4, S3, 'StrUpperInPlace'); - - S4 := S; - StrUpperBuff(PChar(S4)); - CheckEquals(S4, S3, 'StrUpperBuff'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -//================================================================================================== -// String Managment -//================================================================================================== - -procedure TJclStringManagment.StringManagement; -{$IFNDEF SUPPORTS_UNICODE} -{$IFDEF KEEP_DEPRECATED} -var - s1: string; -{$ENDIF KEEP_DEPRECATED} -{$ENDIF !SUPPORTS_UNICODE} - -begin -{$IFNDEF SUPPORTS_UNICODE} -{$IFDEF KEEP_DEPRECATED} - StrAddRef(s1); - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 0,'StrRefCount'); - - s1 := 'test'; - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 2,'StrRefCount'); - - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 4,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 3,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 2,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 1,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 0,'StrRefCount'); -{$ELSE !KEEP_DEPRECATED} - Check(True, 'Ignored because KEEP_DEPRECATED not defined'); -{$ENDIF KEEP_DEPRECATED} -{$ELSE SUPPORT_UNICODE} - Check(True, 'Ignored because SUPPORT_UNICODE is defined'); -{$ENDIF !SUPPORTS_UNICODE} -end; - -//================================================================================================== -// String Search and Replace -//================================================================================================== - -procedure TJclStringSearchandReplace.AddCheck(const s1, s2: string; const res: Integer); -begin - StringArray[fillIdx] := s1; - StringArray2[fillIdx] := s2; - ResultArray[fillIdx] := res; - Inc(fillIdx); -end; - -function TJclStringSearchandReplace.NormalizeCompareResult(res: Integer): Integer; -begin - if res < 0 then - Result := -1 - else - if res > 0 then - Result := 1 - else - Result := 0; -end; - -procedure TJclStringSearchandReplace.TestCompare(idx: Integer; res: Integer; msgFmt: string); -begin - CheckEquals(ResultArray[idx], res, Format('[%d] ' + msgFmt, [idx, QuotedStr(StringArray[idx]), QuotedStr(StringArray2[idx])])); -end; - -procedure TJclStringSearchandReplace._CompareNaturalStr; -var - idx: Integer; - s1: string; - s2: string; -begin - fillIdx := 0; - - // mixed strings, whitespace ignoring for number components only - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi Highlander', 'Delphi 2005', 1); - AddCheck('Delphi Highlander', 'Delphi Highlander', 1); - AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); - AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 1); // case-sensitivity test - - // version/revision numbering schemes - AddCheck('1.2', '1.10', -1); - AddCheck('1.20', '1.3a', 1); - AddCheck('1.1.1', '1.1', 1); - AddCheck('1.1', '1.1a', -1); - AddCheck('1.1.a', '1.1a', -1); - AddCheck('a', '1', 1); - AddCheck('a', 'b', -1); - AddCheck('1', '2', -1); - - // leading zeroes overrule normal number comparisons - AddCheck('0002', '1', -1); - AddCheck('1.5', '1.06', 1); - - // hyphen binds looser than period (technically compares a number against a non-number component) - AddCheck('1-2', '1-1', 1); - AddCheck('1-2', '1.2', -1); - - // handling of positive/negative number comparisons - AddCheck('0', '-5', 1); - AddCheck('-5', '+2', -1); - - for idx := 0 to fillIdx - 1 do - begin - s1 := StringArray[idx]; - s2 := StringArray2[idx]; - TestCompare(idx, NormalizeCompareResult(CompareNaturalStr(s1, s2)), 'CompareNaturalStr(%s, %s)'); - end; -end; - -procedure TJclStringSearchandReplace._CompareNaturalText; -var - idx: Integer; -begin - fillIdx := 0; - - // mixed strings, whitespace ignoring for number components only - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi Highlander', 'Delphi 2005', 1); - AddCheck('Delphi Highlander', 'Delphi Highlander', 1); - AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); - AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 0); // case-sensitivity test - - // version/revision numbering schemes - AddCheck('1.2', '1.10', -1); - AddCheck('1.20', '1.3a', 1); - AddCheck('1.1.1', '1.1', 1); - AddCheck('1.1', '1.1a', -1); - AddCheck('1.1.a', '1.1a', -1); - AddCheck('a', '1', 1); - AddCheck('a', 'b', -1); - AddCheck('1', '2', -1); - - // leading zeroes overrule normal number comparisons - AddCheck('0002', '1', -1); - AddCheck('1.5', '1.06', 1); - - // hyphen binds looser than period (technically compares a number against a non-number component) - AddCheck('1-2', '1-1', 1); - AddCheck('1-2', '1.2', -1); - - // handling of positive/negative number comparisons - AddCheck('0', '-5', 1); - AddCheck('-5', '+2', -1); - - for idx := 0 to fillIdx - 1 do - TestCompare(idx, NormalizeCompareResult(CompareNaturalText(StringArray[idx], StringArray2[idx])), 'CompareNaturalText(%s, %s)'); -end; - -procedure TJclStringSearchandReplace._StrCharCount; -var - s: string; - ca, t, i: Integer; - c: char; - -begin - CheckEquals(StrCharCount('','x'),0,'StrCharCount'); - CheckEquals(StrCharCount('Test',#0),0,'StrCharCount'); - CheckEquals(StrCharCount('Test','T'),1,'StrCharCount'); - CheckEquals(StrCharCount('Test','t'),1,'StrCharCount'); - CheckEquals(StrCharCount('TestTT','T'),3,'StrCharCount'); - CheckEquals(StrCharCount('Ttetstt','t'),4,'StrCharCount'); - - GenerateAll(500,100,StringArray, True); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - - for c := #1 to #255 do - begin - ca := 0; - - for t := 1 to length(s) do - begin - if s[t] = c then - inc(ca); - end; - - CheckEquals(StrCharCount(s,c),ca,'StrCharCount'); - end; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCharsCount; -begin - CheckEquals(StrCharsCount('',['x']),0,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',[#0]),0,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',['T']),1,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',['t']),1,'StrCharsCount'); - CheckEquals(StrCharsCount('TestTT',['T']),3,'StrCharsCount'); - CheckEquals(StrCharsCount('Ttetstt',['t']),4,'StrCharsCount'); - CheckEquals(StrCharsCount('Ttetstt',['t','T']),5,'StrCharsCount'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrStrCount; -begin - CheckEquals(1, StrStrCount('Test', 'Test'), 'StrStrCount_1'); - CheckEquals(2, StrStrCount('TestTest', 'Test'), 'StrStrCount_2'); - CheckEquals(0, StrStrCount('Test', 'Quark'), 'StrStrCount_3'); - CheckEquals(0, StrStrCount('', 'Quark'), 'StrStrCount_4'); - CheckEquals(0, StrStrCount('', ''), 'StrStrCount_5'); - CheckEquals(0, StrStrCount('Test', ''), 'StrStrCount_6'); - CheckEquals(0, StrStrCount('Test', 'TEST'), 'StrStrCount_7'); // Case sensive ? - CheckEquals(0, StrStrCount('', 'Test'), 'StrStrCount_8'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCompare; -var - i, t: Integer; - S, S1, S2: String; - -begin - CheckEquals(StrCompare('',''),0,'StrCompare'); - CheckEquals(StrCompare('jedi','jedi'),0,'StrCompare'); - CheckEquals(StrCompare('jedi','je'),2,'StrCompare'); - CheckEquals(StrCompare('di','jedi'),-2,'StrCompare'); - CheckEquals(StrCompare('project jedi','jedi'),8,'StrCompare'); - CheckEquals(StrCompare('jedi','judi'),Ord('e') - Ord('u'),'StrCompare'); - CheckEquals(StrCompare('JEDI','Judi'),Ord('e') - Ord('u'),'StrCompare'); - - GenerateAll(600,200,StringArray); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S1 := S; - CheckEquals(StrCompare(S,S1),0,'StrCompare'); - CheckEquals(StrCompare(S,S),0,'StrCompare'); - end; - - GenerateAll(600,1000,StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S1 := StringArray[199+i]; - - if Length(S) = Length(S1) then - S1 := S1 + 'x'; - - CheckEquals(StrCompare(S,S1),Length(S) - Length(S1),'StrCompare'); - CheckEquals(StrCompare(S1,S),Length(S1) - Length(S),'StrCompare'); - end; - - GenerateAll(600,2000,StringArray); - GenerateAll(1,1000,StringArray2); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S2 := S; - - S1 := StringArray[i]; - t := random(Length(S)); - - while s1 = S[1 + t] do - t := random(Length(S)); - - S[1+t] := Char(s1[1]); - CheckEquals(StrCompare(S2,S), ord(CharLower(S2[1+t])) - ord(CharLower(S[1+t])) ,'StrCompare'); - CheckEquals(StrCompare(S,S2), ord(CharLower(S[1+t])) - ord(CharLower(S2[1+t])) ,'StrCompare'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCompareRange; -begin - CheckEquals(0, StrCompareRange('', '', 1, 0), 'StrCompareRange1'); - CheckEquals(0, StrCompareRange('Test1234', 'Test', 1, 4), 'StrCompareRange5'); - CheckEquals(0, StrCompareRange('Test1234', 'Test1234', 1, 25), 'StrCompareRange6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrFillChar; - - procedure TestCombo(ch: Char; res: string); - var - s: array[0..79] of Char; - str: string; - begin - StrFillChar(s, Length(res), ch); - s[Length(res)] := #0; - str := s; - CheckEquals(res, s, 'StrFillChar ' + IntToStr(Length(res)) + '*' + ch); - end; - -begin - TestCombo('a', ''); - TestCombo('a', 'a'); - TestCombo('a', 'aa'); - TestCombo('b', 'bbbb'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrFind; -begin - CheckEquals(0, StrFind('abc', 'Test'), 'StrFind_1'); - CheckEquals(1, StrFind('Test', 'Test'), 'StrFind_2'); - CheckEquals(1, StrFind('Test', 'test'), 'StrFind_3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrHasPrefix; -begin - CheckEquals(False, StrHasPrefix('', []), 'StrHasPrefix1'); - CheckEquals(False, StrHasPrefix('', ['TEST']), 'StrHasPrefix2'); - CheckEquals(False, StrHasPrefix('', ['TEST', 'TEST2']), 'StrHasPrefix3'); - CheckEquals(False, StrHasPrefix('Test', ['TEST', 'TEST2']), 'StrHasPrefix4'); - CheckEquals(True, StrHasPrefix('Test2', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix5'); - CheckEquals(True, StrHasPrefix('Test12345', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix6'); - CheckEquals(True, StrHasPrefix('Test21234', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIHasPrefix; -begin - CheckEquals(False, StrIHasPrefix('', []), 'StrIHasPrefix1'); - CheckEquals(False, StrIHasPrefix('', ['TEST']), 'StrIHasPrefix2'); - CheckEquals(False, StrIHasPrefix('', ['TEST', 'TEST2']), 'StrIHasPrefix3'); - CheckEquals(True, StrIHasPrefix('Test', ['TEST', 'TEST2']), 'StrIHasPrefix4'); - CheckEquals(True, StrIHasPrefix('Test2', ['TEST', 'TEST2']), 'StrIHasPrefix5'); - CheckEquals(True, StrIHasPrefix('Test12345', ['TEST', 'TEST2']), 'StrIHasPrefix6'); - CheckEquals(True, StrIHasPrefix('Test21234', ['TEST', 'TEST2']), 'StrIHasPrefix7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIndex; -begin - CheckEquals(-1, StrIndex('', ['A', 'B']), 'Empty string in array of AB'); - CheckEquals(-1, StrIndex('A', []), '''A'' string in empty array'); - CheckEquals(0, StrIndex('A', ['A', 'B']), '''A'' string in array of AB, equal case'); - CheckEquals(0, StrIndex('a', ['A', 'B']), '''A'' string in array of AB, differing case'); - CheckEquals(1, StrIndex('B', ['A', 'B']), '''B'' string in array of AB, equal case'); - CheckEquals(2, StrIndex('C', ['A', 'B', 'C', 'C']), '''C'' string in array of ABCC, equal case'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrILastPos; -begin - CheckEquals(10, StrILastPos('A', 'aaaaaaaaaa'), 'StrILastPos_1'); - CheckEquals(16, StrILastPos('abA', 'aabaaababababababa'), 'StrILastPos_2'); - CheckEquals(8, StrILastPos('abbA', 'abbaabbabba'), 'StrILastPos_3'); - CheckEquals(0, StrILastPos('_abba', 'abbaabbabba'), 'StrILastPos_4'); - CheckEquals(5, StrILastPos('_aBBa', 'abba_abbabba'), 'StrILastPos_5'); - CheckEquals(15, StrILastPos('ABA', 'aabaaaABAbabababa'), 'StrILastPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIPos; -begin - CheckEquals(1, StrIPos('A', 'aaaaaaaaaa'), 'StrIPos_1'); - CheckEquals(2, StrIPos('abA', 'aabaaababababababa'), 'StrIPos_2'); - CheckEquals(1, StrIPos('abbA', 'abbaabbabba'), 'StrIPos_3'); - CheckEquals(0, StrIPos('_abba', 'abbaabbabba'), 'StrIPos_4'); - CheckEquals(5, StrIPos('_aBBa', 'abba_abbabba'), 'StrIPos_5'); - CheckEquals(2, StrIPos('ABA', 'aabaaaABAbabababa'), 'StrIPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIPrefixIndex; -begin - CheckEquals(0, StrIPrefixIndex('Project',['Pro']), 'StrIPrefixIndex1'); - CheckEquals(0, StrIPrefixIndex('Project',['Pro','Con']), 'StrIPrefixIndex2'); - CheckEquals(0, StrIPrefixIndex('Project',['']), 'StrIPrefixIndex3'); - CheckEquals(1, StrIPrefixIndex('Project',['Con','Pro']), 'StrIPrefixIndex4'); - CheckEquals(1, StrIPrefixIndex('Project',['Con','PRO']), 'StrIPrefixIndex5'); - CheckEquals(-1, StrIPrefixIndex('Project',['Con','PRA']), 'StrIPrefixIndex5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIsOneOf; -begin - CheckEquals(True, StrIsOneOf('Test', ['a','atest','Test', 'Fest']), 'StrIsOneOf_1'); - CheckEquals(False, StrIsOneOf('Test', ['a','atest', 'Fest']), 'StrIsOneOf_2'); - CheckEquals(False, StrIsOneOf('', ['a','atest', 'Fest']), 'StrIsOneOf_3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrLastPos; -begin - CheckEquals(10, StrLastPos('a', 'aaaaaaaaaa'), 'StrLastPos_1'); - CheckEquals(16, StrLastPos('aba', 'aabaaababababababa'), 'StrLastPos_2'); - CheckEquals(8, StrLastPos('abba', 'abbaabbabba'), 'StrLastPos_3'); - CheckEquals(0, StrLastPos('_abba', 'abbaabbabba'), 'StrLastPos_4'); - CheckEquals(5, StrLastPos('_abba', 'abba_abbabba'), 'StrLastPos_5'); - CheckEquals(7, StrLastPos('ABA', 'aabaaaABAbabababa'), 'StrLastPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrMatch; -begin - CheckEquals(0, StrMatch('', 'Test', 1), 'StrMatch_1'); - CheckEquals(1, StrMatch('Test', 'Test', 1), 'StrMatch_2'); - CheckEquals(2, StrMatch('Test', 'aTest', 1), 'StrMatch_3'); - CheckEquals(3, StrMatch('Test', 'abTest', 1), 'StrMatch_4'); - CheckEquals(4, StrMatch('Test', 'abcTest', 1), 'StrMatch_5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrNPos; -begin - CheckEquals(0, StrNPos('testtesttest','Test',3)); // case sensitive test - CheckEquals(9, StrNPos('TestTestTest','Test',3)); - - CheckEquals(1, StrNPos('Test','Test',1), 'StrNPos_1'); - CheckEquals(0, StrNPos('Test','Test',0), 'StrNPos_2'); - CheckEquals(0, StrNPos('Test','Test',-1), 'StrNPos_3'); - CheckEquals(5, StrNPos('TestTest','Test',2), 'StrNPos_4'); - CheckEquals(0, StrNPos('Testtest','Test',2), 'StrNPos_5'); - CheckEquals(3, StrNPos('__Test__','Test',1), 'StrNPos_6'); - CheckEquals(9, StrNPos('__Test__Test','Test',2), 'StrNPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrMatches; -begin - //CheckEquals(False, StrMatches('','Test',1), 'StrMatches_1'); - CheckEquals(True, StrMatches('Test','Test',1), 'StrMatches_2'); - CheckEquals(True, StrMatches('Test','aTest',2), 'StrMatches_3'); - CheckEquals(False, StrMatches('Test','abTest',1), 'StrMatches_4'); - CheckEquals(False, StrMatches('Test','abcTest',1), 'StrMatches_5'); - CheckEquals(True, StrMatches('T?st', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T??t', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T*', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T*st', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T*st', 'Tett'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T???', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T???', 'Tes'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T?*', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T?*', 'T'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T?s?', 'Test'), 'StrMatches_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrNIPos; -begin - CheckEquals(5, StrNIPos('aaaaaaaaaa', 'A', 5), 'StrNIPos_1'); - CheckEquals(0, StrNIPos('aabaaababababababa', 'abA', 0), 'StrNIPos_2'); - CheckEquals(0, StrNIPos('abbaabbabba', 'abbA', 4), 'StrNIPos_3'); - CheckEquals(8, StrNIPos('abbaabbabba', 'abba', 3), 'StrNIPos_4'); - CheckEquals(5, StrNIPos('abba_abbabba', '_aBBa', 1), 'StrNIPos_5'); - CheckEquals(11, StrNIPos('aabaaaABAbabababa', 'ABA', 4), 'StrNIPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrPrefixIndex; -begin - CheckEquals(0, StrPrefixIndex('Project',['Pro']), 'StrPrefixIndex1'); - CheckEquals(0, StrPrefixIndex('Project',['Pro','Con']), 'StrPrefixIndex2'); - CheckEquals(0, StrPrefixIndex('Project',['']), 'StrPrefixIndex3'); - CheckEquals(1, StrPrefixIndex('Project',['Con','Pro']), 'StrPrefixIndex4'); - CheckEquals(-1, StrPrefixIndex('Project',['Con','PRO']), 'StrPrefixIndex5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrSearch; -begin - CheckEquals(StrSearch('', '', 1), 0, 'StrSearch_1'); - CheckEquals(StrSearch('Test', 'Test', 1), 1, 'StrSearch_2'); - CheckEquals(StrSearch('Test', 'Test12', 1), 1, 'StrSearch_3'); - CheckEquals(StrSearch('Test', 'Test123', 1), 1, 'StrSearch_4'); - CheckEquals(StrSearch('Test', 'abTest123', 1), 3, 'StrSearch_5'); - CheckEquals(StrSearch('Test', 'abTest123', 3), 3, 'StrSearch_6'); - CheckEquals(StrSearch('Test', 'abTaest123', 3), 0, 'StrSearch_7'); - CheckEquals(StrSearch('Test', 'abT', 4), 0, 'StrSearch_8'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharEqualNoCase; -var - c1, c2: char; - -begin - for c1 := #0 to #255 do - for c2 := #0 to #255 do - Check(CharEqualNoCase(c1,c2) = (AnsiUpperCase(C1) = AnsiUpperCase(C2)),Format('CharEqualNoCase: C1: %s C2: %s',[c1,c2])); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsAlpha; -var - C: char; -begin - for C := #0 to #255 do - CheckEquals( - isalpha(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #181, #186, #192 .. #214, - #216 .. #246, #248 .. #255]), - CharIsAlpha(C), - 'CharIsAlpha #' + IntToStr(Ord(C))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsAlphaNum; -var - C: char; -begin - for C := #0 to #255 do - CheckEquals( - isalnum(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #178, #179, #181, #185, #186, - #192 .. #214, #216 .. #246, #248 .. #255]), - CharIsAlphaNum(C) , - 'CharIsAlphaNum #' + IntToStr(Ord(C))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsBlank; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#9, ' ', #160]), - CharIsBlank(c1), - 'CharIsBlank #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsControl; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), - CharIsControl(c1), - 'CharIsControl #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsDelete; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals((ord(c1) = 8), CharIsDelete(c1), 'CharIsDelete #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsDigit; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['0'..'9', #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), - CharIsDigit(c1), - 'CharIsDigit #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsNumberChar; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['0'..'9', '+', '-', DecimalSeparator, #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), - CharIsNumberChar(c1), - 'CharIsNumberChar #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsPrintable; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - not (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), - CharIsPrintable(c1), - 'CharIsPrintable #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsPunctuation; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#123..#126, #130, #132 .. #135, #137, #139, #145 .. #151, #155, #161 .. #191, #215, #247, - #91..#96, #38..#47, '@', #60..#63, '#','$','%','"','.',',','!',':','=',';']), - CharIsPunctuation(c1), - 'CharIsPunctuation #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsReturn; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals(((c1 = #13) or (c1 = #10)), CharIsReturn(c1), 'CharIsReturn #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsSpace; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - c1 in [#9, #10, #11, #12, #13, ' ', #160], - CharIsSpace(c1), - 'CharIsSpace #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsWhiteSpace; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [NativeTab, NativeLineFeed, NativeVerticalTab, NativeFormFeed, NativeCarriageReturn, NativeSpace]), - CharIsWhiteSpace(c1), - 'CharIsWhiteSpace #' + IntToStr(Ord(c1)) - ); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsUpper; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['A'..'Z', #138, #140, #142, #159, #192 .. #214, #216 .. #222]), - CharIsUpper(c1), - 'CharIsUpper #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsLower; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['a' .. 'z', #131, #154, #156, #158, #170, #181, #186, #223 .. #246, #248 .. #255]), - CharIsLower(c1), - 'CharIsLower #' + IntToStr(Ord(c1))); -end; - - -//================================================================================================== -// String Extraction -//================================================================================================== - -procedure TJclStringExtraction._StrAfter; -begin - CheckEquals(StrAfter('',''),'','StrAfter'); - CheckEquals(StrAfter('Hello', 'Hello World'),' World','StrAfter'); - CheckEquals(StrAfter('Hello ', 'Hello World'),'World','StrAfter'); - CheckEquals(StrAfter('is a ', 'This is a test.'),'test.','StrAfter'); - CheckEquals(StrAfter('is a ', 'This is a test. is a test'),'test. is a test','StrAfter'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrBefore; -begin - CheckEquals(StrBefore('',''),'','StrBefore'); - CheckEquals(StrBefore('World', 'Hello World'),'Hello ','StrBefore'); - CheckEquals(StrBefore('Hello ', 'Hello World'),'','StrBefore'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrBetween; -begin - CheckEquals('', StrBetween('', Char(#0), Char(#0)), 'StrBetween1'); - CheckEquals('', StrBetween('', Char(#0), Char(#1)), 'StrBetween2'); - CheckEquals('Test', StrBetween('aTestb', Char('a'), Char('b')), 'StrBetween3'); - CheckEquals('Test', StrBetween(' Test ', Char(' '), Char(' ')), 'StrBetween4'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrChopRight; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrChopRight('',i),'','StrChopRight'); - - CheckEquals(StrChopRight('Project JEDI',1),'Project JED','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',2),'Project JE','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',3),'Project J','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',4),'Project ','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',5),'Project','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',15),'','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',50),'','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',-5),'Project JEDI','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',-50),'Project JEDI','StrChopRight'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrLeft; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrLeft('',i),'','StrLeft'); - - CheckEquals(StrLeft('Project JEDI',0),'','StrLeft'); - CheckEquals(StrLeft('Project JEDI',1),'P','StrLeft'); - CheckEquals(StrLeft('Project JEDI',3),'Pro','StrLeft'); - CheckEquals(StrLeft('Project JEDI',5),'Proje','StrLeft'); - CheckEquals(StrLeft('Project JEDI',-5),'','StrLeft'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrMid; -begin - CheckEquals(StrMid('Test',1,4),'Test','StrLeft'); - CheckEquals(StrMid('Test',1,3),'Tes','StrLeft'); - CheckEquals(StrMid('Test',1,2),'Te','StrLeft'); - CheckEquals(StrMid('Test',1,1),'T','StrLeft'); - CheckEquals(StrMid('Test',1,-1),'','StrLeft'); - CheckEquals(StrMid('Test',1,0),'','StrLeft'); - CheckEquals(StrMid('Test',2,0),'','StrLeft'); - CheckEquals(StrMid('Test',2,4),'est','StrLeft'); - CheckEquals(StrMid('Test',2,3),'est','StrLeft'); - CheckEquals(StrMid('Test',2,2),'es','StrLeft'); - CheckEquals(StrMid('Test',2,1),'e','StrLeft'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrRight; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrRight('',i),'','StrRight'); - - CheckEquals(StrRight('Test',1),'t','StrRight'); - CheckEquals(StrRight('Test',2),'st','StrRight'); - CheckEquals(StrRight('Test',3),'est','StrRight'); - CheckEquals(StrRight('Test',4),'Test','StrRight'); - CheckEquals(StrRight('Test',8),'Test','StrRight'); - CheckEquals(StrRight('Test',-8),'','StrRight'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrRestOf; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrRestOf('',i),'','StrRestOf'); - - for i := -100 to -1 do - CheckEquals(StrRestOf('Test',i),'Test','StrRestOf'); - - CheckEquals(StrRestOf('Test',1),'Test','StrRestOf'); - CheckEquals(StrRestOf('Test',2),'est','StrRestOf'); - CheckEquals(StrRestOf('Test',3),'st','StrRestOf'); -end; - -//-------------------------------------------------------------------------------------------------- - -(* -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.CharacterTransformationRoutines; -var - i,t : integer; - c1, c2: char; - charhextable: array[0..255] of byte; - -begin - // -- CharHex -- - for i:=0 to 255 do - charhextable[i] := $FF; - - for i := ord('0') to ord('9') do - charhextable[i] := i - ord('0'); - - for i := ord('a') to ord('f') do - charhextable[i] := 10 + i - ord('a'); - - for i := ord('A') to ord('F') do - charhextable[i] := 10 + i - ord('A'); - - for c1 := #0 to #255 do - CheckEquals(CharHex(c1) , charhextable[ord(c1)], 'CharHex'); - - // -- CharLower -- - for c1 := 'A' to 'Z' do - CheckEquals(CharLower(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharLower %s (%d)',[string(c1),ord(c1)])); - - // -- CharUpper -- - for c1 := 'a' to 'z' do - CheckEquals(CharUpper(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharUpper %s (%d)',[string(c1),ord(c1)])); - - // -- CharToggleCase -- - for c1 := 'a' to 'z' do - CheckEquals(CharToggleCase(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); - - for c1 := 'A' to 'Z' do - CheckEquals(CharToggleCase(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.CharacterSearchandReplace; -var - s: string; - Strings: TStringList; - c, c1, c2: char; - index, i, r: Integer; - -begin - Strings := TStringList.Create; - try - Strings.LoadFromFile('Data/charpos.dat'); - - i := 0; - - while i < Strings.Count do - begin - s := Strings.Strings[i]; - c := (Strings.Strings[i+1])[1]; - index := strtoint(Strings.Strings[i+2]); - r := CharPos(s, c, index); - Check(r = strtoint(Strings.Strings[i+3]),Format('CharPos %s %s %d %d ',[s,c,index, r])); - r := CharIPos(s, c, index); - Check(r = strtoint(Strings.Strings[i+4]),Format('CharIPos %s',[s])); - inc(i,5); - end; - - c := #0; - r := CharIPos('',c); - CheckEquals(r , 0,'CharIPos'); - r := CharPos('',c); - CheckEquals(r , 0,'CharPos'); - - // -- CharReplace -- - - Strings.LoadFromFile('Data/charreplace.dat'); - - i := 0; - - while i < Strings.Count - 1 do - begin - s := Strings.Strings[i]; - c1 := (Strings.Strings[i+1])[1]; - c2 := (Strings.Strings[i+2])[1]; - r := strtoint(Strings.Strings[i+3]); - CheckEquals(CharReplace(s,c1,c2), r , 'CharReplace'); - CheckEquals(s, Strings.Strings[i+4] , 'CharReplace'); - inc(i,5); - end; - - SetLength(s,0); - CheckEquals(CharReplace(s,#0,#0) , 0,'CharReplace'); - - finally - Strings.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.PCharVectorRoutines; -var - Strings: TStringList; - Strings2: TStringList; - Vector: PCharVector; - i: Integer; - -begin - // -- StringsToPCharVector -- - Strings := TStringList.Create; - try - Strings2 := TStringList.Create; - - try - for i := 1 to 1000 do - begin - Strings.Add(inttostr(i)) - end; - - StringsToPCharVector(Vector, Strings); - - // -- PCharVectorCount -- - CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); - CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); - - for i := 1001 to 1500 do - begin - Strings.Add(inttostr(i)) - end; - - StringsToPCharVector(Vector, Strings); - - // -- PCharVectorCount -- - CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); - CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); - - // -- PCharVectorToStrings -- - PCharVectorToStrings(Strings2, Vector); - - for i := 0 to 1499 do - begin - CheckEquals(Strings.Strings[i],Strings2.Strings[i],'PCharVectorToStrings'); - end; - - // -- FreePCharVector -- - FreePCharVector(Vector); - CheckEquals(Integer(Vector),0,'FreePCharVector'); - finally - Strings2.Free; - end; - - finally - Strings.Free; - end; - -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.MultiSzRoutines; -var - msz: PChar; - g: TStringList; - nb: Integer; - mszo: PChar; - s: string; - -begin - g := TStringList.Create; - try - g.Add('Project'); - g.Add('JEDI'); - g.Add('RULES!'); - - StringsToMultiSz(Msz, g); - - // Check it in memory - s := 'Project' + #0 + 'JEDI' + #0 + 'RULES!' + #0 + #0; - MsZo := PChar(s); - - CheckEquals(CompareMem(Msz, MszO, 21), True, 'StringsToMultiSz'); - - FreeMultiSz(Msz); - finally - g.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.TStringsManipulation; -var - source, dest: TStringList; - -begin - // -- StrToStrings -- - - // -- StringsToStr -- - - // -- TrimStrings -- - - // -- TrimStringsRight -- - - // -- TrimStringsLeft -- -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.Miscellaneous; -var - S: String; - B: Boolean; - SL: TStringList; - -begin - // -- BooleanToStr -- - B := True; - CheckEquals(BooleanToStr(B) , 'True', 'BooleanToStr(TRUE)'); - CheckEquals(BooleanToStr(not B) , 'False', 'BooleanToStr(FALSE)'); - - // -- FileToString -- - // -- StringToFile -- - - // -- StrToken -- - S := 'Test1;Test2'; - CheckEquals(StrToken(s,';'),'Test1','StrToken'); - CheckEquals(S,'Test2','StrToken'); - - S := ';Test'; - CheckEquals(StrToken(s,';'),'','StrToken'); - CheckEquals(S,'Test','StrToken'); - - S := ';;Test'; - CheckEquals(StrToken(s,';'),'','StrToken'); - CheckEquals(S,';Test','StrToken'); - - // -- StrTokens -- - // -- StrTokenToStrings -- - SL := TStringList.Create; - - S := 'Test1;Test2;Test3;Test4'; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Strings[0],'Test1','StrToken'); - CheckEquals(SL.Strings[1],'Test2','StrToken'); - CheckEquals(SL.Strings[2],'Test3','StrToken'); - CheckEquals(SL.Strings[3],'Test4','StrToken'); - CheckEquals(SL.Count, 4,'StrTokenToStrings'); - - SL.Clear; - S := 'Test1;;Test3;Test4'; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Strings[0],'Test1','StrTokenToStrings'); - CheckEquals(SL.Strings[1],'','StrTokenToStrings'); - CheckEquals(SL.Strings[2],'Test3','StrTokenToStrings'); - CheckEquals(SL.Strings[3],'Test4','StrTokenToStrings'); - CheckEquals(SL.Count, 4,'StrTokenToStrings'); - - SL.Clear; - S := ''; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Count, 0,'StrTokenToStrings'); - SL.Free; - - // -- StrWord -- - // -- StrToFloatSafe -- - // -- StrToIntSafe -- -end; - -*) - -//================================================================================================== -// TabSet -//================================================================================================== - -procedure TJclStringTabSet._CalculatedTabWidth; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; -begin - tabs1 := TJclTabSet.Create([4,8], True); - try - CheckEquals(0, tabs1.TabWidth, 'tabs1.TabWidth'); - CheckEquals(4, tabs1.ActualTabWidth, 'tabs1.ActualTabWidth'); - finally - FreeAndNil(tabs1); - end; - - tabs2 := TJclTabSet.Create([4,7], False, -1); - try - CheckEquals(-1, tabs2.TabWidth, 'tabs2.TabWidth'); - CheckEquals(3, tabs2.ActualTabWidth, 'tabs2.ActualTabWidth'); - finally - FreeAndNil(tabs2); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Clone; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; - - procedure NilClone; - begin - tabs1 := nil; - tabs2 := tabs1.Clone; - try - CheckTrue(tabs2 = nil, 'NilClone: tabs2 = nil'); - finally - FreeAndNil(tabs2); - end; - end; - - procedure NormalClone; - begin - tabs1 := TJclTabSet.Create([4, 8], False, 2); - try - tabs2 := tabs1.Clone; - try - CheckTrue(tabs1 <> tabs2, 'NormalClone: tabs1 <> tabs2'); - CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalClone: .TabWidth'); - CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalClone: .ActualTabWidth'); - CheckEquals(tabs1.Count, tabs2.Count, 'NormalClone: .Count'); - CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalClone: .TabStops[0]'); - CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalClone: .TabStops[1]'); - - // changing values in one reference should not influence the other reference - tabs1.TabWidth := 3; - CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); - - // freeing the first instance should leave the second instance working - FreeAndNil(tabs1); - CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); - finally - FreeAndNil(tabs2); - end; - finally - FreeAndNil(tabs1); - end; - end; - -begin - NilClone; - NormalClone; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Expand; -var - tabs: TJclTabSet; - inp: string; - exp: string; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - inp := 'Test:'#9'LD'#9'A,(HL)'#9'; Read from memory'#13#10+ - #9'LD'#9'B, 100'#13#10 + - #9'CALL'#9'Test2'#13#10+ - #9#9#9'; another comment'; - exp := 'Test: LD A,(HL) ; Read from memory'#13#10 + - ' LD B, 100'#13#10 + - ' CALL Test2'#13#10+ - ' ; another comment'; - CheckEqualsString(exp, tabs.Expand(inp)); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._FromString; -var - tabs: TJclTabSet; -begin - // just a tab width - tabs := TJclTabSet.FromString('+4'); - try - CheckEquals(0, tabs.Count, 'FromString(''+4'').Count'); - CheckEquals(False, tabs.ZeroBased, 'FromString(''+4'').ZeroBased'); - CheckEquals(4, tabs.ActualTabWidth, 'FromString(''+4'').ActualTabWidth'); - CheckEquals(4, tabs.TabWidth, 'FromString(''+4'').TabWidth'); - finally - FreeAndNil(tabs); - end; - - // stops and tab width; with excessive whitespace, including tab - tabs := TJclTabSet.FromString('4, 7 ' + #9 + '+4'); - try - CheckEquals(2, tabs.Count, 'FromString(''4, 7 '' + #9 + ''+4'').Count'); - CheckEquals(4, tabs[0], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[0]'); - CheckEquals(7, tabs[1], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[1]'); - CheckEquals(False, tabs.ZeroBased, 'FromString(''4, 7 '' + #9 + ''+4'').ZeroBased'); - CheckEquals(4, tabs.ActualTabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').ActualTabWidth'); - CheckEquals(4, tabs.TabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').TabWidth'); - finally - FreeAndNil(tabs); - end; - - // zero-based, bracketed stops, auto width - tabs := TJclTabSet.FromString('0[4,7]'); - try - CheckEquals(2, tabs.Count, 'FromString(''0[4,7]'').Count'); - CheckEquals(4, tabs[0], 'FromString(''0[4,7]'').tabs[0]'); - CheckEquals(7, tabs[1], 'FromString(''0[4,7]'').tabs[1]'); - CheckEquals(True, tabs.ZeroBased, 'FromString(''0[4,7]'').ZeroBased'); - CheckEquals(3, tabs.ActualTabWidth, 'FromString(''0[4,7]'').ActualTabWidth'); - CheckTrue(tabs.TabWidth < 1, 'FromString(''0[4,7]'').TabWidth'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._NilSet; -var - tabs: TJclTabSet; -begin - // simplify nil tabset access - tabs := nil; - - // nil tabset should be zero based - CheckTrue(tabs.ZeroBased, 'Nil tabset.ZeroBased'); - - // nil tabset should have no tab stops - CheckEquals(0, tabs.Count, 'Nil tabset.Count'); - - // nil tabset should have an actual tabwidth of 2 - CheckEquals(2, tabs.ActualTabWidth, 'Nil tabset.ActualTabWidth'); - - // nil tabset should have a set tabwidth of <1 or 2 - CheckTrue((tabs.TabWidth = 2) or (tabs.TabWidth < 1), 'Nil tabset.TabWidth'); - - // nil tabset expand test - CheckEquals('A bc de', tabs.Expand('A'#9'bc'#9'de'), 'Nil tabset.Expand') -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._OptimalFill; -var - tabs: TJclTabSet; - tabCount: Integer; - spaceCount: Integer; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - // test 1: tabs and spaces to get from column 1 to column 17 - tabs.OptimalFillInfo(1, 17, tabCount, spaceCount); - CheckEquals(1, tabCount, 'tabCount for column 1->17'); - CheckEquals(0, spaceCount, 'spaceCount for column 1->17'); - - // test 2: tabs and spaces to get from column 1 to column 4 - tabs.OptimalFillInfo(1, 4, tabCount, spaceCount); - CheckEquals(0, tabCount, 'tabCount for column 1->4'); - CheckEquals(3, spaceCount, 'spaceCount for column 1->4'); - - // test 3: tabs and spaces to get from column 1 to column 34 - tabs.OptimalFillInfo(1, 34, tabCount, spaceCount); - CheckEquals(3, tabCount, 'tabCount for column 1->34'); - CheckEquals(2, spaceCount, 'spaceCount for column 1->34'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Optimize; -var - tabs: TJclTabSet; - inp: string; - exp: string; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - inp := ' '#9' test second'; - exp := #9' test'#9#9#9#9#9' second'; - CheckEquals(exp, tabs.Optimize(inp)); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Referencing; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; - - procedure NilReference; - begin - tabs1 := nil; - tabs2 := tabs1.NewReference; - try - CheckTrue(tabs2 = nil, 'NilReference: tabs2 = nil'); - finally - FreeAndNil(tabs2); - end; - end; - - procedure NormalReference; - begin - tabs1 := TJclTabSet.Create([4, 8], False, 2); - try - tabs2 := tabs1.NewReference; - try - CheckTrue(tabs1 <> tabs2, 'NormalReference: tabs1 <> tabs2'); - CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalReference: .TabWidth'); - CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalReference: .ActualTabWidth'); - CheckEquals(tabs1.Count, tabs2.Count, 'NormalReference: .Count'); - CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalReference: .TabStops[0]'); - CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalReference: .TabStops[1]'); - - // changing values in one reference should also occur in the other reference - tabs1.TabWidth := 3; - CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); - - // freeing the first instance should leave the second instance working - FreeAndNil(tabs1); - CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); - finally - FreeAndNil(tabs2); - end; - finally - FreeAndNil(tabs1); - end; - end; - -begin - NilReference; - NormalReference; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabFrom; -var - tabs: TJclTabSet; - idx: Integer; -begin - tabs := TJclTabSet.Create([15, 20, 30], True, 2); - try - // test first fixed stop - // columns 0 through 14 will tab to column 15 - for idx := 0 to 14 do - CheckEquals(15, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test second fixed stop - // columns 15 through 19 will tab to column 20 - for idx := 15 to 19 do - CheckEquals(20, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test third and final fixed stop - // columns 20 through 29 will tab to column 30 - for idx := 20 to 29 do - CheckEquals(30, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test tab width beyond fixed positions - // columns 30 through 39 will tab to column 32 (30-31), 34 (32-33), 36 (34-35), 38 (36-37) or 40 (38-39) - for idx := 30 to 39 do - CheckEquals(2 * Succ(idx div 2), tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopAdding; -var - tabs: TJclTabSet; - x: Integer; - failed: Boolean; -begin - tabs := TJclTabSet.Create([15, 30], True); - try - // Add column 20 and check if the index=1 - CheckEquals(1, tabs.Add(20), 'Index of Add(20)'); - // We should have three stops - CheckEquals(3, tabs.Count, 'Count after Add(20)'); - // The first should be 15 - CheckEquals(15, tabs[0], 'tabs[0]'); - // The second should be 20 - CheckEquals(20, tabs[1], 'tabs[1]'); - // The third should be 30 - CheckEquals(30, tabs[2], 'tabs[2]'); - // Adding a duplicate should fail... - begin - try - x := tabs.Add(30); - failed := True; - except - failed := False; - x := 0; // make compiler happy - end; - if failed then - Fail('tabs.Add(30) returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); - end; - // Adding anything less than StartColumn should fail... - begin - try - x := tabs.Add(tabs.StartColumn - 1); - failed := True; - except - failed := False; - x := 0; - end; - if failed then - Fail('tabs.Add(' + IntToStr(tabs.StartColumn - 1) + ') returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); - end; - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopDeleting; -var - tabs: TJclTabSet; - x: Integer; -begin - tabs := TJclTabSet.Create([15, 17, 20, 30], True, 2); - try - CheckEquals(1, tabs.Delete(17), 'Index of Delete(17)'); - // We should have three stops - CheckEquals(3, tabs.Count, 'Count after Add(20)'); - // The first should be 15 - CheckEquals(15, tabs[0], 'tabs[0]'); - // The second should be 20 - CheckEquals(20, tabs[1], 'tabs[1]'); - // The third should be 30 - CheckEquals(30, tabs[2], 'tabs[2]'); - // Deleting a non-existing tab stop should result in a negative value - x := tabs.Delete(24); - CheckTrue(x < 0, 'tabs.Delete(24) returned ' + IntToStr(x) + '; should''ve returned a negative value.'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopModifying; -var - tabs: TJclTabSet; -begin - tabs := TJclTabSet.Create([15, 17, 2, 30], True, 2); - try - // check tabs array before overwriting the first tab stop... - CheckEquals(2, tabs[0], 'tabs[0] before modify.'); - CheckEquals(15, tabs[1], 'tabs[1] before modify.'); - CheckEquals(17, tabs[2], 'tabs[2] before modify.'); - CheckEquals(30, tabs[3], 'tabs[3] before modify.'); - // overwrite the first tab stop - tabs[0] := 20; - // check tabs array after overwriting the first tab stop... - CheckEquals(15, tabs[0], 'tabs[0] after modify.'); - CheckEquals(17, tabs[1], 'tabs[1] after modify.'); - CheckEquals(20, tabs[2], 'tabs[2] after modify.'); - CheckEquals(30, tabs[3], 'tabs[3] after modify.'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._ToString; -var - tabs: TJclTabSet; -begin - tabs := nil; - CheckEquals('0 [] +2', tabs.ToString, 'nil-set, full'); - CheckEquals('0', tabs.ToString(TabSetFormatting_Default), 'nil-set, default'); - - tabs := TJclTabSet.Create([15, 17, 20, 30], True, 4); - try - CheckEquals('0 [15,17,20,30] +4', tabs.ToString, 'zero-based, full'); - CheckEquals('0 15,17,20,30 +4', tabs.ToString(TabSetFormatting_Default), 'zero-based, default'); - tabs.ZeroBased := False; - CheckEquals('[16,18,21,31] +4', tabs.ToString, 'one-based, full'); - CheckEquals('16,18,21,31 +4', tabs.ToString(TabSetFormatting_Default), 'one-based, default'); - finally - tabs.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._UpdatePosition; -var - tabs: TJclTabSet; - column: Integer; - line: Integer; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - column := tabs.StartColumn; - line := 1; - tabs.UpdatePosition( - 'Label1:'#9'LD'#9'A,0'#9'; init A'#13#10+ - #9'LD'#9'B, 100'#9'; loop counter'#13#10+ - #13#10+ - 'lp1:'#9'ADD'#9'(HL)'#9'; add data'#13+ - #9'JR'#9'NC,nxt'#9'; no carry=>skip to nxt'#13+ - #13+ - #9'RRCA'#10+ - #10+ - 'nxt:'#9'INC'#9'H'#9'; next scanline'#13#10+ - #9'DJNZ'#9'lp1', column, line); - CheckEquals(10, line, 'line'); - CheckEquals(25, column, 'column'); - finally - tabs.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._ZeroBased; -var - tabs: TJclTabSet; - x: Integer; - failed: Boolean; -begin - tabs := TJclTabSet.Create([15, 20, 30], True, 2); - try - // make sure it's actually zero-based - CheckTrue(tabs.ZeroBased, 'tabset should be zero based.'); - // can we tab from column 0? - CheckEquals(15, tabs.TabFrom(0), 'tabs.TabFrom(0) in zero-based mode.'); - // we should have three stops - CheckEquals(3, tabs.Count, 'tabs.Count (zero-based)'); - // are they 15, 20 and 30 respectively? - CheckEquals(15, tabs[0], 'tabs[0] (zero-based)'); - CheckEquals(20, tabs[1], 'tabs[1] (zero-based)'); - CheckEquals(30, tabs[2], 'tabs[2] (zero-based)'); - - // switch to not zero-based - tabs.ZeroBased := False; - // make sure it's no longer zero-based - CheckFalse(tabs.ZeroBased, 'tabset shouldn''t be zero based.'); - // we still should have three stops - CheckEquals(3, tabs.Count, 'tabs.Count (not zero-based)'); - // are they 16, 21 and 31 respectively? - CheckEquals(16, tabs[0], 'tabs[0] (not zero-based)'); - CheckEquals(21, tabs[1], 'tabs[1] (not zero-based)'); - CheckEquals(31, tabs[2], 'tabs[2] (not zero-based)'); - // we shouldn't be able to tab from column 0? - try - x := tabs.TabFrom(0); - failed := False; - except - // swallow exception - failed := True; - x := 0; // make compiler happy - end; - if not failed then - Fail('tab.TabFrom(0) resulted in ' + IntToStr(x) + '; should''ve resulted in an exception when not in zero-based mode.'); - finally - FreeAndNil(tabs); - end; -end; - -{ TAnsiStringListTest } - -procedure TAnsiStringListTest._GetCommaTextCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextInnerQuotesProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('"World"'); - slRTL.Add('Hello'); - slRTL.Add('"World"'); - CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TAnsiStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextQuotedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('My World'); - slRTL.Add('Hello'); - slRTL.Add('My World'); - CheckEquals('Hello,"My World"', slJCL.CommaText, 'TAnsiStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextSpacedCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World,There!'; - slRTL.CommaText := 'Hello,My World,There!'; - CheckEquals(4, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World'; - slRTL.CommaText := 'Hello,My World'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextFunkyFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextInnerQuotesProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"""World"""'; - slRTL.CommaText := 'Hello,"""World"""'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('"World"', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextQuotedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"World"'; - slRTL.CommaText := 'Hello,"World"'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextQuotedSpacedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World",There!'; - slRTL.CommaText := 'Hello,"My World",There!'; - CheckEquals(3, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=3 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello,"My World"'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello,"My World"'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slJCL.DelimitedText := 'Hello,My World'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - slRTL.DelimitedText := 'Hello,My World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextFunkyFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello-|My World|'; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello-|My World|'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -initialization - - RegisterTest('JCLStrings', TJclStringTransformation.Suite); - RegisterTest('JCLStrings', TJclStringManagment.Suite); - RegisterTest('JCLStrings', TJclStringSearchandReplace.Suite); - RegisterTest('JCLStrings', TJclStringCharacterTestRoutines.Suite); - RegisterTest('JCLStrings', TJclStringExtraction.Suite); - RegisterTest('JCLStrings', TJclStringTabSet.Suite); - RegisterTest('JCLStrings', TAnsiStringListTest.Suite); - -// History: -// -// $Log$ -// Revision 1.3 2004/12/05 15:55:32 rrossmair -// - restored D5 compatibility -// - -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test Unit } +{ } +{ Covers: JclStrings } +{ Last Update: $Date$ } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +unit TestJclStrings; + +interface +uses + TestFramework, + {$IFDEF MSWINDOWS} + Windows, + {$ELSE} + Types, + {$ENDIF} + Classes, + SysUtils, + JclStrings, + JclStringLists; + +{ TJclStringCharacterTestRoutines } + +type + TJclStringCharacterTestRoutines = class(TTestCase) + private + published + procedure _CharEqualNoCase; + procedure _CharIsAlpha; + procedure _CharIsAlphaNum; + procedure _CharIsBlank; + procedure _CharIsControl; + procedure _CharIsDelete; + procedure _CharIsDigit; + procedure _CharIsNumberChar; + procedure _CharIsPrintable; + procedure _CharIsPunctuation; + procedure _CharIsReturn; + procedure _CharIsSpace; + procedure _CharIsWhiteSpace; + procedure _CharIsUpper; + procedure _CharIsLower; +end; + + +{ TJclStringTransformation } + +type + TJclStringTransformation = class (TTestCase) + private + StringArray : array[0..5000] of string; + StringArray2 : array[0..5000] of string; + + published + { String Transformation } + procedure _StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; + procedure _Deprecated_StrContainsChars_StrIsSubset1; + procedure _StringMatchingAgainstChars; + procedure _StrSame; + procedure _StrIsDigit_StrConsistsOfNumberChars; + procedure _StrCenter; + procedure _StrCharPosLower; + procedure _StrCharPosUpper; + procedure _StrDoubleQuote; + procedure _StrEnsurePrefix; + procedure _StrEnsureSuffix; + procedure _StrEscapedToString_StrStringToEscaped; + procedure _StrLower_StrLowerInPlace_StrLowerBuff; + procedure _StrMove; + procedure _StrPadLeft; + procedure _StrPadRight; + procedure _StrProper_StrProperBuff; + procedure _StrQuote; + procedure _StrReplace; + procedure _StrReplaceChar; + procedure _StrReplaceChars; + procedure _StrReplacebutChars; + procedure _StrRemoveChars; + procedure _StrKeepChars; + procedure _StrRepeat; + procedure _StrRepeatLength; + procedure _StrReverse_StrReverseInPlace; + procedure _StrSingleQuote; + procedure _StrSmartCase; + procedure _StrStripNonNumberChars; + procedure _StrToHex_Ansi; + procedure _StrTrimCharLeft; + procedure _StrTrimCharsLeft; + procedure _StrTrimCharRight; + procedure _StrTrimCharsRight; + procedure _StrTrimQuotes; + procedure _StrUpper_StrUpperInPlace_StrUpperBuff; + end; + + { TJclStringManagment } + + TJclStringManagment = class (TTestCase) + published + procedure StringManagement; + end; + + { TJclStringSearchandReplace } + + TJclStringSearchandReplace = class (TTestCase) + private + StringArray: array[0..5000] of string; + StringArray2: array[0..5000] of string; + ResultArray: array[0..5000] of Integer; + fillIdx: Integer; + procedure AddCheck(const s1, s2: string; const res: Integer); + function NormalizeCompareResult(res: Integer): Integer; + procedure TestCompare(idx: Integer; res: Integer; msgFmt: string); + published + procedure _CompareNaturalStr; + procedure _CompareNaturalText; + procedure _StrCharCount; + procedure _StrCharsCount; + procedure _StrStrCount; + procedure _StrCompare; + procedure _StrCompareRange; + procedure _StrFillChar; + procedure _StrFind; + procedure _StrHasPrefix; + procedure _StrIHasPrefix; + procedure _StrIndex; + procedure _StrILastPos; + procedure _StrIPos; + procedure _StrIPrefixIndex; + procedure _StrIsOneOf; + procedure _StrLastPos; + procedure _StrMatch; + procedure _StrNPos; + procedure _StrMatches; + procedure _StrNIPos; + procedure _StrPrefixIndex; + procedure _StrSearch; + end; + + { TJclStringExtraction } + + TJclStringExtraction = class (TTestCase) + published + procedure _StrAfter; + procedure _StrBefore; + procedure _StrBetween; + procedure _StrChopRight; + procedure _StrLeft; + procedure _StrMid; + procedure _StrRight; + procedure _StrRestOf; + end; + + { TJclStringTabSet } + TJclStringTabSet = class(TTestCase) + published + procedure _CalculatedTabWidth; + procedure _Clone; + procedure _Expand; + procedure _FromString; + procedure _NilSet; + procedure _OptimalFill; + procedure _Optimize; + procedure _Referencing; + procedure _TabFrom; + procedure _TabStopAdding; + procedure _TabStopDeleting; + procedure _TabStopModifying; + procedure _ToString; + procedure _UpdatePosition; + procedure _ZeroBased; +end; + + { TJclStringManagment } + + TAnsiStringListTest = class (TTestCase) + published + procedure _SetCommaTextCount; + procedure _GetCommaTextCount; + procedure _GetCommaTextSpacedCount; + procedure _SetCommaTextProperties; + procedure _SetCommaTextQuotedProperties; + procedure _SetCommaTextQuotedSpacedProperties; + procedure _GetCommaTextQuotedProperties; + procedure _SetCommaTextInnerQuotesProperties; + procedure _GetCommaTextInnerQuotesProperties; + procedure _SetDelimitedTextCommaDoubleQuoteFalse; + procedure _GetDelimitedTextCommaDoubleQuoteFalse; + procedure _SetDelimitedTextCommaDoubleQuoteTrue; + procedure _GetDelimitedTextCommaDoubleQuoteTrue; + procedure _SetDelimitedTextFunkyFalse; + procedure _GetDelimitedTextFunkyFalse; + end; + + TJclStringListTest = class (TTestCase) + published + procedure _SetCommaTextCount; + procedure _GetCommaTextCount; + procedure _GetCommaTextSpacedCount; + procedure _SetCommaTextProperties; + procedure _SetCommaTextQuotedProperties; + procedure _SetCommaTextQuotedSpacedProperties; + procedure _GetCommaTextQuotedProperties; + procedure _SetCommaTextInnerQuotesProperties; + procedure _GetCommaTextInnerQuotesProperties; + procedure _SetDelimitedTextCommaDoubleQuoteFalse; + procedure _GetDelimitedTextCommaDoubleQuoteFalse; + procedure _SetDelimitedTextCommaDoubleQuoteTrue; + procedure _GetDelimitedTextCommaDoubleQuoteTrue; + procedure _SetDelimitedTextFunkyFalse; + procedure _GetDelimitedTextFunkyFalse; + procedure _SplitJoin; + end; + +implementation + +{$IFDEF LINUX} +uses + LibC; +{$ENDIF LINUX} +{$IFDEF WIN32} +const + LibC = 'msvcrt40.dll'; + +function isalnum(C: Integer): LongBool; cdecl; external LibC; +function isalpha(C: Integer): LongBool; cdecl; external LibC; +{$ENDIF WIN32} + +//----------------------------------------------------------------------------------------------- +// Generators +//----------------------------------------------------------------------------------------------- + +procedure GenerateAlpha(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 785378134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + v := random(2); + case v of + 0: s := s + chr(ord('a') + d); + 1: s := s + chr(ord('A') + d); + end; + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaLowerCase(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + s: string; + +begin + RandSeed := 728134; // Everything has to be reproducible + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + s := s + chr(ord('a') + d); + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaUpperCase(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + s: string; + +begin + RandSeed := 728134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + s := s + chr(ord('A') + d); + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaNum(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 785378134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + case random(2) of + 0: begin + v := random(2); + case v of + 0: s := s + chr(ord('a') + d); + 1: s := s + chr(ord('A') + d); + end; + end; + 1: begin + d := random(Ord('9')-Ord('0')); + s := s + chr(ord('0') + d); + end; + end; + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAll(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 781134; // Everything has to be reproducible + v := Len; + + for t := 1 to Count do + begin + s := ''; + + if RandLen then + Len := random(v) + 1; + + for i := 1 to Len do + begin + d := random(255); + s := s + chr(1+d); + end; + + Strings[t-1] := s; + end; +end; + +function StrLower2(const S: AnsiString): AnsiString; +var sTemp: String; +begin + sTemp := S; + StrLowerInPlace(sTemp); + Result := sTemp; +end; + +//================================================================================================== +// TJclStringTransformation +//================================================================================================== + +procedure TJclStringTransformation._StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; +var + i: Integer; + s: String; + +begin + CheckEquals(False, StrIsAlpha(''), 'StrIsAlpha'); // per doc + CheckEquals(False, StrIsAlphaNumUnderscore(''), 'StrIsAlphaNumUnderscore9'); // per doc + CheckEquals(False, StrIsAlphaNum(''), 'StrIsAlphaNum'); // per doc + + GenerateAlpha(2000, 1000, stringarray); + + for i := 1 to 500 do + begin + s := stringarray[i-1]; + CheckEquals(True, StrIsAlpha(s), 'StrIsAlpha'); + CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); + end; + + GenerateAlphaNum(2000, 1000, stringarray, True); + + for i := 1 to 500 do + begin + s := stringarray[i-1]; + CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); + + s := s + '_'; + CheckEquals(False,StrIsAlphaNum(s),'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s),'StrIsAlphaNumUnderscore'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +function ContainsValidator(const C: Char): Boolean; +begin + Result := (C = 'g') or (C = 'r'); +end; + +procedure TJclStringTransformation._Deprecated_StrContainsChars_StrIsSubset1; +begin + // StrIsSubset + CheckEquals(StrIsSubset('',[' ']), False,'StrIsSubset'); // per doc + + CheckEquals(True, StrContainsChars('AbcdefghiJkl', ['g', 'r'], False), 'array, CheckAll set to False'); + CheckEquals(False, StrContainsChars('AbcdefghiJkl', ['g', 'r'], True), 'array, CheckAll set to True, only 1 occurring'); + CheckEquals(True, StrContainsChars('AbcdefghiJklr', ['g', 'r'], True), 'array, CheckAll set to True, both occurring'); + + CheckEquals(True, StrContainsChars('AbcdefghiJkl', ContainsValidator, False), 'validator, CheckAll set to False'); + // CheckAll=True will not work with a validator, at least not with the same meaning as with the array-based tests. + // The tests are disabled for now. + { + CheckEquals(False, StrContainsChars('AbcdefghiJkl', ContainsValidator, True), 'validator, CheckAll set to True, only 1 occurring'); + CheckEquals(True, StrContainsChars('AbcdefghiJklr', ContainsValidator, True), 'validator, CheckAll set to True, both occurring'); + } +end; + +procedure TJclStringTransformation._StringMatchingAgainstChars; +begin + CheckTrue (StrContainsEveryChar('AbcdefghiJklr', ['g', 'r'])); + CheckTrue (StrContainsEveryChar('', [])); + CheckFalse(StrContainsEveryChar('AbcdefghiJkl', ['g', 'r'])); + CheckTrue (StrContainsEveryChar('AbcdefghiJklr', 'gr')); + CheckTrue (StrContainsEveryChar('', '')); + CheckFalse(StrContainsEveryChar('AbcdefghiJkl', 'gr')); + + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ['g', 'r'])); + CheckTrue (StrContainsSomeChar('AbcdefhiJklr', ['r', 'g'])); + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', 'rg')); + CheckTrue (StrContainsSomeChar('AbcdefghiJkl', 'rg')); + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ContainsValidator)); + CheckTrue (StrContainsSomeChar('AbcdefghiJkl', ContainsValidator)); + + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ['g', 'r'])); + CheckTrue (StrConsistsOfChars('grrrgr', ['r', 'g'])); + CheckTrue (StrConsistsOfChars('', ['r', 'g'])); + CheckFalse(StrConsistsOfChars('', ['r', 'g'], False)); + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', 'rg')); + CheckTrue (StrConsistsOfChars('grrrgr', 'rg')); + CheckTrue (StrConsistsOfChars('', 'rg')); + CheckFalse (StrConsistsOfChars('', 'rg', False)); + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ContainsValidator)); + CheckTrue (StrConsistsOfChars('grrrgr', ContainsValidator)); + CheckTrue (StrConsistsOfChars('', ContainsValidator)); + CheckFalse(StrConsistsOfChars('', ContainsValidator, False)); + +(* +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; + *) +end; + + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSame; +var + i: Integer; + +begin + // StrSame + CheckEquals(StrSame('',''), True, 'StrSame'); // per doc + CheckEquals(True,StrSame('aaa','AAA'), 'StrSame'); // Case insensitive + + GenerateAll(1000, 500, stringarray, True); + GenerateAll(50, 500, stringarray2, True); + + for i := 1 to 500 do + begin + CheckEquals(True, StrSame(stringarray[i-1], stringarray[i-1]), 'StrSame'); + CheckEquals(False, StrSame(stringarray[i-1], stringarray2[i-1]), 'StrSame'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrIsDigit_StrConsistsOfNumberChars; +var s: string; +begin + // StrIsDigit + CheckEquals(StrIsDigit('') , False, 'StrIsDigit'); // per doc + CheckEquals(StrConsistsOfDigits('') , False, 'StrConsistsOfDigits'); // per doc + + // StrConsistsOfNumberChars + CheckEquals(StrConsistsOfNumberChars('') , False,'StrConsistsOfNumberChars'); // per doc + + CheckEquals(StrConsistsOfDigits('2345') , True, 'StrConsistsOfDigits'); // per doc + CheckEquals(StrConsistsOfNumberChars('2345') , True,'StrConsistsOfNumberChars'); // per doc + + s := FormatFloat('#,###.##', -12345.6789); + CheckEquals(StrConsistsOfDigits(s) , False, 'StrConsistsOfDigits'); // per doc + CheckEquals(StrConsistsOfNumberChars(s) , True,'StrConsistsOfNumberChars'); // per doc +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCenter; +var + i: Integer; + s, SN: String; + +begin + // StrCenter should return s unchanged. Since the length parameter is + // smaller than (even negative) the acutal length of S. + + S := '1234567890'; + + for i := -100 to 9 do + begin + SN := StrCenter(S, i, '#'); + CheckEquals(SN, S, 'StrCenter'); + end; + + // StrCenter should add the fill pattern. The length is checked. + + for i := 10 to 400 do + begin + SN := StrCenter(S, i, '#'); + CheckEquals(i, Length(SN), 'StrCenter'); + end; + + // StrCenter work tests. + + SN := StrCenter('', 10, '#'); + CheckEquals(Length(SN), 10, 'StrCenter'); + CheckEquals(SN, '##########', 'StrCenter'); + + SN := StrCenter('t', 6, '#'); + CheckEquals(SN, '##t###', 'StrCenter'); + + SN := StrCenter('t', 7, '!'); + CheckEquals(SN, '!!!t!!!', 'StrCenter'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCharPosLower; +begin + CheckEquals('This is a test.', StrCharPosLower('This is a test.', -1)); + CheckEquals('This is a test.', StrCharPosLower('This is a test.', 0)); + CheckEquals('this is a test.', StrCharPosLower('This is a test.', 1)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCharPosUpper; +begin + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', -1)); + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 0)); + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 1)); + CheckEquals('THis is a test.', StrCharPosUpper('This is a test.', 2)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrDoubleQuote; +var + SN, S: string; + i: Integer; + +begin + SN := StrDoubleQuote(''); + CheckEquals('""', SN, 'StrDoubleQuote'); + + SN := StrDoubleQuote('Project JEDI'); + CheckEquals('"Project JEDI"',SN, 'StrDoubleQuote'); + + // Test if String is has been quoted. Since StrDoubleQuote adds quotes also + // when they are already there no special tests are needed. + + GenerateAll(2000,200, StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + CheckEquals('"'+S+'"',StrDoubleQuote(s) ,'StrDoubleQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEnsurePrefix; +var + Prefix, s, SN: String; + I: Integer; + +begin + s := 'TestIt!'; + CheckEquals('TestIt!', StrEnsurePrefix('',S), 'StrEnsurePrefix'); + CheckEquals(StrEnsurePrefix(S,''), 'TestIt!', 'StrEnsurePrefix'); + CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!', 'StrEnsurePrefix'); + + s := 'TestIT!'; + CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!TestIT!','StrEnsurePrefix'); + + // Test StrEnsurePrefix using the Generators. S is the string, Prefix the + // wanted prefix and SN is prefix + s or s if the prefix is already there. + + GenerateAll(2000, 100, StringArray, True); + GenerateAll(20, 100, StringArray2, True); + + for i := 1 to 100 do + begin + S := StringArray[i-1]; + Prefix := StringArray2[i-1]; + + SN := StrEnsurePrefix(Prefix,S); + + if copy(s, 0, length(Prefix)) <> prefix then + Check(SN = prefix+s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])) + else + Check(SN = s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEnsureSuffix; +var + Suffix, s, SN: String; + I: Integer; +begin + s := 'TestIt!'; + CheckEquals(StrEnsureSuffix('',S), 'TestIt!', 'StrEnsureSuffix'); + CheckEquals(StrEnsureSuffix(S,''), 'TestIt!', 'StrEnsureSuffix'); + CheckEquals(StrEnsureSuffix('TestIt!',S), 'TestIt!', 'StrEnsureSuffix'); + + s := 'TestIT!'; + CheckEquals(StrEnsureSuffix('TestIt!',S) , 'TestIT!TestIt!', 'StrEnsureSuffix'); + + // Test StrEnsureSuffix using the Generators. S is the string, Suffix the + // wanted suffix and SN is s + suffix or s if the suffix is already there. + + GenerateAll(2000, 200, StringArray, True); + GenerateAll(20, 200, StringArray2, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + Suffix := StringArray2[i-1]; + + SN := StrEnsureSuffix(suffix,s); + + if copy(s, length(s) - length(suffix), 300) <> suffix then + Check(SN = s + suffix, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])) + else + Check(SN = s, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEscapedToString_StrStringToEscaped; +var + s, sn: string; + i: Integer; + + +begin + S := StrEscapedToString(''); + sn := ''; + CheckEquals(StrEscapedToString(SN), S, 'StrEscapedToString'); + + GenerateAll(1000, 200, StringArray, true); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + sn := StrStringToEscaped(s); + + CheckEquals(StrEscapedToString(SN), s, 'StrEscapedToString'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrLower_StrLowerInPlace_StrLowerBuff; +var + sp: pointer; + i: Integer; + s, sn: string; + +begin + CheckEquals(StrLower(''), '', 'StrLower'); + + { LowerBuff nil tests } + sp := nil; + StrLowerBuff(nil); + StrLowerBuff(sp); + CheckEquals(Integer(sp), Integer(nil), 'StrLowerBuff'); + + { Tests StrLower, StrLowerBuff and StrLowerInPlace against AnsiLowerCase and + against each other. The Testdata consits of only uppercase chars in this test. } + + GenerateAlphaUpperCase(500,500,StringArray, True); + + for i := 1 to 500 do + begin + s := StringArray[i-1]; + SN := s; + StrLowerInPlace(SN); + CheckEquals(StrLower(s), AnsiLowerCase(s), 'StrLower'); + CheckEquals(StrLower(s), SN, 'StrLower'); + + StrLowerBuff(PChar(s)); + CheckEquals(s, SN,'StrLowerBuff'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrMove; +var + Dest: string; + +begin + Dest := 'ATest'; + + StrMove(Dest, 'xxxx', 1, 1, 5); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 4, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', -1, 1, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, -1, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 1, -3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 1, 3); + CheckEquals('xxxst',Dest, 'StrMove'); + + Dest := 'ATest'; + StrMove(Dest, 'abcd', 3, 2, 2); + CheckEquals('ATbct',Dest, 'StrMove'); + + Dest := 'ATest'; + StrMove(Dest, 'abcd', 5, 4, 1); + CheckEquals('ATesd',Dest, 'StrMove'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrPadLeft; +var + S, S3: String; + I, v,t: Integer; + +begin + // -- StrPadLeft -- + + S := ''; + S := StrPadLeft(S, 10, '#'); + CheckEquals(S, '##########','StrPadLeft'); + + s := StrPadLeft(S, -10, '$'); + CheckEquals(S , '##########','StrPadLeft'); + + { StrPadLeft is tested using the Generator. A random number of dollar signs are + added to the string s. The first comparisation test against the length, the + second performs an actual test.} + + GenerateAll(2000,100, StringArray, True); + RandSeed := 123456; + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + v := random(20)+2; + + s3 := StrPadLeft(s, length(s) + v, '$'); + CheckEquals(Length(s3), length(s) + v,'StrPadLeft'); + + for t := 1 to v do + s := '$' + s; + + CheckEquals(s3, s,'StrPadLeft'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrPadRight; +var + S, S3: String; + I, v,t: Integer; + +begin + // -- StrPadRight -- + S := ''; + s := StrPadRight(S, 10, '#'); + CheckEquals(S , '##########','StrPadRight'); + + s := StrPadRight(S, -10, '$'); + CheckEquals(S , '##########','StrPadRight'); + + { StrPadRight is tested using the Generator. A random number of percent char are + added to the string s. The first comparisation test against the length, the + second performs an actual test.} + + GenerateAll(2000,100,StringArray, True); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + v := random(20)+2; + s3 := StrPadRight(s, length(s) + v, '%'); + CheckEquals(Length(s3), length(s) + v,'StrPadRight'); + + for t := 1 to v do + s := s + '%'; + + CheckEquals(s3, s,'StrPadRight'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrProper_StrProperBuff; +var + s, s3: string; + +begin + CheckEquals('', StrProper(''), 'StrProper1'); + CheckEquals('Test', StrProper('Test') , 'StrProper2'); + CheckEquals('Test', StrProper('TeSt'), 'StrProper3'); + CheckEquals('Test', StrProper('TEST'), 'StrProper4'); + CheckEquals('Test1234', StrProper('TeST1234'), 'StrProper5'); + CheckEquals('Test1234', StrProper('teST1234'), 'StrProper6'); + + s := 'TeST'; + s3 := s; + s3 := StrProper(s); + CheckNotEquals(s, s3, 'StrProper7'); + + // check if StrProperBuff can handle a nil pointer + StrProperBuff(nil); + + // check StrProperBuff works as expected + s3 := Copy(s, 1, Length(s)); + StrProperBuff(PChar(s3)); + CheckEquals('Test', s3, 'StrProperBuff.2') +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrQuote; +var + i: Integer; + s: string; + +begin + CheckEquals(StrQuote('','#'), '','StrQuote'); + CheckEquals(StrQuote('a','#'), '#a#','StrQuote'); + CheckEquals(StrQuote('Test','#'), '#Test#','StrQuote'); + CheckEquals(StrQuote('#Test#','#'), '#Test#','StrQuote'); + CheckEquals(StrQuote('"Test"','#'), '#"Test"#','StrQuote'); + CheckEquals(StrQuote('"Test#','"'), '"Test#"','StrQuote'); + + { StrQuote is tested using the Generator. Since it is possible that the char + is already on the left or right side we have to check all four cases.} + + GenerateAll(2000,200,StringArray, True); + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + if (s[1] <> '"') and (s[Length(s)] <> '"') then + CheckEquals(StrQuote(s,'"'), '"'+s+'"','StrQuote') + else + if (s[1] = '"') and (s[Length(s)] = '"') then + CheckEquals(StrQuote(s,'"'), s,'StrQuote') + else + if (s[1] <> '"') and (s[Length(s)] = '"') then + CheckEquals(StrQuote(s,'"'), '"'+s,'StrQuote') + else + if (s[1] = '"') and (s[Length(s)] <> '"') then + CheckEquals(StrQuote(s,'"'), s+'"','StrQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +threadvar + removeset: TSysCharSet; + +function RemoveValidator(const C: Char): Boolean; +begin + Result := C in removeset; +end; + +procedure TJclStringTransformation._StrRemoveChars; +var + i, t, v: Integer; + s, s3, sn: string; +begin + // -- StrRemoveChars -- + CheckEquals(StrRemoveChars('',['e']), '', 'StrRemoveChars 1'); + CheckEquals(StrRemoveChars('Test',['e']), 'Tst', 'StrRemoveChars 2'); + + GenerateAll(20,200,StringArray2, True); + GenerateAll(400,200,StringArray, True); + + { Check StrRemoveChars against a self made one using the Pos function } + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := StringArray[i-1]; + sn := StringArray2[i-1]; + removeset := []; + + for t := 1 to Length(sn) do + begin + if not (sn[t] in removeset) then + removeset := removeset + [Char(sn[t])]; + + v := Pos(sn[t], s3); + + while v > 0 do + begin + Delete(s3, v, 1); + v := Pos(sn[t], s3); + end; + end; + + CheckEquals(s3, StrRemoveChars(s, RemoveValidator), 'StrRemoveChars 3'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +threadvar + keepset: TSysCharSet; + +function KeepValidator(const C: Char): Boolean; +begin + Result := C in keepset; +end; + +procedure TJclStringTransformation._StrKeepChars; +var + i, t: Integer; + s, s3, sn: String; + +begin + CheckEquals('', StrKeepChars('',[]), 'StrKeepChars 0'); + CheckEquals('oieaouoeioao', StrKeepChars('Joint Endeavour of Delphi Innovators',['e', 'a', 'o', 'u', 'i']), 'StrKeepChars 1'); + CheckEquals('oi eaou o ei oao', StrKeepChars('Joint Endeavour of Delphi Innovators',[' ', 'e', 'a', 'o', 'u', 'i']), 'StrKeepChars 2'); + + GenerateAll(20,200,StringArray2, True); + GenerateAll(400,200,StringArray, True); + + { Check StrKeepChars against a self made one } + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := ''; + sn := StringArray2[i-1]; + keepset := []; + + for t := 1 to length(sn) do + begin + if not (sn[t] in keepset) then + keepset := keepset + [Char(sn[t])]; + end; + + for t := 1 to length(s) do + begin + if s[t] in keepset then + s3 := s3 + s[t]; + end; + + CheckEquals(s3, StrKeepChars(s, KeepValidator), 'StrKeepChars 3'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplace; +var + s: string; + +begin + // test 1: Replace on an empty string with an empty search string should result in the replace string + s := ''; + StrReplace(s, '', 'Test', []); + CheckEquals('Test', s, 'StrReplace1'); + + // test 2: replace a short string with a longer string + s := 'This is a test.'; + StrReplace(s, 'is a', 'is a successful', []); + CheckEquals('This is a successful test.', s, 'StrReplace 2'); + + // test 3: replace a long string with a shorter string + s := 'This is a successful little test.'; + StrReplace(s, 'successful little', 'successful', []); + CheckEquals('This is a successful test.', s, 'StrReplace 3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplaceChar; +begin + CheckEquals(StrReplaceChar('', 'a', 'b'),'','StrReplaceChar'); + CheckEquals(StrReplaceChar('', #0, #0),'','StrReplaceChar'); + CheckEquals(StrReplaceChar('ababab', 'a', 'b'),'bbbbbb','StrReplaceChar'); + CheckEquals(StrReplaceChar('ababab', 'b', 'a'),'aaaaaa','StrReplaceChar'); + CheckEquals(StrReplaceChar('xabababx', 'b', 'a'),'xaaaaaax','StrReplaceChar'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplaceChars; +begin + CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); + CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); + CheckEquals(StrReplaceChars('ababab', ['a','b'], 'b'),'bbbbbb','StrReplaceChars'); + CheckEquals(StrReplaceChars('xabababx', ['a','b'], 'b'),'xbbbbbbx','StrReplaceChars'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplacebutChars; +begin + CheckEquals(StrReplaceButChars('', ['a'], 'b'),'','StrReplaceButChars'); + CheckEquals(StrReplaceButChars('xabababx', ['a','b'], 'v'),'vabababv','StrReplaceChars'); + CheckEquals(StrReplaceButChars('TxabababxT', ['a','b'], 'v'),'vvabababvv','StrReplaceChars'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrRepeat; +var + i,t, v: Integer; + s, s3: string; + +begin + CheckEquals(StrRepeat('Test',0) , '', 'StrRepeat'); + CheckEquals(StrRepeat('Test',-1) , '', 'StrRepeat'); + CheckEquals(StrRepeat('Test',-1000) , '', 'StrRepeat'); + CheckEquals(StrRepeat('He',3) , 'HeHeHe', 'StrRepeat'); + CheckEquals(StrRepeat('H e',3) , 'H eH eH e', 'StrRepeat'); + + GenerateAll(50,200,StringArray, True); + + { Check StrRepeat against a self made one } + + RandSeed := 432321; + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := ''; + v := random(20)+1; + + for t := 1 to v do + s3 := s3 + s; + + CheckEquals(StrRepeat(s,v) ,s3, 'StrRepeat'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrRepeatLength; +begin + CheckEquals(StrRepeatLength('Test',0),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',1),'T','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',2),'Te','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',3),'Tes','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',4),'Test','StrRepeatLength'); + CheckEquals(StrRepeatLength('TestTest',8),'TestTest','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',-1),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',-100),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('',-100),'','StrRepeatLength'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReverse_StrReverseInPlace; +var + i,t: Integer; + s, s3: string; + +begin + // -- StrReverse / StrReverseInPlace -- + CheckEquals(StrReverse(''), '', 'StrReverse'); + CheckEquals(StrReverse('a'), 'a', 'StrReverse'); + CheckEquals(StrReverse('ab'), 'ba', 'StrReverse'); + CheckEquals(StrReverse('abc'), 'cba', 'StrReverse'); + + { Check StrReverse against a (slow) self made one } + + GenerateAll(100,200,StringArray, True); + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + SetLength(s3, length(s)); + + for t := 1 to length(s) do + s3[t] := s[(length(s) - t) + 1]; + + s := StrReverse(s); + CheckEquals(s, s3, 'StrReverse'); + + s := StringArray[i-1]; + + StrReverseInPlace(s); + CheckEquals(s, s3, 'StrReverse'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSingleQuote; +var + i: Integer; + s: string; + +begin + CheckEquals(StrSingleQuote(''), '''''', 'StrSingleQuote'); + CheckEquals(StrSingleQuote('Project JEDI'), '''Project JEDI''', 'StrSingleQuote'); + + GenerateAll(2000,200,StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + CheckEquals(StrSingleQuote(s),''''+S+'''', 'StrSingleQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSmartCase; +begin + CheckEquals('', StrSmartCase('', [' ']), 'StrSmartCase1'); + CheckEquals('Project Jedi', StrSmartCase('project jedi', [' ']), 'StrSmartCase2'); + CheckEquals('Project Jedi ', StrSmartCase('project jedi ', [' ']), 'StrSmartCase3'); + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase4'); + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase5'); + // test 6: delimiters followed by the same delimiter will not force an upper case on the second delimiter + CheckEquals('XxxxxAx', StrSmartCase('xxxxxAx', [' ','x']), 'StrSmartCase6'); + // test 7: delimiters followed by the another delimiter will not force an upper case on the second delimiter + CheckEquals('Xxx xAx', StrSmartCase('xxx xAx', [' ','x']), 'StrSmartCase7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrStripNonNumberChars; +var + i: Integer; + s: string; + +begin + CheckEquals(StrStripNonNumberChars(''),'','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('123+abcabc+123'),'123++123','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); + + GenerateAlpha(200,50,StringArray, True); + + for i := 1 to 50 do + begin + S := StringArray[i-1]; + CheckEquals(StrStripNonNumberChars(s),'', 'StrStripNonNumberChars'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrToHex_Ansi; +var + s, sn: AnsiString; + +begin + CheckEquals(StrToHex(''),'','StrToHex'); + + SN := '262A32543B'; + SetLength(S,20); + HexToBin(PAnsiChar(SN),PAnsiChar(S),20); + CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); + + SN := 'FF2A2B2C2D1A2F'; + HexToBin(PAnsiChar(SN),PAnsiChar(S),20); + CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharLeft; +var + i,t: Integer; + s, s3, sn: string; +begin + CheckEquals('', StrTrimCharLeft('', #0), 'StrTrimCharLeft1'); + CheckEquals('', StrTrimCharLeft('AAAAAAAAAA', 'A'), 'StrTrimCharLeft2'); + + GenerateAll(200, 2000, StringArray); + GenerateAll(1, 2000, StringArray2); + + for i := 1 to 2000 do + begin + S := StringArray[i-1]; + SN := StringArray2[i-1]; + + while S[1] = SN do + s := '#' + s; + + S3 := S; + t := random(100); + + while t <> 0 do + begin + S3 := SN + S3; + dec(t); + end; + + CheckEquals(S, StrTrimCharLeft(S3,SN[1]), 'StrTrimCharLeft3.' + IntToStr(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +function TrimValidator(const C: Char): Boolean; +begin + Result := (C = 'A') or (C = 'B'); +end; + +procedure TJclStringTransformation._StrTrimCharsLeft; +begin + CheckEquals('', StrTrimCharsLeft('', []), 'empty str, empty array'); + CheckEquals('ABC', StrTrimCharsLeft('ABC', []), 'non-empty str, empty array'); + CheckEquals('BCA', StrTrimCharsLeft('ABCA', ['A']), 'ABCA str, A array'); + CheckEquals('CA', StrTrimCharsLeft('ABCA', ['B', 'A']), 'ABCA str, BA array'); + + CheckEquals('CA', StrTrimCharsLeft('ABCA', TrimValidator), 'ABCA str, AB validator'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharRight; +var + i,t: Integer; + s, sn, s3: string; + +begin + // -- StrTrimCharRight -- + CheckEquals('', StrTrimCharRight('', #0), 'StrTrimCharRight1'); + CheckEquals('', StrTrimCharRight('AAAAAAAAAA', 'A'), 'StrTrimCharRight2'); + + GenerateAll(200, 2000, StringArray); + GenerateAll(1, 2000, StringArray2); + + for i := 1 to 2000 do + begin + S := StringArray[i-1]; + SN := StringArray2[i-1]; + + while S[Length(S)] = SN do + s := s + '#'; + + S3 := S; + t := random(100); + + while t <> 0 do + begin + S3 := S3 + SN; + dec(t); + end; + + CheckEquals(S, StrTrimCharRight(S3, SN[1]), 'StrTrimCharRight3.' + IntToStr(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharsRight; +begin + CheckEquals('', StrTrimCharsRight('', []), 'empty str, empty array'); + CheckEquals('ABC', StrTrimCharsRight('ABC', []), 'non-empty str, empty array'); + CheckEquals('ABC', StrTrimCharsRight('ABCA', ['A']), 'ABCA str, A array'); + CheckEquals('AB', StrTrimCharsRight('ABCA', ['C', 'A']), 'ABCA str, CA array'); + + CheckEquals('ABC', StrTrimCharsRight('ABCAABA', TrimValidator), 'ABCAABA str, AB validator'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimQuotes; +var + i: Integer; + s, s3, s4: string; +begin + CheckEquals(StrTrimQuotes(''),'','StrTrimQuotes'); + CheckEquals(StrTrimQuotes('""'),'','StrTrimQuotes'); + CheckEquals(StrTrimQuotes(''''''),'','StrTrimQuotes'); + + CheckEquals(StrTrimQuotes('""TEST""'),'"TEST"','StrTrimQuotes'); + CheckEquals(StrTrimQuotes('''''TEST'''''),'''TEST''','StrTrimQuotes'); + + GenerateAll(200,100,StringArray); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + s3 := StrDoubleQuote(s); + s4 := StrSingleQuote(s); + + CheckEquals(StrTrimQuotes(s3),s,'StrTrimQuotes'); + CheckEquals(StrTrimQuotes(s4),s,'StrTrimQuotes'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrUpper_StrUpperInPlace_StrUpperBuff; +var + i: Integer; + s4, s, s3: string; + +begin + GenerateAll(200,200,StringArray); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S3 := AnsiUpperCase(s); + S4 := S; + StrUpperInPlace(S4); + CheckEquals(StrUpper(S), S3, 'StrUpper'); + CheckEquals(S4, S3, 'StrUpperInPlace'); + + S4 := S; + StrUpperBuff(PChar(S4)); + CheckEquals(S4, S3, 'StrUpperBuff'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +//================================================================================================== +// String Managment +//================================================================================================== + +procedure TJclStringManagment.StringManagement; +{$IFNDEF SUPPORTS_UNICODE} +{$IFDEF KEEP_DEPRECATED} +var + s1: string; +{$ENDIF KEEP_DEPRECATED} +{$ENDIF !SUPPORTS_UNICODE} + +begin +{$IFNDEF SUPPORTS_UNICODE} +{$IFDEF KEEP_DEPRECATED} + StrAddRef(s1); + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 0,'StrRefCount'); + + s1 := 'test'; + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 2,'StrRefCount'); + + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 4,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 3,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 2,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 1,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 0,'StrRefCount'); +{$ELSE !KEEP_DEPRECATED} + Check(True, 'Ignored because KEEP_DEPRECATED not defined'); +{$ENDIF KEEP_DEPRECATED} +{$ELSE SUPPORT_UNICODE} + Check(True, 'Ignored because SUPPORT_UNICODE is defined'); +{$ENDIF !SUPPORTS_UNICODE} +end; + +//================================================================================================== +// String Search and Replace +//================================================================================================== + +procedure TJclStringSearchandReplace.AddCheck(const s1, s2: string; const res: Integer); +begin + StringArray[fillIdx] := s1; + StringArray2[fillIdx] := s2; + ResultArray[fillIdx] := res; + Inc(fillIdx); +end; + +function TJclStringSearchandReplace.NormalizeCompareResult(res: Integer): Integer; +begin + if res < 0 then + Result := -1 + else + if res > 0 then + Result := 1 + else + Result := 0; +end; + +procedure TJclStringSearchandReplace.TestCompare(idx: Integer; res: Integer; msgFmt: string); +begin + CheckEquals(ResultArray[idx], res, Format('[%d] ' + msgFmt, [idx, QuotedStr(StringArray[idx]), QuotedStr(StringArray2[idx])])); +end; + +procedure TJclStringSearchandReplace._CompareNaturalStr; +var + idx: Integer; + s1: string; + s2: string; +begin + fillIdx := 0; + + // mixed strings, whitespace ignoring for number components only + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi Highlander', 'Delphi 2005', 1); + AddCheck('Delphi Highlander', 'Delphi Highlander', 1); + AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); + AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 1); // case-sensitivity test + + // version/revision numbering schemes + AddCheck('1.2', '1.10', -1); + AddCheck('1.20', '1.3a', 1); + AddCheck('1.1.1', '1.1', 1); + AddCheck('1.1', '1.1a', -1); + AddCheck('1.1.a', '1.1a', -1); + AddCheck('a', '1', 1); + AddCheck('a', 'b', -1); + AddCheck('1', '2', -1); + + // leading zeroes overrule normal number comparisons + AddCheck('0002', '1', -1); + AddCheck('1.5', '1.06', 1); + + // hyphen binds looser than period (technically compares a number against a non-number component) + AddCheck('1-2', '1-1', 1); + AddCheck('1-2', '1.2', -1); + + // handling of positive/negative number comparisons + AddCheck('0', '-5', 1); + AddCheck('-5', '+2', -1); + + for idx := 0 to fillIdx - 1 do + begin + s1 := StringArray[idx]; + s2 := StringArray2[idx]; + TestCompare(idx, NormalizeCompareResult(CompareNaturalStr(s1, s2)), 'CompareNaturalStr(%s, %s)'); + end; +end; + +procedure TJclStringSearchandReplace._CompareNaturalText; +var + idx: Integer; +begin + fillIdx := 0; + + // mixed strings, whitespace ignoring for number components only + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi Highlander', 'Delphi 2005', 1); + AddCheck('Delphi Highlander', 'Delphi Highlander', 1); + AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); + AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 0); // case-sensitivity test + + // version/revision numbering schemes + AddCheck('1.2', '1.10', -1); + AddCheck('1.20', '1.3a', 1); + AddCheck('1.1.1', '1.1', 1); + AddCheck('1.1', '1.1a', -1); + AddCheck('1.1.a', '1.1a', -1); + AddCheck('a', '1', 1); + AddCheck('a', 'b', -1); + AddCheck('1', '2', -1); + + // leading zeroes overrule normal number comparisons + AddCheck('0002', '1', -1); + AddCheck('1.5', '1.06', 1); + + // hyphen binds looser than period (technically compares a number against a non-number component) + AddCheck('1-2', '1-1', 1); + AddCheck('1-2', '1.2', -1); + + // handling of positive/negative number comparisons + AddCheck('0', '-5', 1); + AddCheck('-5', '+2', -1); + + for idx := 0 to fillIdx - 1 do + TestCompare(idx, NormalizeCompareResult(CompareNaturalText(StringArray[idx], StringArray2[idx])), 'CompareNaturalText(%s, %s)'); +end; + +procedure TJclStringSearchandReplace._StrCharCount; +var + s: string; + ca, t, i: Integer; + c: char; + +begin + CheckEquals(StrCharCount('','x'),0,'StrCharCount'); + CheckEquals(StrCharCount('Test',#0),0,'StrCharCount'); + CheckEquals(StrCharCount('Test','T'),1,'StrCharCount'); + CheckEquals(StrCharCount('Test','t'),1,'StrCharCount'); + CheckEquals(StrCharCount('TestTT','T'),3,'StrCharCount'); + CheckEquals(StrCharCount('Ttetstt','t'),4,'StrCharCount'); + + GenerateAll(500,100,StringArray, True); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + + for c := #1 to #255 do + begin + ca := 0; + + for t := 1 to length(s) do + begin + if s[t] = c then + inc(ca); + end; + + CheckEquals(StrCharCount(s,c),ca,'StrCharCount'); + end; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCharsCount; +begin + CheckEquals(StrCharsCount('',['x']),0,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',[#0]),0,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',['T']),1,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',['t']),1,'StrCharsCount'); + CheckEquals(StrCharsCount('TestTT',['T']),3,'StrCharsCount'); + CheckEquals(StrCharsCount('Ttetstt',['t']),4,'StrCharsCount'); + CheckEquals(StrCharsCount('Ttetstt',['t','T']),5,'StrCharsCount'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrStrCount; +begin + CheckEquals(1, StrStrCount('Test', 'Test'), 'StrStrCount_1'); + CheckEquals(2, StrStrCount('TestTest', 'Test'), 'StrStrCount_2'); + CheckEquals(0, StrStrCount('Test', 'Quark'), 'StrStrCount_3'); + CheckEquals(0, StrStrCount('', 'Quark'), 'StrStrCount_4'); + CheckEquals(0, StrStrCount('', ''), 'StrStrCount_5'); + CheckEquals(0, StrStrCount('Test', ''), 'StrStrCount_6'); + CheckEquals(0, StrStrCount('Test', 'TEST'), 'StrStrCount_7'); // Case sensive ? + CheckEquals(0, StrStrCount('', 'Test'), 'StrStrCount_8'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCompare; +var + i, t: Integer; + S, S1, S2: String; + +begin + CheckEquals(StrCompare('',''),0,'StrCompare'); + CheckEquals(StrCompare('jedi','jedi'),0,'StrCompare'); + CheckEquals(StrCompare('jedi','je'),2,'StrCompare'); + CheckEquals(StrCompare('di','jedi'),-2,'StrCompare'); + CheckEquals(StrCompare('project jedi','jedi'),8,'StrCompare'); + CheckEquals(StrCompare('jedi','judi'),Ord('e') - Ord('u'),'StrCompare'); + CheckEquals(StrCompare('JEDI','Judi'),Ord('e') - Ord('u'),'StrCompare'); + + GenerateAll(600,200,StringArray); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S1 := S; + CheckEquals(StrCompare(S,S1),0,'StrCompare'); + CheckEquals(StrCompare(S,S),0,'StrCompare'); + end; + + GenerateAll(600,1000,StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S1 := StringArray[199+i]; + + if Length(S) = Length(S1) then + S1 := S1 + 'x'; + + CheckEquals(StrCompare(S,S1),Length(S) - Length(S1),'StrCompare'); + CheckEquals(StrCompare(S1,S),Length(S1) - Length(S),'StrCompare'); + end; + + GenerateAll(600,2000,StringArray); + GenerateAll(1,1000,StringArray2); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S2 := S; + + S1 := StringArray[i]; + t := random(Length(S)); + + while s1 = S[1 + t] do + t := random(Length(S)); + + S[1+t] := Char(s1[1]); + CheckEquals(StrCompare(S2,S), ord(CharLower(S2[1+t])) - ord(CharLower(S[1+t])) ,'StrCompare'); + CheckEquals(StrCompare(S,S2), ord(CharLower(S[1+t])) - ord(CharLower(S2[1+t])) ,'StrCompare'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCompareRange; +begin + CheckEquals(0, StrCompareRange('', '', 1, 0), 'StrCompareRange1'); + CheckEquals(0, StrCompareRange('Test1234', 'Test', 1, 4), 'StrCompareRange5'); + CheckEquals(0, StrCompareRange('Test1234', 'Test1234', 1, 25), 'StrCompareRange6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrFillChar; + + procedure TestCombo(ch: Char; res: string); + var + s: array[0..79] of Char; + str: string; + begin + StrFillChar(s, Length(res), ch); + s[Length(res)] := #0; + str := s; + CheckEquals(res, s, 'StrFillChar ' + IntToStr(Length(res)) + '*' + ch); + end; + +begin + TestCombo('a', ''); + TestCombo('a', 'a'); + TestCombo('a', 'aa'); + TestCombo('b', 'bbbb'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrFind; +begin + CheckEquals(0, StrFind('abc', 'Test'), 'StrFind_1'); + CheckEquals(1, StrFind('Test', 'Test'), 'StrFind_2'); + CheckEquals(1, StrFind('Test', 'test'), 'StrFind_3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrHasPrefix; +begin + CheckEquals(False, StrHasPrefix('', []), 'StrHasPrefix1'); + CheckEquals(False, StrHasPrefix('', ['TEST']), 'StrHasPrefix2'); + CheckEquals(False, StrHasPrefix('', ['TEST', 'TEST2']), 'StrHasPrefix3'); + CheckEquals(False, StrHasPrefix('Test', ['TEST', 'TEST2']), 'StrHasPrefix4'); + CheckEquals(True, StrHasPrefix('Test2', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix5'); + CheckEquals(True, StrHasPrefix('Test12345', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix6'); + CheckEquals(True, StrHasPrefix('Test21234', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIHasPrefix; +begin + CheckEquals(False, StrIHasPrefix('', []), 'StrIHasPrefix1'); + CheckEquals(False, StrIHasPrefix('', ['TEST']), 'StrIHasPrefix2'); + CheckEquals(False, StrIHasPrefix('', ['TEST', 'TEST2']), 'StrIHasPrefix3'); + CheckEquals(True, StrIHasPrefix('Test', ['TEST', 'TEST2']), 'StrIHasPrefix4'); + CheckEquals(True, StrIHasPrefix('Test2', ['TEST', 'TEST2']), 'StrIHasPrefix5'); + CheckEquals(True, StrIHasPrefix('Test12345', ['TEST', 'TEST2']), 'StrIHasPrefix6'); + CheckEquals(True, StrIHasPrefix('Test21234', ['TEST', 'TEST2']), 'StrIHasPrefix7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIndex; +begin + CheckEquals(-1, StrIndex('', ['A', 'B']), 'Empty string in array of AB'); + CheckEquals(-1, StrIndex('A', []), '''A'' string in empty array'); + CheckEquals(0, StrIndex('A', ['A', 'B']), '''A'' string in array of AB, equal case'); + CheckEquals(0, StrIndex('a', ['A', 'B']), '''A'' string in array of AB, differing case'); + CheckEquals(1, StrIndex('B', ['A', 'B']), '''B'' string in array of AB, equal case'); + CheckEquals(2, StrIndex('C', ['A', 'B', 'C', 'C']), '''C'' string in array of ABCC, equal case'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrILastPos; +begin + CheckEquals(10, StrILastPos('A', 'aaaaaaaaaa'), 'StrILastPos_1'); + CheckEquals(16, StrILastPos('abA', 'aabaaababababababa'), 'StrILastPos_2'); + CheckEquals(8, StrILastPos('abbA', 'abbaabbabba'), 'StrILastPos_3'); + CheckEquals(0, StrILastPos('_abba', 'abbaabbabba'), 'StrILastPos_4'); + CheckEquals(5, StrILastPos('_aBBa', 'abba_abbabba'), 'StrILastPos_5'); + CheckEquals(15, StrILastPos('ABA', 'aabaaaABAbabababa'), 'StrILastPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIPos; +begin + CheckEquals(1, StrIPos('A', 'aaaaaaaaaa'), 'StrIPos_1'); + CheckEquals(2, StrIPos('abA', 'aabaaababababababa'), 'StrIPos_2'); + CheckEquals(1, StrIPos('abbA', 'abbaabbabba'), 'StrIPos_3'); + CheckEquals(0, StrIPos('_abba', 'abbaabbabba'), 'StrIPos_4'); + CheckEquals(5, StrIPos('_aBBa', 'abba_abbabba'), 'StrIPos_5'); + CheckEquals(2, StrIPos('ABA', 'aabaaaABAbabababa'), 'StrIPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIPrefixIndex; +begin + CheckEquals(0, StrIPrefixIndex('Project',['Pro']), 'StrIPrefixIndex1'); + CheckEquals(0, StrIPrefixIndex('Project',['Pro','Con']), 'StrIPrefixIndex2'); + CheckEquals(0, StrIPrefixIndex('Project',['']), 'StrIPrefixIndex3'); + CheckEquals(1, StrIPrefixIndex('Project',['Con','Pro']), 'StrIPrefixIndex4'); + CheckEquals(1, StrIPrefixIndex('Project',['Con','PRO']), 'StrIPrefixIndex5'); + CheckEquals(-1, StrIPrefixIndex('Project',['Con','PRA']), 'StrIPrefixIndex5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIsOneOf; +begin + CheckEquals(True, StrIsOneOf('Test', ['a','atest','Test', 'Fest']), 'StrIsOneOf_1'); + CheckEquals(False, StrIsOneOf('Test', ['a','atest', 'Fest']), 'StrIsOneOf_2'); + CheckEquals(False, StrIsOneOf('', ['a','atest', 'Fest']), 'StrIsOneOf_3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrLastPos; +begin + CheckEquals(10, StrLastPos('a', 'aaaaaaaaaa'), 'StrLastPos_1'); + CheckEquals(16, StrLastPos('aba', 'aabaaababababababa'), 'StrLastPos_2'); + CheckEquals(8, StrLastPos('abba', 'abbaabbabba'), 'StrLastPos_3'); + CheckEquals(0, StrLastPos('_abba', 'abbaabbabba'), 'StrLastPos_4'); + CheckEquals(5, StrLastPos('_abba', 'abba_abbabba'), 'StrLastPos_5'); + CheckEquals(7, StrLastPos('ABA', 'aabaaaABAbabababa'), 'StrLastPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrMatch; +begin + CheckEquals(0, StrMatch('', 'Test', 1), 'StrMatch_1'); + CheckEquals(1, StrMatch('Test', 'Test', 1), 'StrMatch_2'); + CheckEquals(2, StrMatch('Test', 'aTest', 1), 'StrMatch_3'); + CheckEquals(3, StrMatch('Test', 'abTest', 1), 'StrMatch_4'); + CheckEquals(4, StrMatch('Test', 'abcTest', 1), 'StrMatch_5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrNPos; +begin + CheckEquals(0, StrNPos('testtesttest','Test',3)); // case sensitive test + CheckEquals(9, StrNPos('TestTestTest','Test',3)); + + CheckEquals(1, StrNPos('Test','Test',1), 'StrNPos_1'); + CheckEquals(0, StrNPos('Test','Test',0), 'StrNPos_2'); + CheckEquals(0, StrNPos('Test','Test',-1), 'StrNPos_3'); + CheckEquals(5, StrNPos('TestTest','Test',2), 'StrNPos_4'); + CheckEquals(0, StrNPos('Testtest','Test',2), 'StrNPos_5'); + CheckEquals(3, StrNPos('__Test__','Test',1), 'StrNPos_6'); + CheckEquals(9, StrNPos('__Test__Test','Test',2), 'StrNPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrMatches; +begin + //CheckEquals(False, StrMatches('','Test',1), 'StrMatches_1'); + CheckEquals(True, StrMatches('Test','Test',1), 'StrMatches_2'); + CheckEquals(True, StrMatches('Test','aTest',2), 'StrMatches_3'); + CheckEquals(False, StrMatches('Test','abTest',1), 'StrMatches_4'); + CheckEquals(False, StrMatches('Test','abcTest',1), 'StrMatches_5'); + CheckEquals(True, StrMatches('T?st', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T??t', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T*', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T*st', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T*st', 'Tett'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T???', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T???', 'Tes'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T?*', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T?*', 'T'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T?s?', 'Test'), 'StrMatches_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrNIPos; +begin + CheckEquals(5, StrNIPos('aaaaaaaaaa', 'A', 5), 'StrNIPos_1'); + CheckEquals(0, StrNIPos('aabaaababababababa', 'abA', 0), 'StrNIPos_2'); + CheckEquals(0, StrNIPos('abbaabbabba', 'abbA', 4), 'StrNIPos_3'); + CheckEquals(8, StrNIPos('abbaabbabba', 'abba', 3), 'StrNIPos_4'); + CheckEquals(5, StrNIPos('abba_abbabba', '_aBBa', 1), 'StrNIPos_5'); + CheckEquals(11, StrNIPos('aabaaaABAbabababa', 'ABA', 4), 'StrNIPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrPrefixIndex; +begin + CheckEquals(0, StrPrefixIndex('Project',['Pro']), 'StrPrefixIndex1'); + CheckEquals(0, StrPrefixIndex('Project',['Pro','Con']), 'StrPrefixIndex2'); + CheckEquals(0, StrPrefixIndex('Project',['']), 'StrPrefixIndex3'); + CheckEquals(1, StrPrefixIndex('Project',['Con','Pro']), 'StrPrefixIndex4'); + CheckEquals(-1, StrPrefixIndex('Project',['Con','PRO']), 'StrPrefixIndex5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrSearch; +begin + CheckEquals(StrSearch('', '', 1), 0, 'StrSearch_1'); + CheckEquals(StrSearch('Test', 'Test', 1), 1, 'StrSearch_2'); + CheckEquals(StrSearch('Test', 'Test12', 1), 1, 'StrSearch_3'); + CheckEquals(StrSearch('Test', 'Test123', 1), 1, 'StrSearch_4'); + CheckEquals(StrSearch('Test', 'abTest123', 1), 3, 'StrSearch_5'); + CheckEquals(StrSearch('Test', 'abTest123', 3), 3, 'StrSearch_6'); + CheckEquals(StrSearch('Test', 'abTaest123', 3), 0, 'StrSearch_7'); + CheckEquals(StrSearch('Test', 'abT', 4), 0, 'StrSearch_8'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharEqualNoCase; +var + c1, c2: char; + +begin + for c1 := #0 to #255 do + for c2 := #0 to #255 do + Check(CharEqualNoCase(c1,c2) = (AnsiUpperCase(C1) = AnsiUpperCase(C2)),Format('CharEqualNoCase: C1: %s C2: %s',[c1,c2])); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsAlpha; +var + C: char; +begin + for C := #0 to #255 do + CheckEquals( + isalpha(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #181, #186, #192 .. #214, + #216 .. #246, #248 .. #255]), + CharIsAlpha(C), + 'CharIsAlpha #' + IntToStr(Ord(C))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsAlphaNum; +var + C: char; +begin + for C := #0 to #255 do + CheckEquals( + isalnum(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #178, #179, #181, #185, #186, + #192 .. #214, #216 .. #246, #248 .. #255]), + CharIsAlphaNum(C) , + 'CharIsAlphaNum #' + IntToStr(Ord(C))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsBlank; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#9, ' ', #160]), + CharIsBlank(c1), + 'CharIsBlank #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsControl; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), + CharIsControl(c1), + 'CharIsControl #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsDelete; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals((ord(c1) = 8), CharIsDelete(c1), 'CharIsDelete #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsDigit; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['0'..'9', #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), + CharIsDigit(c1), + 'CharIsDigit #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsNumberChar; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['0'..'9', '+', '-', DecimalSeparator, #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), + CharIsNumberChar(c1), + 'CharIsNumberChar #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsPrintable; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + not (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), + CharIsPrintable(c1), + 'CharIsPrintable #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsPunctuation; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#123..#126, #130, #132 .. #135, #137, #139, #145 .. #151, #155, #161 .. #191, #215, #247, + #91..#96, #38..#47, '@', #60..#63, '#','$','%','"','.',',','!',':','=',';']), + CharIsPunctuation(c1), + 'CharIsPunctuation #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsReturn; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals(((c1 = #13) or (c1 = #10)), CharIsReturn(c1), 'CharIsReturn #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsSpace; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + c1 in [#9, #10, #11, #12, #13, ' ', #160], + CharIsSpace(c1), + 'CharIsSpace #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsWhiteSpace; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [NativeTab, NativeLineFeed, NativeVerticalTab, NativeFormFeed, NativeCarriageReturn, NativeSpace]), + CharIsWhiteSpace(c1), + 'CharIsWhiteSpace #' + IntToStr(Ord(c1)) + ); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsUpper; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['A'..'Z', #138, #140, #142, #159, #192 .. #214, #216 .. #222]), + CharIsUpper(c1), + 'CharIsUpper #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsLower; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['a' .. 'z', #131, #154, #156, #158, #170, #181, #186, #223 .. #246, #248 .. #255]), + CharIsLower(c1), + 'CharIsLower #' + IntToStr(Ord(c1))); +end; + + +//================================================================================================== +// String Extraction +//================================================================================================== + +procedure TJclStringExtraction._StrAfter; +begin + CheckEquals(StrAfter('',''),'','StrAfter'); + CheckEquals(StrAfter('Hello', 'Hello World'),' World','StrAfter'); + CheckEquals(StrAfter('Hello ', 'Hello World'),'World','StrAfter'); + CheckEquals(StrAfter('is a ', 'This is a test.'),'test.','StrAfter'); + CheckEquals(StrAfter('is a ', 'This is a test. is a test'),'test. is a test','StrAfter'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrBefore; +begin + CheckEquals(StrBefore('',''),'','StrBefore'); + CheckEquals(StrBefore('World', 'Hello World'),'Hello ','StrBefore'); + CheckEquals(StrBefore('Hello ', 'Hello World'),'','StrBefore'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrBetween; +begin + CheckEquals('', StrBetween('', Char(#0), Char(#0)), 'StrBetween1'); + CheckEquals('', StrBetween('', Char(#0), Char(#1)), 'StrBetween2'); + CheckEquals('Test', StrBetween('aTestb', Char('a'), Char('b')), 'StrBetween3'); + CheckEquals('Test', StrBetween(' Test ', Char(' '), Char(' ')), 'StrBetween4'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrChopRight; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrChopRight('',i),'','StrChopRight'); + + CheckEquals(StrChopRight('Project JEDI',1),'Project JED','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',2),'Project JE','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',3),'Project J','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',4),'Project ','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',5),'Project','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',15),'','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',50),'','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',-5),'Project JEDI','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',-50),'Project JEDI','StrChopRight'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrLeft; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrLeft('',i),'','StrLeft'); + + CheckEquals(StrLeft('Project JEDI',0),'','StrLeft'); + CheckEquals(StrLeft('Project JEDI',1),'P','StrLeft'); + CheckEquals(StrLeft('Project JEDI',3),'Pro','StrLeft'); + CheckEquals(StrLeft('Project JEDI',5),'Proje','StrLeft'); + CheckEquals(StrLeft('Project JEDI',-5),'','StrLeft'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrMid; +begin + CheckEquals(StrMid('Test',1,4),'Test','StrLeft'); + CheckEquals(StrMid('Test',1,3),'Tes','StrLeft'); + CheckEquals(StrMid('Test',1,2),'Te','StrLeft'); + CheckEquals(StrMid('Test',1,1),'T','StrLeft'); + CheckEquals(StrMid('Test',1,-1),'','StrLeft'); + CheckEquals(StrMid('Test',1,0),'','StrLeft'); + CheckEquals(StrMid('Test',2,0),'','StrLeft'); + CheckEquals(StrMid('Test',2,4),'est','StrLeft'); + CheckEquals(StrMid('Test',2,3),'est','StrLeft'); + CheckEquals(StrMid('Test',2,2),'es','StrLeft'); + CheckEquals(StrMid('Test',2,1),'e','StrLeft'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrRight; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrRight('',i),'','StrRight'); + + CheckEquals(StrRight('Test',1),'t','StrRight'); + CheckEquals(StrRight('Test',2),'st','StrRight'); + CheckEquals(StrRight('Test',3),'est','StrRight'); + CheckEquals(StrRight('Test',4),'Test','StrRight'); + CheckEquals(StrRight('Test',8),'Test','StrRight'); + CheckEquals(StrRight('Test',-8),'','StrRight'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrRestOf; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrRestOf('',i),'','StrRestOf'); + + for i := -100 to -1 do + CheckEquals(StrRestOf('Test',i),'Test','StrRestOf'); + + CheckEquals(StrRestOf('Test',1),'Test','StrRestOf'); + CheckEquals(StrRestOf('Test',2),'est','StrRestOf'); + CheckEquals(StrRestOf('Test',3),'st','StrRestOf'); +end; + +//-------------------------------------------------------------------------------------------------- + +(* +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.CharacterTransformationRoutines; +var + i,t : integer; + c1, c2: char; + charhextable: array[0..255] of byte; + +begin + // -- CharHex -- + for i:=0 to 255 do + charhextable[i] := $FF; + + for i := ord('0') to ord('9') do + charhextable[i] := i - ord('0'); + + for i := ord('a') to ord('f') do + charhextable[i] := 10 + i - ord('a'); + + for i := ord('A') to ord('F') do + charhextable[i] := 10 + i - ord('A'); + + for c1 := #0 to #255 do + CheckEquals(CharHex(c1) , charhextable[ord(c1)], 'CharHex'); + + // -- CharLower -- + for c1 := 'A' to 'Z' do + CheckEquals(CharLower(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharLower %s (%d)',[string(c1),ord(c1)])); + + // -- CharUpper -- + for c1 := 'a' to 'z' do + CheckEquals(CharUpper(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharUpper %s (%d)',[string(c1),ord(c1)])); + + // -- CharToggleCase -- + for c1 := 'a' to 'z' do + CheckEquals(CharToggleCase(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); + + for c1 := 'A' to 'Z' do + CheckEquals(CharToggleCase(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.CharacterSearchandReplace; +var + s: string; + Strings: TStringList; + c, c1, c2: char; + index, i, r: Integer; + +begin + Strings := TStringList.Create; + try + Strings.LoadFromFile('Data/charpos.dat'); + + i := 0; + + while i < Strings.Count do + begin + s := Strings.Strings[i]; + c := (Strings.Strings[i+1])[1]; + index := strtoint(Strings.Strings[i+2]); + r := CharPos(s, c, index); + Check(r = strtoint(Strings.Strings[i+3]),Format('CharPos %s %s %d %d ',[s,c,index, r])); + r := CharIPos(s, c, index); + Check(r = strtoint(Strings.Strings[i+4]),Format('CharIPos %s',[s])); + inc(i,5); + end; + + c := #0; + r := CharIPos('',c); + CheckEquals(r , 0,'CharIPos'); + r := CharPos('',c); + CheckEquals(r , 0,'CharPos'); + + // -- CharReplace -- + + Strings.LoadFromFile('Data/charreplace.dat'); + + i := 0; + + while i < Strings.Count - 1 do + begin + s := Strings.Strings[i]; + c1 := (Strings.Strings[i+1])[1]; + c2 := (Strings.Strings[i+2])[1]; + r := strtoint(Strings.Strings[i+3]); + CheckEquals(CharReplace(s,c1,c2), r , 'CharReplace'); + CheckEquals(s, Strings.Strings[i+4] , 'CharReplace'); + inc(i,5); + end; + + SetLength(s,0); + CheckEquals(CharReplace(s,#0,#0) , 0,'CharReplace'); + + finally + Strings.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.PCharVectorRoutines; +var + Strings: TStringList; + Strings2: TStringList; + Vector: PCharVector; + i: Integer; + +begin + // -- StringsToPCharVector -- + Strings := TStringList.Create; + try + Strings2 := TStringList.Create; + + try + for i := 1 to 1000 do + begin + Strings.Add(inttostr(i)) + end; + + StringsToPCharVector(Vector, Strings); + + // -- PCharVectorCount -- + CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); + CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); + + for i := 1001 to 1500 do + begin + Strings.Add(inttostr(i)) + end; + + StringsToPCharVector(Vector, Strings); + + // -- PCharVectorCount -- + CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); + CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); + + // -- PCharVectorToStrings -- + PCharVectorToStrings(Strings2, Vector); + + for i := 0 to 1499 do + begin + CheckEquals(Strings.Strings[i],Strings2.Strings[i],'PCharVectorToStrings'); + end; + + // -- FreePCharVector -- + FreePCharVector(Vector); + CheckEquals(Integer(Vector),0,'FreePCharVector'); + finally + Strings2.Free; + end; + + finally + Strings.Free; + end; + +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.MultiSzRoutines; +var + msz: PChar; + g: TStringList; + nb: Integer; + mszo: PChar; + s: string; + +begin + g := TStringList.Create; + try + g.Add('Project'); + g.Add('JEDI'); + g.Add('RULES!'); + + StringsToMultiSz(Msz, g); + + // Check it in memory + s := 'Project' + #0 + 'JEDI' + #0 + 'RULES!' + #0 + #0; + MsZo := PChar(s); + + CheckEquals(CompareMem(Msz, MszO, 21), True, 'StringsToMultiSz'); + + FreeMultiSz(Msz); + finally + g.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.TStringsManipulation; +var + source, dest: TStringList; + +begin + // -- StrToStrings -- + + // -- StringsToStr -- + + // -- TrimStrings -- + + // -- TrimStringsRight -- + + // -- TrimStringsLeft -- +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.Miscellaneous; +var + S: String; + B: Boolean; + SL: TStringList; + +begin + // -- BooleanToStr -- + B := True; + CheckEquals(BooleanToStr(B) , 'True', 'BooleanToStr(TRUE)'); + CheckEquals(BooleanToStr(not B) , 'False', 'BooleanToStr(FALSE)'); + + // -- FileToString -- + // -- StringToFile -- + + // -- StrToken -- + S := 'Test1;Test2'; + CheckEquals(StrToken(s,';'),'Test1','StrToken'); + CheckEquals(S,'Test2','StrToken'); + + S := ';Test'; + CheckEquals(StrToken(s,';'),'','StrToken'); + CheckEquals(S,'Test','StrToken'); + + S := ';;Test'; + CheckEquals(StrToken(s,';'),'','StrToken'); + CheckEquals(S,';Test','StrToken'); + + // -- StrTokens -- + // -- StrTokenToStrings -- + SL := TStringList.Create; + + S := 'Test1;Test2;Test3;Test4'; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Strings[0],'Test1','StrToken'); + CheckEquals(SL.Strings[1],'Test2','StrToken'); + CheckEquals(SL.Strings[2],'Test3','StrToken'); + CheckEquals(SL.Strings[3],'Test4','StrToken'); + CheckEquals(SL.Count, 4,'StrTokenToStrings'); + + SL.Clear; + S := 'Test1;;Test3;Test4'; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Strings[0],'Test1','StrTokenToStrings'); + CheckEquals(SL.Strings[1],'','StrTokenToStrings'); + CheckEquals(SL.Strings[2],'Test3','StrTokenToStrings'); + CheckEquals(SL.Strings[3],'Test4','StrTokenToStrings'); + CheckEquals(SL.Count, 4,'StrTokenToStrings'); + + SL.Clear; + S := ''; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Count, 0,'StrTokenToStrings'); + SL.Free; + + // -- StrWord -- + // -- StrToFloatSafe -- + // -- StrToIntSafe -- +end; + +*) + +//================================================================================================== +// TabSet +//================================================================================================== + +procedure TJclStringTabSet._CalculatedTabWidth; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; +begin + tabs1 := TJclTabSet.Create([4,8], True); + try + CheckEquals(0, tabs1.TabWidth, 'tabs1.TabWidth'); + CheckEquals(4, tabs1.ActualTabWidth, 'tabs1.ActualTabWidth'); + finally + FreeAndNil(tabs1); + end; + + tabs2 := TJclTabSet.Create([4,7], False, -1); + try + CheckEquals(-1, tabs2.TabWidth, 'tabs2.TabWidth'); + CheckEquals(3, tabs2.ActualTabWidth, 'tabs2.ActualTabWidth'); + finally + FreeAndNil(tabs2); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Clone; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; + + procedure NilClone; + begin + tabs1 := nil; + tabs2 := tabs1.Clone; + try + CheckTrue(tabs2 = nil, 'NilClone: tabs2 = nil'); + finally + FreeAndNil(tabs2); + end; + end; + + procedure NormalClone; + begin + tabs1 := TJclTabSet.Create([4, 8], False, 2); + try + tabs2 := tabs1.Clone; + try + CheckTrue(tabs1 <> tabs2, 'NormalClone: tabs1 <> tabs2'); + CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalClone: .TabWidth'); + CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalClone: .ActualTabWidth'); + CheckEquals(tabs1.Count, tabs2.Count, 'NormalClone: .Count'); + CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalClone: .TabStops[0]'); + CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalClone: .TabStops[1]'); + + // changing values in one reference should not influence the other reference + tabs1.TabWidth := 3; + CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); + + // freeing the first instance should leave the second instance working + FreeAndNil(tabs1); + CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); + finally + FreeAndNil(tabs2); + end; + finally + FreeAndNil(tabs1); + end; + end; + +begin + NilClone; + NormalClone; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Expand; +var + tabs: TJclTabSet; + inp: string; + exp: string; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + inp := 'Test:'#9'LD'#9'A,(HL)'#9'; Read from memory'#13#10+ + #9'LD'#9'B, 100'#13#10 + + #9'CALL'#9'Test2'#13#10+ + #9#9#9'; another comment'; + exp := 'Test: LD A,(HL) ; Read from memory'#13#10 + + ' LD B, 100'#13#10 + + ' CALL Test2'#13#10+ + ' ; another comment'; + CheckEqualsString(exp, tabs.Expand(inp)); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._FromString; +var + tabs: TJclTabSet; +begin + // just a tab width + tabs := TJclTabSet.FromString('+4'); + try + CheckEquals(0, tabs.Count, 'FromString(''+4'').Count'); + CheckEquals(False, tabs.ZeroBased, 'FromString(''+4'').ZeroBased'); + CheckEquals(4, tabs.ActualTabWidth, 'FromString(''+4'').ActualTabWidth'); + CheckEquals(4, tabs.TabWidth, 'FromString(''+4'').TabWidth'); + finally + FreeAndNil(tabs); + end; + + // stops and tab width; with excessive whitespace, including tab + tabs := TJclTabSet.FromString('4, 7 ' + #9 + '+4'); + try + CheckEquals(2, tabs.Count, 'FromString(''4, 7 '' + #9 + ''+4'').Count'); + CheckEquals(4, tabs[0], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[0]'); + CheckEquals(7, tabs[1], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[1]'); + CheckEquals(False, tabs.ZeroBased, 'FromString(''4, 7 '' + #9 + ''+4'').ZeroBased'); + CheckEquals(4, tabs.ActualTabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').ActualTabWidth'); + CheckEquals(4, tabs.TabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').TabWidth'); + finally + FreeAndNil(tabs); + end; + + // zero-based, bracketed stops, auto width + tabs := TJclTabSet.FromString('0[4,7]'); + try + CheckEquals(2, tabs.Count, 'FromString(''0[4,7]'').Count'); + CheckEquals(4, tabs[0], 'FromString(''0[4,7]'').tabs[0]'); + CheckEquals(7, tabs[1], 'FromString(''0[4,7]'').tabs[1]'); + CheckEquals(True, tabs.ZeroBased, 'FromString(''0[4,7]'').ZeroBased'); + CheckEquals(3, tabs.ActualTabWidth, 'FromString(''0[4,7]'').ActualTabWidth'); + CheckTrue(tabs.TabWidth < 1, 'FromString(''0[4,7]'').TabWidth'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._NilSet; +var + tabs: TJclTabSet; +begin + // simplify nil tabset access + tabs := nil; + + // nil tabset should be zero based + CheckTrue(tabs.ZeroBased, 'Nil tabset.ZeroBased'); + + // nil tabset should have no tab stops + CheckEquals(0, tabs.Count, 'Nil tabset.Count'); + + // nil tabset should have an actual tabwidth of 2 + CheckEquals(2, tabs.ActualTabWidth, 'Nil tabset.ActualTabWidth'); + + // nil tabset should have a set tabwidth of <1 or 2 + CheckTrue((tabs.TabWidth = 2) or (tabs.TabWidth < 1), 'Nil tabset.TabWidth'); + + // nil tabset expand test + CheckEquals('A bc de', tabs.Expand('A'#9'bc'#9'de'), 'Nil tabset.Expand') +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._OptimalFill; +var + tabs: TJclTabSet; + tabCount: Integer; + spaceCount: Integer; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + // test 1: tabs and spaces to get from column 1 to column 17 + tabs.OptimalFillInfo(1, 17, tabCount, spaceCount); + CheckEquals(1, tabCount, 'tabCount for column 1->17'); + CheckEquals(0, spaceCount, 'spaceCount for column 1->17'); + + // test 2: tabs and spaces to get from column 1 to column 4 + tabs.OptimalFillInfo(1, 4, tabCount, spaceCount); + CheckEquals(0, tabCount, 'tabCount for column 1->4'); + CheckEquals(3, spaceCount, 'spaceCount for column 1->4'); + + // test 3: tabs and spaces to get from column 1 to column 34 + tabs.OptimalFillInfo(1, 34, tabCount, spaceCount); + CheckEquals(3, tabCount, 'tabCount for column 1->34'); + CheckEquals(2, spaceCount, 'spaceCount for column 1->34'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Optimize; +var + tabs: TJclTabSet; + inp: string; + exp: string; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + inp := ' '#9' test second'; + exp := #9' test'#9#9#9#9#9' second'; + CheckEquals(exp, tabs.Optimize(inp)); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Referencing; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; + + procedure NilReference; + begin + tabs1 := nil; + tabs2 := tabs1.NewReference; + try + CheckTrue(tabs2 = nil, 'NilReference: tabs2 = nil'); + finally + FreeAndNil(tabs2); + end; + end; + + procedure NormalReference; + begin + tabs1 := TJclTabSet.Create([4, 8], False, 2); + try + tabs2 := tabs1.NewReference; + try + CheckTrue(tabs1 <> tabs2, 'NormalReference: tabs1 <> tabs2'); + CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalReference: .TabWidth'); + CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalReference: .ActualTabWidth'); + CheckEquals(tabs1.Count, tabs2.Count, 'NormalReference: .Count'); + CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalReference: .TabStops[0]'); + CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalReference: .TabStops[1]'); + + // changing values in one reference should also occur in the other reference + tabs1.TabWidth := 3; + CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); + + // freeing the first instance should leave the second instance working + FreeAndNil(tabs1); + CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); + finally + FreeAndNil(tabs2); + end; + finally + FreeAndNil(tabs1); + end; + end; + +begin + NilReference; + NormalReference; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabFrom; +var + tabs: TJclTabSet; + idx: Integer; +begin + tabs := TJclTabSet.Create([15, 20, 30], True, 2); + try + // test first fixed stop + // columns 0 through 14 will tab to column 15 + for idx := 0 to 14 do + CheckEquals(15, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test second fixed stop + // columns 15 through 19 will tab to column 20 + for idx := 15 to 19 do + CheckEquals(20, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test third and final fixed stop + // columns 20 through 29 will tab to column 30 + for idx := 20 to 29 do + CheckEquals(30, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test tab width beyond fixed positions + // columns 30 through 39 will tab to column 32 (30-31), 34 (32-33), 36 (34-35), 38 (36-37) or 40 (38-39) + for idx := 30 to 39 do + CheckEquals(2 * Succ(idx div 2), tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopAdding; +var + tabs: TJclTabSet; + x: Integer; + failed: Boolean; +begin + tabs := TJclTabSet.Create([15, 30], True); + try + // Add column 20 and check if the index=1 + CheckEquals(1, tabs.Add(20), 'Index of Add(20)'); + // We should have three stops + CheckEquals(3, tabs.Count, 'Count after Add(20)'); + // The first should be 15 + CheckEquals(15, tabs[0], 'tabs[0]'); + // The second should be 20 + CheckEquals(20, tabs[1], 'tabs[1]'); + // The third should be 30 + CheckEquals(30, tabs[2], 'tabs[2]'); + // Adding a duplicate should fail... + begin + try + x := tabs.Add(30); + failed := True; + except + failed := False; + x := 0; // make compiler happy + end; + if failed then + Fail('tabs.Add(30) returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); + end; + // Adding anything less than StartColumn should fail... + begin + try + x := tabs.Add(tabs.StartColumn - 1); + failed := True; + except + failed := False; + x := 0; + end; + if failed then + Fail('tabs.Add(' + IntToStr(tabs.StartColumn - 1) + ') returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); + end; + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopDeleting; +var + tabs: TJclTabSet; + x: Integer; +begin + tabs := TJclTabSet.Create([15, 17, 20, 30], True, 2); + try + CheckEquals(1, tabs.Delete(17), 'Index of Delete(17)'); + // We should have three stops + CheckEquals(3, tabs.Count, 'Count after Add(20)'); + // The first should be 15 + CheckEquals(15, tabs[0], 'tabs[0]'); + // The second should be 20 + CheckEquals(20, tabs[1], 'tabs[1]'); + // The third should be 30 + CheckEquals(30, tabs[2], 'tabs[2]'); + // Deleting a non-existing tab stop should result in a negative value + x := tabs.Delete(24); + CheckTrue(x < 0, 'tabs.Delete(24) returned ' + IntToStr(x) + '; should''ve returned a negative value.'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopModifying; +var + tabs: TJclTabSet; +begin + tabs := TJclTabSet.Create([15, 17, 2, 30], True, 2); + try + // check tabs array before overwriting the first tab stop... + CheckEquals(2, tabs[0], 'tabs[0] before modify.'); + CheckEquals(15, tabs[1], 'tabs[1] before modify.'); + CheckEquals(17, tabs[2], 'tabs[2] before modify.'); + CheckEquals(30, tabs[3], 'tabs[3] before modify.'); + // overwrite the first tab stop + tabs[0] := 20; + // check tabs array after overwriting the first tab stop... + CheckEquals(15, tabs[0], 'tabs[0] after modify.'); + CheckEquals(17, tabs[1], 'tabs[1] after modify.'); + CheckEquals(20, tabs[2], 'tabs[2] after modify.'); + CheckEquals(30, tabs[3], 'tabs[3] after modify.'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._ToString; +var + tabs: TJclTabSet; +begin + tabs := TJclTabSet.Create([15, 17, 20, 30], True, 4); + try + CheckEquals('0 [15,17,20,30] +4', tabs.ToString, 'zero-based, full'); + CheckEquals('0 15,17,20,30 +4', tabs.ToString(TabSetFormatting_Default), 'zero-based, default'); + tabs.ZeroBased := False; + CheckEquals('[16,18,21,31] +4', tabs.ToString, 'one-based, full'); + CheckEquals('16,18,21,31 +4', tabs.ToString(TabSetFormatting_Default), 'one-based, default'); + finally + tabs.Free; + end; + + tabs := TJclTabSet.FromString(''); // nil; ????????????????? + CheckEquals('0 [] +2', tabs.ToString, 'nil-set, full'); + CheckEquals('0', tabs.ToString(TabSetFormatting_Default), 'nil-set, default'); +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._UpdatePosition; +var + tabs: TJclTabSet; + column: Integer; + line: Integer; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + column := tabs.StartColumn; + line := 1; + tabs.UpdatePosition( + 'Label1:'#9'LD'#9'A,0'#9'; init A'#13#10+ + #9'LD'#9'B, 100'#9'; loop counter'#13#10+ + #13#10+ + 'lp1:'#9'ADD'#9'(HL)'#9'; add data'#13+ + #9'JR'#9'NC,nxt'#9'; no carry=>skip to nxt'#13+ + #13+ + #9'RRCA'#10+ + #10+ + 'nxt:'#9'INC'#9'H'#9'; next scanline'#13#10+ + #9'DJNZ'#9'lp1', column, line); + CheckEquals(10, line, 'line'); + CheckEquals(25, column, 'column'); + finally + tabs.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._ZeroBased; +var + tabs: TJclTabSet; + x: Integer; + failed: Boolean; +begin + tabs := TJclTabSet.Create([15, 20, 30], True, 2); + try + // make sure it's actually zero-based + CheckTrue(tabs.ZeroBased, 'tabset should be zero based.'); + // can we tab from column 0? + CheckEquals(15, tabs.TabFrom(0), 'tabs.TabFrom(0) in zero-based mode.'); + // we should have three stops + CheckEquals(3, tabs.Count, 'tabs.Count (zero-based)'); + // are they 15, 20 and 30 respectively? + CheckEquals(15, tabs[0], 'tabs[0] (zero-based)'); + CheckEquals(20, tabs[1], 'tabs[1] (zero-based)'); + CheckEquals(30, tabs[2], 'tabs[2] (zero-based)'); + + // switch to not zero-based + tabs.ZeroBased := False; + // make sure it's no longer zero-based + CheckFalse(tabs.ZeroBased, 'tabset shouldn''t be zero based.'); + // we still should have three stops + CheckEquals(3, tabs.Count, 'tabs.Count (not zero-based)'); + // are they 16, 21 and 31 respectively? + CheckEquals(16, tabs[0], 'tabs[0] (not zero-based)'); + CheckEquals(21, tabs[1], 'tabs[1] (not zero-based)'); + CheckEquals(31, tabs[2], 'tabs[2] (not zero-based)'); + // we shouldn't be able to tab from column 0? + try + x := tabs.TabFrom(0); + failed := False; + except + // swallow exception + failed := True; + x := 0; // make compiler happy + end; + if not failed then + Fail('tab.TabFrom(0) resulted in ' + IntToStr(x) + '; should''ve resulted in an exception when not in zero-based mode.'); + finally + FreeAndNil(tabs); + end; +end; + +{ TAnsiStringListTest } + +procedure TAnsiStringListTest._GetCommaTextCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextInnerQuotesProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('"World"'); + slRTL.Add('Hello'); + slRTL.Add('"World"'); + CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TAnsiStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextQuotedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('My World'); + slRTL.Add('Hello'); + slRTL.Add('My World'); + CheckEquals('Hello,"My World"', slJCL.CommaText, 'TAnsiStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextSpacedCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World,There!'; + slRTL.CommaText := 'Hello,My World,There!'; + CheckEquals(4, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World'; + slRTL.CommaText := 'Hello,My World'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextFunkyFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextInnerQuotesProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"""World"""'; + slRTL.CommaText := 'Hello,"""World"""'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('"World"', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextQuotedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"World"'; + slRTL.CommaText := 'Hello,"World"'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextQuotedSpacedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World",There!'; + slRTL.CommaText := 'Hello,"My World",There!'; + CheckEquals(3, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=3 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello,"My World"'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello,"My World"'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slJCL.DelimitedText := 'Hello,My World'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + slRTL.DelimitedText := 'Hello,My World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextFunkyFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello-|My World|'; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello-|My World|'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +{ TJclStringListTest } + +procedure TJclStringListTest._GetCommaTextCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextInnerQuotesProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('"World"'); + slRTL.Add('Hello'); + slRTL.Add('"World"'); + CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TJclStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextQuotedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('My World'); + slRTL.Add('Hello'); + slRTL.Add('My World'); + CheckEquals('Hello,"My World"', slJCL.CommaText, 'TJclStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextSpacedCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World,There!'; + slRTL.CommaText := 'Hello,My World,There!'; + CheckEquals(4, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World'; + slRTL.CommaText := 'Hello,My World'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextFunkyFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextInnerQuotesProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"""World"""'; + slRTL.CommaText := 'Hello,"""World"""'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('"World"', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextQuotedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"World"'; + slRTL.CommaText := 'Hello,"World"'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextQuotedSpacedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World",There!'; + slRTL.CommaText := 'Hello,"My World",There!'; + CheckEquals(3, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=3 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello,"My World"'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello,"My World"'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slJCL.DelimitedText := 'Hello,My World'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + slRTL.DelimitedText := 'Hello,My World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextFunkyFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello-|My World|'; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello-|My World|'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SplitJoin; +var slJCL: IJclStringList; +begin + slJCL := TJclStringList.Create; + + CheckEquals(0, slJCL.Count); + slJcl.Add('111'); + slJcl.Add('222'); + CheckEquals(2, slJCL.Count); + slJcl.Split('1111f2222f3333f','f'); + CheckEquals(4, slJCL.Count); + CheckEquals(3, slJCL.LastIndex); + CheckEquals(0, Length(slJCL.Last)); + slJcl.Split('1111f2222f3333f','f', False); + CheckEquals(8, slJCL.Count); + CheckEquals(7, slJCL.LastIndex); + CheckEquals(0, Length(slJCL.Last)); + slJcl.Clear; + CheckEquals(0, slJCL.Count); + CheckEquals('', slJCL.Join('111')); + slJcl.Add('0000'); + CheckEquals('0000', slJCL.Join('222')); + slJcl.Split('1111f2222f3333f','f', False); + slJCL.Delete(slJCL.LastIndex); + CheckEquals('0000a1111a2222a3333', slJCL.Join('a')); +end; + +initialization + + RegisterTest('JCLStrings', TJclStringTransformation.Suite); + RegisterTest('JCLStrings', TJclStringManagment.Suite); + RegisterTest('JCLStrings', TJclStringSearchandReplace.Suite); + RegisterTest('JCLStrings', TJclStringCharacterTestRoutines.Suite); + RegisterTest('JCLStrings', TJclStringExtraction.Suite); + RegisterTest('JCLStrings', TJclStringTabSet.Suite); + RegisterTest('JCLStrings', TAnsiStringListTest.Suite); + RegisterTest('JCLStrings', TJCLStringListTest.Suite); + +// History: +// +// $Log$ +// Revision 1.3 2004/12/05 15:55:32 rrossmair +// - restored D5 compatibility +// + +end. From 774b7151fef8cc99ff861797e964ac83819aedf6 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Thu, 14 Feb 2013 13:22:11 +0400 Subject: [PATCH 09/12] CRLF normalization --- jcl/source/common/JclSimpleXml.pas | 8788 +++++++------- jcl/source/common/JclStringLists.pas | 2924 ++--- jcl/source/common/JclStrings.pas | 11038 +++++++++--------- qa/automated/dunit/JclTests.dpr | 80 +- qa/automated/dunit/units/TestJclMath.pas | 2452 ++-- qa/automated/dunit/units/TestJclStrings.pas | 7486 ++++++------ 6 files changed, 16384 insertions(+), 16384 deletions(-) diff --git a/jcl/source/common/JclSimpleXml.pas b/jcl/source/common/JclSimpleXml.pas index 49ab865b48..fe12300773 100644 --- a/jcl/source/common/JclSimpleXml.pas +++ b/jcl/source/common/JclSimpleXml.pas @@ -1,4395 +1,4395 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 JvSimpleXML.PAS, released on 2002-06-03. } -{ } -{ The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]. } -{ Portions created by Sébastien Buysse are Copyright (C) 2001 Sébastien Buysse. } -{ All Rights Reserved. } -{ } -{ Contributor(s): } -{ Christophe Paris, } -{ Florent Ouchet (move from the JVCL to the JCL) } -{ Teträm } -{ } -{**************************************************************************************************} -{ } -{ This unit contains Xml parser and writter classes } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -// Known Issues: This component does not parse the !DOCTYPE tags but preserves them - -unit JclSimpleXml; - -interface - -{$I jcl.inc} - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF HAS_UNIT_RTLCONSTS} - System.RTLConsts, - {$ENDIF HAS_UNIT_RTLCONSTS} - {$IFDEF MSWINDOWS} - Winapi.Windows, // Delphi 2005 inline - {$ENDIF MSWINDOWS} - System.SysUtils, System.Classes, - System.Variants, - System.IniFiles, - System.Contnrs, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF HAS_UNIT_RTLCONSTS} - RTLConsts, - {$ENDIF HAS_UNIT_RTLCONSTS} - {$IFDEF MSWINDOWS} - Windows, // Delphi 2005 inline - {$ENDIF MSWINDOWS} - SysUtils, Classes, - Variants, - IniFiles, - Contnrs, - {$ENDIF ~HAS_UNITSCOPE} - JclBase, JclStreams; - -type - TJclSimpleItem = class(TObject) - private - FName: string; - protected - procedure SetName(const Value: string); virtual; - public - property Name: string read FName write SetName; - end; - -type - TJclSimpleItemHashedList = class(TObjectList) - private - FNameHash: TStringHash; - FCaseSensitive: Boolean; - function GetSimpleItemByName(const Name: string): TJclSimpleItem; - function GetSimpleItem(Index: Integer): TJclSimpleItem; - procedure SetCaseSensitive(const Value: Boolean); - protected - procedure Notify(Ptr: Pointer; Action: TListNotification); override; - public - constructor Create(ACaseSensitive: Boolean); - destructor Destroy; override; - function Add(Item: TJclSimpleItem): Integer; - procedure Clear; override; - function IndexOfSimpleItem(Item: TJclSimpleItem): Integer; - function IndexOfName(const Name: string): Integer; - procedure Insert(Index: Integer; Item: TJclSimpleItem); - procedure InvalidateHash; - procedure Move(CurIndex, NewIndex: Integer); - property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; - property SimpleItemByNames[const Name: string]: TJclSimpleItem read GetSimpleItemByName; - property SimpleItems[Index: Integer]: TJclSimpleItem read GetSimpleItem; - end; - -type - TJclSimpleData = class(TJclSimpleItem) - private - FValue: string; - FData: Pointer; - protected - function GetBoolValue: Boolean; - procedure SetBoolValue(const Value: Boolean); - function GetFloatValue: Extended; - procedure SetFloatValue(const Value: Extended); - function GetAnsiValue: AnsiString; - procedure SetAnsiValue(const Value: AnsiString); - function GetIntValue: Int64; - procedure SetIntValue(const Value: Int64); - public - constructor Create; overload; virtual; - constructor Create(const AName: string); overload; - constructor Create(const AName, AValue: string); overload; - property Value: string read FValue write FValue; - property AnsiValue: AnsiString read GetAnsiValue write SetAnsiValue; - property IntValue: Int64 read GetIntValue write SetIntValue; - property BoolValue: Boolean read GetBoolValue write SetBoolValue; - property FloatValue: Extended read GetFloatValue write SetFloatValue; - - property Data: Pointer read FData write FData; - end; - -type - TJclSimpleXMLData = class(TJclSimpleData) - private - FNameSpace: string; - public - function FullName:string; - property NameSpace: string read FNameSpace write FNameSpace; - end; - -type - TJclSimpleXML = class; - EJclSimpleXMLError = class(EJclError); - {$TYPEINFO ON} // generate RTTI for published properties - TJclSimpleXMLElem = class; - {$IFNDEF TYPEINFO_ON} - {$TYPEINFO OFF} - {$ENDIF ~TYPEINFO_ON} - TJclSimpleXMLElems = class; - TJclSimpleXMLProps = class; - TJclSimpleXMLElemsProlog = class; - TJclSimpleXMLNamedElems = class; - TJclSimpleXMLElemComment = class; - TJclSimpleXMLElemClassic = class; - TJclSimpleXMLElemCData = class; - TJclSimpleXMLElemDocType = class; - TJclSimpleXMLElemText = class; - TJclSimpleXMLElemHeader = class; - TJclSimpleXMLElemSheet = class; - TJclSimpleXMLElemMSOApplication = class; - TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object; - TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object; - TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; - - //Those hash stuffs are for future use only - //Plans are to replace current hash by this mechanism - TJclHashKind = (hkList, hkDirect); - PJclHashElem = ^TJclHashElem; - TJclHashElem = packed record - Next: PJclHashElem; - Obj: TObject; - end; - PJclHashRecord = ^TJclHashRecord; - TJclHashList = array [0..25] of PJclHashRecord; - PJclHashList = ^TJclHashList; - TJclHashRecord = packed record - Count: Byte; - case Kind: TJclHashKind of - hkList: (List: PJclHashList); - hkDirect: (FirstElem: PJclHashElem); - end; - - TJclSimpleXMLProp = class(TJclSimpleXMLData) - private - FParent: TJclSimpleXMLElem; - protected - function GetSimpleXML: TJclSimpleXML; - procedure SetName(const Value: string); override; - public - constructor Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); - procedure SaveToStringStream(StringStream: TJclStringStream); - property Parent: TJclSimpleXMLElem read FParent; - property SimpleXML: TJclSimpleXML read GetSimpleXML; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLPropsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLProps; - public - constructor Create(AList: TJclSimpleXMLProps); - function GetCurrent: TJclSimpleXMLProp; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLProp read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLProps = class(TObject) - private - FProperties: TStringList; - FParent: TJclSimpleXMLElem; - function GetCount: Integer; - function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; - function GetItemNamed(const Name: string): TJclSimpleXMLProp; - protected - function GetSimpleXML: TJclSimpleXML; - function GetItem(const Index: Integer): TJclSimpleXMLProp; - procedure DoItemRename(Value: TJclSimpleXMLProp; const Name: string); - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - constructor Create(AParent: TJclSimpleXMLElem); - destructor Destroy; override; - function Add(const Name, Value: string): TJclSimpleXMLProp; overload; - {$IFDEF SUPPORTS_UNICODE} - function Add(const Name: string; const Value: AnsiString): TJclSimpleXMLProp; overload; - {$ENDIF SUPPORTS_UNICODE} - function Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; - function Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; - function Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; - procedure Clear; virtual; - procedure Delete(const Index: Integer); overload; - procedure Delete(const Name: string); overload; - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLPropsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - function Value(const Name: string; const Default: string = ''): string; - function IntValue(const Name: string; const Default: Int64 = -1): Int64; - function BoolValue(const Name: string; Default: Boolean = True): Boolean; - function FloatValue(const Name: string; const Default: Extended = 0): Extended; - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream); - property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default; - property ItemNamed[const Name: string]: TJclSimpleXMLProp read GetItemNamed; - property Count: Integer read GetCount; - property Parent: TJclSimpleXMLElem read FParent; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLElemsPrologEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLElemsProlog; - public - constructor Create(AList: TJclSimpleXMLElemsProlog); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLElemsProlog = class(TObject) - private - FElems: TJclSimpleItemHashedList; - function GetCount: Integer; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - function GetEncoding: string; - function GetStandAlone: Boolean; - function GetVersion: string; - procedure SetEncoding(const Value: string); - procedure SetStandAlone(const Value: Boolean); - procedure SetVersion(const Value: string); - protected - FSimpleXML: TJclSimpleXML; - function FindHeader: TJclSimpleXMLElem; - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - constructor Create(ASimpleXML: TJclSimpleXML); - destructor Destroy; override; - function AddComment(const AValue: string): TJclSimpleXMLElemComment; - function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; - procedure Clear; - function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; - function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream); - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property Count: Integer read GetCount; - property Encoding: string read GetEncoding write SetEncoding; - property SimpleXML: TJclSimpleXML read FSimpleXML; - property StandAlone: Boolean read GetStandAlone write SetStandAlone; - property Version: string read GetVersion write SetVersion; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLNamedElemsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLNamedElems; - public - constructor Create(AList: TJclSimpleXMLNamedElems); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLNamedElems = class(TJclSimpleItem) - private - FElems: TJclSimpleXMLElems; - function GetCount: Integer; - protected - FItems: TList; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - procedure SetName(const Value: string); override; - public - constructor Create(AElems: TJclSimpleXMLElems; const AName: string); - destructor Destroy; override; - - function Add: TJclSimpleXMLElemClassic; overload; - function Add(const Value: string): TJclSimpleXMLElemClassic; overload; - function Add(const Value: Int64): TJclSimpleXMLElemClassic; overload; - function Add(const Value: Boolean): TJclSimpleXMLElemClassic; overload; - function Add(Value: TStream): TJclSimpleXMLElemClassic; overload; - function AddFirst: TJclSimpleXMLElemClassic; - function AddComment(const Value: string): TJclSimpleXMLElemComment; - function AddCData(const Value: string): TJclSimpleXMLElemCData; - function AddText(const Value: string): TJclSimpleXMLElemText; - procedure Clear; virtual; - procedure Delete(const Index: Integer); - procedure Move(const CurIndex, NewIndex: Integer); - function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; - function IndexOf(const Value: string): Integer; overload; - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - - property Elems: TJclSimpleXMLElems read FElems; - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property Count: Integer read GetCount; - end; - - {$IFDEF SUPPORTS_FOR_IN} - TJclSimpleXMLElemsEnumerator = class - private - FIndex: Integer; - FList: TJclSimpleXMLElems; - public - constructor Create(AList: TJclSimpleXMLElems); - function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} - function MoveNext: Boolean; - property Current: TJclSimpleXMLElem read GetCurrent; - end; - {$ENDIF SUPPORTS_FOR_IN} - - TJclSimpleXMLElemCompare = function(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer of object; - TJclSimpleXMLElems = class(TObject) - private - FParent: TJclSimpleXMLElem; - function GetCount: Integer; - function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; - function GetItemNamed(const Name: string): TJclSimpleXMLElem; - function GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; - protected - FElems: TJclSimpleItemHashedList; - FCompare: TJclSimpleXMLElemCompare; - FNamedElems: TJclSimpleItemHashedList; - function GetItem(const Index: Integer): TJclSimpleXMLElem; - procedure AddChild(const Value: TJclSimpleXMLElem); - procedure AddChildFirst(const Value: TJclSimpleXMLElem); - procedure InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); - procedure DoItemRename(Value: TJclSimpleXMLElem; const Name: string); - procedure CreateElems; - function SimpleCompare(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer; - public - constructor Create(AParent: TJclSimpleXMLElem); - destructor Destroy; override; - - // Use notify to indicate to a list that the given element is removed - // from the list so that it doesn't delete it as well as the one - // that insert it in itself. This method is automatically called - // by AddChild and AddChildFirst if the Container property of the - // given element is set. - procedure Notify(Value: TJclSimpleXMLElem; Operation: TOperation); - - function Add(const Name: string): TJclSimpleXMLElemClassic; overload; - function Add(const Name, Value: string): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; overload; - function Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; overload; - function Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; - function AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; - function AddFirst(const Name: string): TJclSimpleXMLElemClassic; overload; - function AddComment(const Name: string; const Value: string): TJclSimpleXMLElemComment; - function AddCData(const Name: string; const Value: string): TJclSimpleXMLElemCData; - function AddText(const Name: string; const Value: string): TJclSimpleXMLElemText; - function Insert(Value: TJclSimpleXMLElem; Index: Integer): TJclSimpleXMLElem; overload; - function Insert(const Name: string; Index: Integer): TJclSimpleXMLElemClassic; overload; - procedure Clear; virtual; - procedure Delete(const Index: Integer); overload; - procedure Delete(const Name: string); overload; - function Remove(Value: TJclSimpleXMLElem): Integer; - procedure Move(const CurIndex, NewIndex: Integer); - {$IFDEF SUPPORTS_FOR_IN} - function GetEnumerator: TJclSimpleXMLElemsEnumerator; - {$ENDIF SUPPORTS_FOR_IN} - function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; - function IndexOf(const Name: string): Integer; overload; - function Value(const Name: string; const Default: string = ''): string; - function IntValue(const Name: string; const Default: Int64 = -1): Int64; - function FloatValue(const Name: string; const Default: Extended = 0): Extended; - function BoolValue(const Name: string; Default: Boolean = True): Boolean; - procedure BinaryValue(const Name: string; Stream: TStream); - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); - procedure Sort; - procedure CustomSort(AFunction: TJclSimpleXMLElemCompare); - property Parent: TJclSimpleXMLElem read FParent; - property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; - property ItemNamed[const Name: string]: TJclSimpleXMLElem read GetItemNamed; - property Count: Integer read GetCount; - property NamedElems[const Name: string]: TJclSimpleXMLNamedElems read GetNamedElems; - end; - - {$TYPEINFO ON} - TJclSimpleXMLElem = class(TJclSimpleXMLData) - private - FParent: TJclSimpleXMLElem; - FSimpleXML: TJclSimpleXML; - function GetHasItems: Boolean; - function GetHasProperties: Boolean; - function GetItemCount: Integer; - function GetPropertyCount: Integer; - protected - FItems: TJclSimpleXMLElems; - FProps: TJclSimpleXMLProps; - function GetChildsCount: Integer; - function GetProps: TJclSimpleXMLProps; - procedure SetName(const Value: string); override; - function GetItems: TJclSimpleXMLElems; - procedure Error(const S: string); - procedure FmtError(const S: string; const Args: array of const); - public - //constructor Create; overload; - //constructor Create(const AName: string); overload; - //constructor Create(const AName, AValue: string); overload; - constructor Create(ASimpleXML: TJclSimpleXML); overload; - destructor Destroy; override; - procedure Assign(Value: TJclSimpleXMLElem); virtual; - procedure Clear; virtual; - procedure LoadFromStringStream(StringStream: TJclStringStream); virtual; abstract; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); virtual; - abstract; - procedure LoadFromString(const Value: string); - function SaveToString: string; - procedure GetBinaryValue(Stream: TStream); - function GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; - function GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; - - property SimpleXML: TJclSimpleXML read FSimpleXML; - published - property Parent: TJclSimpleXMLElem read FParent; - property ChildsCount: Integer read GetChildsCount; - property HasItems: Boolean read GetHasItems; - property HasProperties: Boolean read GetHasProperties; - property ItemCount: Integer read GetItemCount; - property PropertyCount: Integer read GetPropertyCount; - property Items: TJclSimpleXMLElems read GetItems; - property Properties: TJclSimpleXMLProps read GetProps; - end; - {$IFNDEF TYPEINFO_ON} - {$TYPEINFO OFF} - {$ENDIF ~TYPEINFO_ON} - TJclSimpleXMLElemClass = class of TJclSimpleXMLElem; - - TJclSimpleXMLElemComment = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemClassic = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemCData = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemText = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemProcessingInstruction = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLElemHeader = class(TJclSimpleXMLElemProcessingInstruction) - private - function GetEncoding: string; - function GetStandalone: Boolean; - function GetVersion: string; - procedure SetEncoding(const Value: string); - procedure SetStandalone(const Value: Boolean); - procedure SetVersion(const Value: string); - public - constructor Create; override; - - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - property Version: string read GetVersion write SetVersion; - property StandAlone: Boolean read GetStandalone write SetStandalone; - property Encoding: string read GetEncoding write SetEncoding; - end; - - // for backward compatibility - TJclSimpleXMLElemSheet = class(TJclSimpleXMLElemProcessingInstruction) - end; - - // for backward compatibility - TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElemProcessingInstruction) - end; - - TJclSimpleXMLElemDocType = class(TJclSimpleXMLElem) - public - procedure LoadFromStringStream(StringStream: TJclStringStream); override; - procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; - end; - - TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue, - sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace, - sxoTrimFollowingTextWhitespace, sxoKeepWhitespace, sxoDoNotSaveBOM, sxoCaseSensitive); - TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object; - TJclSimpleXMLEncodeStreamEvent = procedure(Sender: TObject; InStream, OutStream: TStream) of object; - - TJclSimpleXML = class(TObject) - protected - FEncoding: TJclStringEncoding; - FCodePage: Word; - FFileName: TFileName; - FOptions: TJclSimpleXMLOptions; - FRoot: TJclSimpleXMLElemClassic; - FOnTagParsed: TJclOnSimpleXMLParsed; - FOnValue: TJclOnValueParsed; - FOnLoadProg: TJclOnSimpleProgress; - FOnSaveProg: TJclOnSimpleProgress; - FProlog: TJclSimpleXMLElemsProlog; - FSaveCount: Integer; - FSaveCurrent: Integer; - FIndentString: string; - FBaseIndentString: string; - FOnEncodeValue: TJclSimpleXMLEncodeEvent; - FOnDecodeValue: TJclSimpleXMLEncodeEvent; - FOnDecodeStream: TJclSimpleXMLEncodeStreamEvent; - FOnEncodeStream: TJclSimpleXMLEncodeStreamEvent; - procedure SetIndentString(const Value: string); - procedure SetBaseIndentString(const Value: string); - procedure SetRoot(const Value: TJclSimpleXMLElemClassic); - procedure SetFileName(const Value: TFileName); - protected - procedure DoLoadProgress(const APosition, ATotal: Integer); - procedure DoSaveProgress; - procedure DoTagParsed(const AName: string); - procedure DoValueParsed(const AName, AValue: string); - procedure DoEncodeValue(var Value: string); virtual; - procedure DoDecodeValue(var Value: string); virtual; - procedure GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); - public - constructor Create; - destructor Destroy; override; - procedure LoadFromString(const Value: string); - procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure LoadFromStringStream(StringStream: TJclStringStream); - procedure LoadFromResourceName(Instance: THandle; const ResName: string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); - procedure SaveToStringStream(StringStream: TJclStringStream); - function SaveToString: string; - function SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word = CP_ACP): string; - property CodePage: Word read FCodePage; - property Prolog: TJclSimpleXMLElemsProlog read FProlog write FProlog; - property Root: TJclSimpleXMLElemClassic read FRoot write SetRoot; - property XMLData: string read SaveToString write LoadFromString; - property FileName: TFileName read FFileName write SetFileName; - property IndentString: string read FIndentString write SetIndentString; - property BaseIndentString: string read FBaseIndentString write SetBaseIndentString; - property Options: TJclSimpleXMLOptions read FOptions write FOptions; - property OnSaveProgress: TJclOnSimpleProgress read FOnSaveProg write FOnSaveProg; - property OnLoadProgress: TJclOnSimpleProgress read FOnLoadProg write FOnLoadProg; - property OnTagParsed: TJclOnSimpleXMLParsed read FOnTagParsed write FOnTagParsed; - property OnValueParsed: TJclOnValueParsed read FOnValue write FOnValue; - property OnEncodeValue: TJclSimpleXMLEncodeEvent read FOnEncodeValue write FOnEncodeValue; - property OnDecodeValue: TJclSimpleXMLEncodeEvent read FOnDecodeValue write FOnDecodeValue; - property OnEncodeStream: TJclSimpleXMLEncodeStreamEvent read FOnEncodeStream write FOnEncodeStream; - property OnDecodeStream: TJclSimpleXMLEncodeStreamEvent read FOnDecodeStream write FOnDecodeStream; - end; - - TXMLVariant = class(TInvokeableVariantType) - public - procedure Clear(var V: TVarData); override; - function IsClear(const V: TVarData): Boolean; override; - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - procedure CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); override; - - function DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; override; - function GetProperty(var Dest: TVarData; const V: TVarData; - const Name: string): Boolean; override; - function SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - end; - -procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); -function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; overload; -function XMLCreate: Variant; overload; -function VarXML: TVarType; - -// Encodes a string into an internal format: -// any character TAB,LF,CR,#32..#127 is preserved -// all other characters are converted to hex notation except -// for some special characters that are converted to XML entities -function SimpleXMLEncode(const S: string): string; -// Decodes a string encoded with SimpleXMLEncode: -// any character TAB,LF,CR,#32..#127 is preserved -// all other characters and substrings are converted from -// the special XML entities to characters or from hex to characters -// NB! Setting TrimBlanks to true will slow down the process considerably -procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); - -function XMLEncode(const S: string): string; -function XMLDecode(const S: string): string; - -// Encodes special characters (', ", <, > and &) into XML entities (@apos;, ", <, > and &) -function EntityEncode(const S: string): string; -// Decodes XML entities (@apos;, ", <, > and &) into special characters (', ", <, > and &) -function EntityDecode(const S: string): string; - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNITSCOPE} - System.Types, - {$ENDIF HAS_UNITSCOPE} - JclCharsets, - JclStrings, - JclUnicode, - JclStringConversions, - JclResources; - -const - cBufferSize = 8192; - -var - GlobalXMLVariant: TXMLVariant = nil; - - PreparedNibbleCharMapping: Boolean = False; - NibbleCharMapping: array [Low(Char)..High(Char)] of Byte; - -function XMLVariant: TXMLVariant; -begin - if not Assigned(GlobalXMLVariant) then - GlobalXMLVariant := TXMLVariant.Create; - Result := GlobalXMLVariant; -end; - -procedure AddEntity(var Res: string; var ResIndex, ResLen: Integer; const Entity: string); -var - EntityIndex, EntityLen: Integer; -begin - EntityLen := Length(Entity); - if (ResIndex + EntityLen) > ResLen then - begin - if ResLen <= EntityLen then - ResLen := ResLen * EntityLen - else - ResLen := ResLen * 2; - SetLength(Res, ResLen); - end; - for EntityIndex := 1 to EntityLen do - begin - Res[ResIndex] := Entity[EntityIndex]; - Inc(ResIndex); - end; -end; - -function EntityEncode(const S: string): string; -var - C: Char; - SIndex, SLen, RIndex, RLen: Integer; - Tmp: string; -begin - SLen := Length(S); - RLen := SLen; - RIndex := 1; - SetLength(Tmp, RLen); - for SIndex := 1 to SLen do - begin - C := S[SIndex]; - case C of - '"': - AddEntity(Tmp, RIndex, RLen, '"'); - '&': - AddEntity(Tmp, RIndex, RLen, '&'); - #39: - AddEntity(Tmp, RIndex, RLen, '''); - '<': - AddEntity(Tmp, RIndex, RLen, '<'); - '>': - AddEntity(Tmp, RIndex, RLen, '>'); - else - if RIndex > RLen then - begin - RLen := RLen * 2; - SetLength(Tmp, RLen); - end; - Tmp[RIndex] := C; - Inc(RIndex); - end; - end; - if RIndex > 1 then - SetLength(Tmp, RIndex - 1); - - Result := Tmp; -end; - -function EntityDecode(const S: string): string; -var - I, J, L: Integer; -begin - Result := S; - I := 1; - J := 1; - L := Length(Result); - - while I <= L do - begin - if Result[I] = '&' then - begin - if StrSame(Copy(Result, I, 5), '&') then - begin - Result[J] := '&'; - Inc(J); - Inc(I, 4); - end - else - if StrSame(Copy(Result, I, 4), '<') then - begin - Result[J] := '<'; - Inc(J); - Inc(I, 3); - end - else - if StrSame(Copy(Result, I, 4), '>') then - begin - Result[J] := '>'; - Inc(J); - Inc(I, 3); - end - else - if StrSame(Copy(Result, I, 6), ''') then - begin - Result[J] := #39; - Inc(J); - Inc(I, 5); - end - else - if StrSame(Copy(Result, I, 6), '"') then - begin - Result[J] := '"'; - Inc(J); - Inc(I, 5); - end - else - begin - Result[J] := Result[I]; - Inc(J); - end; - end - else - begin - Result[J] := Result[I]; - Inc(J); - end; - Inc(I); - end; - if J > 1 then - SetLength(Result, J - 1) - else - SetLength(Result, 0); -end; - -function SimpleXMLEncode(const S: string): string; -var - C: Char; - SIndex, SLen, RIndex, RLen: Integer; - Tmp: string; -begin - SLen := Length(S); - RLen := SLen; - RIndex := 1; - SetLength(Tmp, RLen); - for SIndex := 1 to SLen do - begin - C := S[SIndex]; - case C of - '"': - AddEntity(Tmp, RIndex, RLen, '"'); - '&': - AddEntity(Tmp, RIndex, RLen, '&'); - #39: - AddEntity(Tmp, RIndex, RLen, '''); - '<': - AddEntity(Tmp, RIndex, RLen, '<'); - '>': - AddEntity(Tmp, RIndex, RLen, '>'); - NativeNull..NativeBackspace, // NativeTab, NativeLineFeed - NativeVerticalTab..NativeFormFeed, // NativeCarriageReturn - NativeSo..NativeUs, - Char(128)..Char(255): - AddEntity(Tmp, RIndex, RLen, Format('&#x%.2x;', [Ord(C)])); - {$IFDEF SUPPORTS_UNICODE} - Char(256)..High(Char): - AddEntity(Tmp, RIndex, RLen, Format('&#x%.4x;', [Ord(C)])); - {$ENDIF SUPPORTS_UNICODE} - else - if RIndex > RLen then - begin - RLen := RLen * 2; - SetLength(Tmp, RLen); - end; - Tmp[RIndex] := C; - Inc(RIndex); - end; - end; - if RIndex > 1 then - SetLength(Tmp, RIndex - 1); - - Result := Tmp; -end; - -procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); - procedure DecodeEntity(var S: string; StringLength: Cardinal; - var ReadIndex, WriteIndex: Cardinal); - const - cHexPrefix: array [Boolean] of string = ('', '$'); - var - I: Cardinal; - Value: Integer; - IsHex: Boolean; - begin - Inc(ReadIndex, 2); - IsHex := (ReadIndex <= StringLength) and ((S[ReadIndex] = 'x') or (S[ReadIndex] = 'X')); - Inc(ReadIndex, Ord(IsHex)); - I := ReadIndex; - while ReadIndex <= StringLength do - begin - if S[ReadIndex] = ';' then - begin - Value := StrToIntDef(cHexPrefix[IsHex] + Copy(S, I, ReadIndex - I), -1); // no characters are less than 0 - if Value >= 0 then - S[WriteIndex] := Chr(Value) - else - ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start - Exit; - end; - Inc(ReadIndex); - end; - ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start - end; - - procedure SkipBlanks(var S: string; StringLength: Cardinal; var ReadIndex: Cardinal); - begin - while ReadIndex < StringLength do - begin - if S[ReadIndex] = NativeCarriageReturn then - S[ReadIndex] := NativeLineFeed - else - if S[ReadIndex + 1] = NativeCarriageReturn then - S[ReadIndex + 1] := NativeLineFeed; - if (S[ReadIndex] < #33) and (S[ReadIndex] = S[ReadIndex + 1]) then - Inc(ReadIndex) - else - Exit; - end; - end; - -var - StringLength, ReadIndex, WriteIndex: Cardinal; -begin - // NB! This procedure replaces the text inplace to speed up the conversion. This - // works because when decoding, the string can only become shorter. This is - // accomplished by keeping track of the current read and write points. - // In addition, the original string length is read only once and passed to the - // inner procedures to speed up conversion as much as possible - ReadIndex := 1; - WriteIndex := 1; - StringLength := Length(S); - while ReadIndex <= StringLength do - begin - // this call lowers conversion speed by ~30%, ie 21MB/sec -> 15MB/sec (repeated tests, various inputs) - if TrimBlanks then - SkipBlanks(S, StringLength, ReadIndex); - if S[ReadIndex] = '&' then - begin - if (ReadIndex < StringLength) and (S[ReadIndex + 1] = '#') then - begin - DecodeEntity(S, StringLength, ReadIndex, WriteIndex); - Inc(WriteIndex); - end - else - if StrSame(Copy(S, ReadIndex, 5), '&') then - begin - S[WriteIndex] := '&'; - Inc(WriteIndex); - Inc(ReadIndex, 4); - end - else - if StrSame(Copy(S, ReadIndex, 4), '<') then - begin - S[WriteIndex] := '<'; - Inc(WriteIndex); - Inc(ReadIndex, 3); - end - else - if StrSame(Copy(S, ReadIndex, 4), '>') then - begin - S[WriteIndex] := '>'; - Inc(WriteIndex); - Inc(ReadIndex, 3); - end - else - if StrSame(Copy(S, ReadIndex, 6), ''') then - begin - S[WriteIndex] := #39; - Inc(WriteIndex); - Inc(ReadIndex, 5); - end - else - if StrSame(Copy(S, ReadIndex, 6), '"') then - begin - S[WriteIndex] := '"'; - Inc(WriteIndex); - Inc(ReadIndex, 5); - end - else - begin - S[WriteIndex] := S[ReadIndex]; - Inc(WriteIndex); - end; - end - else - begin - S[WriteIndex] := S[ReadIndex]; - Inc(WriteIndex); - end; - Inc(ReadIndex); - end; - if WriteIndex > 0 then - SetLength(S, WriteIndex - 1) - else - SetLength(S, 0); - // this call lowers conversion speed by ~65%, ie 21MB/sec -> 7MB/sec (repeated tests, various inputs) -// if TrimBlanks then -// S := AdjustLineBreaks(S); -end; - -function XMLEncode(const S: string): string; -begin - Result := SimpleXMLEncode(S); -end; - -function XMLDecode(const S: string): string; -begin - Result := S; - SimpleXMLDecode(Result, False); -end; - -//=== { TJclSimpleItem } ===================================================== - -procedure TJclSimpleItem.SetName(const Value: string); -begin - FName := Value; -end; - -//=== { TJclSimpleItemHashedList } =========================================== - -procedure TJclSimpleItemHashedList.Clear; -begin - InvalidateHash; - inherited Clear; -end; - -constructor TJclSimpleItemHashedList.Create(ACaseSensitive: Boolean); -begin - inherited Create(True); - FCaseSensitive := ACaseSensitive; -end; - -destructor TJclSimpleItemHashedList.Destroy; -begin - FreeAndNil(FNameHash); - inherited Destroy; -end; - -function TJclSimpleItemHashedList.Add(Item: TJclSimpleItem): Integer; -begin - Result := inherited Add(Item); - if FNameHash <> nil then - begin - if FCaseSensitive then - FNameHash.Add(Item.Name, Result) - else - FNameHash.Add(UpperCase(Item.Name), Result); - end; -end; - -function TJclSimpleItemHashedList.GetSimpleItem(Index: Integer): TJclSimpleItem; -begin - Result := TJclSimpleItem(GetItem(Index)); -end; - -function TJclSimpleItemHashedList.GetSimpleItemByName(const Name: string): TJclSimpleItem; -var - I: Integer; -begin - I := IndexOfName(Name); - if I >= 0 then - Result := TJclSimpleItem(Items[I]) - else - Result := nil; -end; - -function TJclSimpleItemHashedList.IndexOfSimpleItem(Item: TJclSimpleItem): Integer; -begin - Result := IndexOf(Item); -end; - -function TJclSimpleItemHashedList.IndexOfName(const Name: string): Integer; -var - I: Integer; -begin - if FCaseSensitive then - begin - if FNameHash = nil then - begin - FNameHash := TStringHash.Create(8); - for I := 0 to Count - 1 do - FNameHash.Add(TJclSimpleData(Items[I]).Name, I); - end; - Result := FNameHash.ValueOf(Name); - end - else - begin - if FNameHash = nil then - begin - FNameHash := TStringHash.Create(8); - for I := 0 to Count - 1 do - FNameHash.Add(UpperCase(TJclSimpleData(Items[I]).Name), I); - end; - Result := FNameHash.ValueOf(UpperCase(Name)); - end; -end; - -procedure TJclSimpleItemHashedList.Insert(Index: Integer; Item: TJclSimpleItem); -begin - InvalidateHash; - inherited Insert(Index, Item); -end; - -procedure TJclSimpleItemHashedList.InvalidateHash; -begin - FreeAndNil(FNameHash); -end; - -procedure TJclSimpleItemHashedList.Move(CurIndex, NewIndex: Integer); -begin - InvalidateHash; - inherited Move(CurIndex, NewIndex); -end; - -procedure TJclSimpleItemHashedList.Notify(Ptr: Pointer; Action: TListNotification); -begin - if (Action = lnDeleted) and (FNameHash <> nil) then - begin - InvalidateHash; -// if FCaseSensitive then -// FNameHash.Remove(TJclSimpleItem(Ptr).Name) -// else -// FNameHash.Remove(UpperCase(TJclSimpleItem(Ptr).Name)); - end; - inherited Notify(Ptr, Action); -end; - -procedure TJclSimpleItemHashedList.SetCaseSensitive(const Value: Boolean); -begin - if FCaseSensitive <> Value then - begin - InvalidateHash; - FCaseSensitive := Value; - end; -end; - -//=== { TJclSimpleData } ===================================================== - -constructor TJclSimpleData.Create; -begin - inherited Create; -end; - -constructor TJclSimpleData.Create(const AName: string); -begin - inherited Create; - FName := AName; -end; - -constructor TJclSimpleData.Create(const AName, AValue: string); -begin - inherited Create; - FName := AName; - FValue := AValue; -end; - -function TJclSimpleData.GetAnsiValue: AnsiString; -begin - Result := AnsiString(Value); -end; - -function TJclSimpleData.GetBoolValue: Boolean; -begin - Result := StrToBoolDef(Value, False); -end; - -function TJclSimpleData.GetFloatValue: Extended; -begin - Result := 0.0; - if not TryStrToFloat(Value, Result) then - Result := 0.0; -end; - -function TJclSimpleData.GetIntValue: Int64; -begin - Result := StrToInt64Def(Value, -1); -end; - -procedure TJclSimpleData.SetAnsiValue(const Value: AnsiString); -begin - Self.Value := string(Value); -end; - -procedure TJclSimpleData.SetBoolValue(const Value: Boolean); -begin - FValue := BoolToStr(Value); -end; - -procedure TJclSimpleData.SetFloatValue(const Value: Extended); -begin - FValue := FloatToStr(Value); -end; - -procedure TJclSimpleData.SetIntValue(const Value: Int64); -begin - FValue := IntToStr(Value); -end; - -//=== { TJclSimpleXMLData } ================================================== - -function TJclSimpleXMLData.FullName: string; -begin - if NameSpace <> '' then - Result := NameSpace + ':' + Name - else - Result := Name; -end; - -//=== { TJclSimpleXML } ====================================================== - -constructor TJclSimpleXML.Create; -begin - inherited Create; - FRoot := TJclSimpleXMLElemClassic.Create(Self); - FProlog := TJclSimpleXMLElemsProlog.Create(Self); - FOptions := [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity]; - FIndentString := ' '; -end; - -destructor TJclSimpleXML.Destroy; -begin - FreeAndNil(FRoot); - FreeAndNil(FProlog); - inherited Destroy; -end; - -procedure TJclSimpleXML.DoDecodeValue(var Value: string); -begin - if sxoAutoEncodeValue in Options then - SimpleXMLDecode(Value, False) - else - if sxoAutoEncodeEntity in Options then - Value := EntityDecode(Value); - if Assigned(FOnDecodeValue) then - FOnDecodeValue(Self, Value); -end; - -procedure TJclSimpleXML.DoEncodeValue(var Value: string); -begin - if Assigned(FOnEncodeValue) then - FOnEncodeValue(Self, Value); - if sxoAutoEncodeValue in Options then - Value := SimpleXMLEncode(Value) - else - if sxoAutoEncodeEntity in Options then - Value := EntityEncode(Value); -end; - -procedure TJclSimpleXML.DoLoadProgress(const APosition, ATotal: Integer); -begin - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, APosition, ATotal); -end; - -procedure TJclSimpleXML.DoSaveProgress; -begin - if Assigned(FOnSaveProg) then - begin +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 JvSimpleXML.PAS, released on 2002-06-03. } +{ } +{ The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]. } +{ Portions created by Sébastien Buysse are Copyright (C) 2001 Sébastien Buysse. } +{ All Rights Reserved. } +{ } +{ Contributor(s): } +{ Christophe Paris, } +{ Florent Ouchet (move from the JVCL to the JCL) } +{ Teträm } +{ } +{**************************************************************************************************} +{ } +{ This unit contains Xml parser and writter classes } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +// Known Issues: This component does not parse the !DOCTYPE tags but preserves them + +unit JclSimpleXml; + +interface + +{$I jcl.inc} + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF HAS_UNIT_RTLCONSTS} + System.RTLConsts, + {$ENDIF HAS_UNIT_RTLCONSTS} + {$IFDEF MSWINDOWS} + Winapi.Windows, // Delphi 2005 inline + {$ENDIF MSWINDOWS} + System.SysUtils, System.Classes, + System.Variants, + System.IniFiles, + System.Contnrs, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF HAS_UNIT_RTLCONSTS} + RTLConsts, + {$ENDIF HAS_UNIT_RTLCONSTS} + {$IFDEF MSWINDOWS} + Windows, // Delphi 2005 inline + {$ENDIF MSWINDOWS} + SysUtils, Classes, + Variants, + IniFiles, + Contnrs, + {$ENDIF ~HAS_UNITSCOPE} + JclBase, JclStreams; + +type + TJclSimpleItem = class(TObject) + private + FName: string; + protected + procedure SetName(const Value: string); virtual; + public + property Name: string read FName write SetName; + end; + +type + TJclSimpleItemHashedList = class(TObjectList) + private + FNameHash: TStringHash; + FCaseSensitive: Boolean; + function GetSimpleItemByName(const Name: string): TJclSimpleItem; + function GetSimpleItem(Index: Integer): TJclSimpleItem; + procedure SetCaseSensitive(const Value: Boolean); + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + public + constructor Create(ACaseSensitive: Boolean); + destructor Destroy; override; + function Add(Item: TJclSimpleItem): Integer; + procedure Clear; override; + function IndexOfSimpleItem(Item: TJclSimpleItem): Integer; + function IndexOfName(const Name: string): Integer; + procedure Insert(Index: Integer; Item: TJclSimpleItem); + procedure InvalidateHash; + procedure Move(CurIndex, NewIndex: Integer); + property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; + property SimpleItemByNames[const Name: string]: TJclSimpleItem read GetSimpleItemByName; + property SimpleItems[Index: Integer]: TJclSimpleItem read GetSimpleItem; + end; + +type + TJclSimpleData = class(TJclSimpleItem) + private + FValue: string; + FData: Pointer; + protected + function GetBoolValue: Boolean; + procedure SetBoolValue(const Value: Boolean); + function GetFloatValue: Extended; + procedure SetFloatValue(const Value: Extended); + function GetAnsiValue: AnsiString; + procedure SetAnsiValue(const Value: AnsiString); + function GetIntValue: Int64; + procedure SetIntValue(const Value: Int64); + public + constructor Create; overload; virtual; + constructor Create(const AName: string); overload; + constructor Create(const AName, AValue: string); overload; + property Value: string read FValue write FValue; + property AnsiValue: AnsiString read GetAnsiValue write SetAnsiValue; + property IntValue: Int64 read GetIntValue write SetIntValue; + property BoolValue: Boolean read GetBoolValue write SetBoolValue; + property FloatValue: Extended read GetFloatValue write SetFloatValue; + + property Data: Pointer read FData write FData; + end; + +type + TJclSimpleXMLData = class(TJclSimpleData) + private + FNameSpace: string; + public + function FullName:string; + property NameSpace: string read FNameSpace write FNameSpace; + end; + +type + TJclSimpleXML = class; + EJclSimpleXMLError = class(EJclError); + {$TYPEINFO ON} // generate RTTI for published properties + TJclSimpleXMLElem = class; + {$IFNDEF TYPEINFO_ON} + {$TYPEINFO OFF} + {$ENDIF ~TYPEINFO_ON} + TJclSimpleXMLElems = class; + TJclSimpleXMLProps = class; + TJclSimpleXMLElemsProlog = class; + TJclSimpleXMLNamedElems = class; + TJclSimpleXMLElemComment = class; + TJclSimpleXMLElemClassic = class; + TJclSimpleXMLElemCData = class; + TJclSimpleXMLElemDocType = class; + TJclSimpleXMLElemText = class; + TJclSimpleXMLElemHeader = class; + TJclSimpleXMLElemSheet = class; + TJclSimpleXMLElemMSOApplication = class; + TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object; + TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object; + TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; + + //Those hash stuffs are for future use only + //Plans are to replace current hash by this mechanism + TJclHashKind = (hkList, hkDirect); + PJclHashElem = ^TJclHashElem; + TJclHashElem = packed record + Next: PJclHashElem; + Obj: TObject; + end; + PJclHashRecord = ^TJclHashRecord; + TJclHashList = array [0..25] of PJclHashRecord; + PJclHashList = ^TJclHashList; + TJclHashRecord = packed record + Count: Byte; + case Kind: TJclHashKind of + hkList: (List: PJclHashList); + hkDirect: (FirstElem: PJclHashElem); + end; + + TJclSimpleXMLProp = class(TJclSimpleXMLData) + private + FParent: TJclSimpleXMLElem; + protected + function GetSimpleXML: TJclSimpleXML; + procedure SetName(const Value: string); override; + public + constructor Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); + procedure SaveToStringStream(StringStream: TJclStringStream); + property Parent: TJclSimpleXMLElem read FParent; + property SimpleXML: TJclSimpleXML read GetSimpleXML; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLPropsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLProps; + public + constructor Create(AList: TJclSimpleXMLProps); + function GetCurrent: TJclSimpleXMLProp; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLProp read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLProps = class(TObject) + private + FProperties: TStringList; + FParent: TJclSimpleXMLElem; + function GetCount: Integer; + function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; + function GetItemNamed(const Name: string): TJclSimpleXMLProp; + protected + function GetSimpleXML: TJclSimpleXML; + function GetItem(const Index: Integer): TJclSimpleXMLProp; + procedure DoItemRename(Value: TJclSimpleXMLProp; const Name: string); + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + constructor Create(AParent: TJclSimpleXMLElem); + destructor Destroy; override; + function Add(const Name, Value: string): TJclSimpleXMLProp; overload; + {$IFDEF SUPPORTS_UNICODE} + function Add(const Name: string; const Value: AnsiString): TJclSimpleXMLProp; overload; + {$ENDIF SUPPORTS_UNICODE} + function Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; + function Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; overload; + function Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload; + procedure Clear; virtual; + procedure Delete(const Index: Integer); overload; + procedure Delete(const Name: string); overload; + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLPropsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; + function BoolValue(const Name: string; Default: Boolean = True): Boolean; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream); + property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default; + property ItemNamed[const Name: string]: TJclSimpleXMLProp read GetItemNamed; + property Count: Integer read GetCount; + property Parent: TJclSimpleXMLElem read FParent; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLElemsPrologEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLElemsProlog; + public + constructor Create(AList: TJclSimpleXMLElemsProlog); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLElemsProlog = class(TObject) + private + FElems: TJclSimpleItemHashedList; + function GetCount: Integer; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + function GetEncoding: string; + function GetStandAlone: Boolean; + function GetVersion: string; + procedure SetEncoding(const Value: string); + procedure SetStandAlone(const Value: Boolean); + procedure SetVersion(const Value: string); + protected + FSimpleXML: TJclSimpleXML; + function FindHeader: TJclSimpleXMLElem; + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + constructor Create(ASimpleXML: TJclSimpleXML); + destructor Destroy; override; + function AddComment(const AValue: string): TJclSimpleXMLElemComment; + function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; + procedure Clear; + function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; + function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream); + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property Count: Integer read GetCount; + property Encoding: string read GetEncoding write SetEncoding; + property SimpleXML: TJclSimpleXML read FSimpleXML; + property StandAlone: Boolean read GetStandAlone write SetStandAlone; + property Version: string read GetVersion write SetVersion; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLNamedElemsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLNamedElems; + public + constructor Create(AList: TJclSimpleXMLNamedElems); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLNamedElems = class(TJclSimpleItem) + private + FElems: TJclSimpleXMLElems; + function GetCount: Integer; + protected + FItems: TList; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + procedure SetName(const Value: string); override; + public + constructor Create(AElems: TJclSimpleXMLElems; const AName: string); + destructor Destroy; override; + + function Add: TJclSimpleXMLElemClassic; overload; + function Add(const Value: string): TJclSimpleXMLElemClassic; overload; + function Add(const Value: Int64): TJclSimpleXMLElemClassic; overload; + function Add(const Value: Boolean): TJclSimpleXMLElemClassic; overload; + function Add(Value: TStream): TJclSimpleXMLElemClassic; overload; + function AddFirst: TJclSimpleXMLElemClassic; + function AddComment(const Value: string): TJclSimpleXMLElemComment; + function AddCData(const Value: string): TJclSimpleXMLElemCData; + function AddText(const Value: string): TJclSimpleXMLElemText; + procedure Clear; virtual; + procedure Delete(const Index: Integer); + procedure Move(const CurIndex, NewIndex: Integer); + function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; + function IndexOf(const Value: string): Integer; overload; + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + + property Elems: TJclSimpleXMLElems read FElems; + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property Count: Integer read GetCount; + end; + + {$IFDEF SUPPORTS_FOR_IN} + TJclSimpleXMLElemsEnumerator = class + private + FIndex: Integer; + FList: TJclSimpleXMLElems; + public + constructor Create(AList: TJclSimpleXMLElems); + function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} + function MoveNext: Boolean; + property Current: TJclSimpleXMLElem read GetCurrent; + end; + {$ENDIF SUPPORTS_FOR_IN} + + TJclSimpleXMLElemCompare = function(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer of object; + TJclSimpleXMLElems = class(TObject) + private + FParent: TJclSimpleXMLElem; + function GetCount: Integer; + function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; + function GetItemNamed(const Name: string): TJclSimpleXMLElem; + function GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; + protected + FElems: TJclSimpleItemHashedList; + FCompare: TJclSimpleXMLElemCompare; + FNamedElems: TJclSimpleItemHashedList; + function GetItem(const Index: Integer): TJclSimpleXMLElem; + procedure AddChild(const Value: TJclSimpleXMLElem); + procedure AddChildFirst(const Value: TJclSimpleXMLElem); + procedure InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); + procedure DoItemRename(Value: TJclSimpleXMLElem; const Name: string); + procedure CreateElems; + function SimpleCompare(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer; + public + constructor Create(AParent: TJclSimpleXMLElem); + destructor Destroy; override; + + // Use notify to indicate to a list that the given element is removed + // from the list so that it doesn't delete it as well as the one + // that insert it in itself. This method is automatically called + // by AddChild and AddChildFirst if the Container property of the + // given element is set. + procedure Notify(Value: TJclSimpleXMLElem; Operation: TOperation); + + function Add(const Name: string): TJclSimpleXMLElemClassic; overload; + function Add(const Name, Value: string): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; overload; + function Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; overload; + function Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; + function AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload; + function AddFirst(const Name: string): TJclSimpleXMLElemClassic; overload; + function AddComment(const Name: string; const Value: string): TJclSimpleXMLElemComment; + function AddCData(const Name: string; const Value: string): TJclSimpleXMLElemCData; + function AddText(const Name: string; const Value: string): TJclSimpleXMLElemText; + function Insert(Value: TJclSimpleXMLElem; Index: Integer): TJclSimpleXMLElem; overload; + function Insert(const Name: string; Index: Integer): TJclSimpleXMLElemClassic; overload; + procedure Clear; virtual; + procedure Delete(const Index: Integer); overload; + procedure Delete(const Name: string); overload; + function Remove(Value: TJclSimpleXMLElem): Integer; + procedure Move(const CurIndex, NewIndex: Integer); + {$IFDEF SUPPORTS_FOR_IN} + function GetEnumerator: TJclSimpleXMLElemsEnumerator; + {$ENDIF SUPPORTS_FOR_IN} + function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; + function IndexOf(const Name: string): Integer; overload; + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; + function BoolValue(const Name: string; Default: Boolean = True): Boolean; + procedure BinaryValue(const Name: string; Stream: TStream); + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); + procedure Sort; + procedure CustomSort(AFunction: TJclSimpleXMLElemCompare); + property Parent: TJclSimpleXMLElem read FParent; + property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; + property ItemNamed[const Name: string]: TJclSimpleXMLElem read GetItemNamed; + property Count: Integer read GetCount; + property NamedElems[const Name: string]: TJclSimpleXMLNamedElems read GetNamedElems; + end; + + {$TYPEINFO ON} + TJclSimpleXMLElem = class(TJclSimpleXMLData) + private + FParent: TJclSimpleXMLElem; + FSimpleXML: TJclSimpleXML; + function GetHasItems: Boolean; + function GetHasProperties: Boolean; + function GetItemCount: Integer; + function GetPropertyCount: Integer; + protected + FItems: TJclSimpleXMLElems; + FProps: TJclSimpleXMLProps; + function GetChildsCount: Integer; + function GetProps: TJclSimpleXMLProps; + procedure SetName(const Value: string); override; + function GetItems: TJclSimpleXMLElems; + procedure Error(const S: string); + procedure FmtError(const S: string; const Args: array of const); + public + //constructor Create; overload; + //constructor Create(const AName: string); overload; + //constructor Create(const AName, AValue: string); overload; + constructor Create(ASimpleXML: TJclSimpleXML); overload; + destructor Destroy; override; + procedure Assign(Value: TJclSimpleXMLElem); virtual; + procedure Clear; virtual; + procedure LoadFromStringStream(StringStream: TJclStringStream); virtual; abstract; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); virtual; + abstract; + procedure LoadFromString(const Value: string); + function SaveToString: string; + procedure GetBinaryValue(Stream: TStream); + function GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; + function GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; + + property SimpleXML: TJclSimpleXML read FSimpleXML; + published + property Parent: TJclSimpleXMLElem read FParent; + property ChildsCount: Integer read GetChildsCount; + property HasItems: Boolean read GetHasItems; + property HasProperties: Boolean read GetHasProperties; + property ItemCount: Integer read GetItemCount; + property PropertyCount: Integer read GetPropertyCount; + property Items: TJclSimpleXMLElems read GetItems; + property Properties: TJclSimpleXMLProps read GetProps; + end; + {$IFNDEF TYPEINFO_ON} + {$TYPEINFO OFF} + {$ENDIF ~TYPEINFO_ON} + TJclSimpleXMLElemClass = class of TJclSimpleXMLElem; + + TJclSimpleXMLElemComment = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemClassic = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemCData = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemText = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemProcessingInstruction = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLElemHeader = class(TJclSimpleXMLElemProcessingInstruction) + private + function GetEncoding: string; + function GetStandalone: Boolean; + function GetVersion: string; + procedure SetEncoding(const Value: string); + procedure SetStandalone(const Value: Boolean); + procedure SetVersion(const Value: string); + public + constructor Create; override; + + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + property Version: string read GetVersion write SetVersion; + property StandAlone: Boolean read GetStandalone write SetStandalone; + property Encoding: string read GetEncoding write SetEncoding; + end; + + // for backward compatibility + TJclSimpleXMLElemSheet = class(TJclSimpleXMLElemProcessingInstruction) + end; + + // for backward compatibility + TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElemProcessingInstruction) + end; + + TJclSimpleXMLElemDocType = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override; + end; + + TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue, + sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace, + sxoTrimFollowingTextWhitespace, sxoKeepWhitespace, sxoDoNotSaveBOM, sxoCaseSensitive); + TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object; + TJclSimpleXMLEncodeStreamEvent = procedure(Sender: TObject; InStream, OutStream: TStream) of object; + + TJclSimpleXML = class(TObject) + protected + FEncoding: TJclStringEncoding; + FCodePage: Word; + FFileName: TFileName; + FOptions: TJclSimpleXMLOptions; + FRoot: TJclSimpleXMLElemClassic; + FOnTagParsed: TJclOnSimpleXMLParsed; + FOnValue: TJclOnValueParsed; + FOnLoadProg: TJclOnSimpleProgress; + FOnSaveProg: TJclOnSimpleProgress; + FProlog: TJclSimpleXMLElemsProlog; + FSaveCount: Integer; + FSaveCurrent: Integer; + FIndentString: string; + FBaseIndentString: string; + FOnEncodeValue: TJclSimpleXMLEncodeEvent; + FOnDecodeValue: TJclSimpleXMLEncodeEvent; + FOnDecodeStream: TJclSimpleXMLEncodeStreamEvent; + FOnEncodeStream: TJclSimpleXMLEncodeStreamEvent; + procedure SetIndentString(const Value: string); + procedure SetBaseIndentString(const Value: string); + procedure SetRoot(const Value: TJclSimpleXMLElemClassic); + procedure SetFileName(const Value: TFileName); + protected + procedure DoLoadProgress(const APosition, ATotal: Integer); + procedure DoSaveProgress; + procedure DoTagParsed(const AName: string); + procedure DoValueParsed(const AName, AValue: string); + procedure DoEncodeValue(var Value: string); virtual; + procedure DoDecodeValue(var Value: string); virtual; + procedure GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); + public + constructor Create; + destructor Destroy; override; + procedure LoadFromString(const Value: string); + procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure LoadFromStringStream(StringStream: TJclStringStream); + procedure LoadFromResourceName(Instance: THandle; const ResName: string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); + procedure SaveToStringStream(StringStream: TJclStringStream); + function SaveToString: string; + function SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word = CP_ACP): string; + property CodePage: Word read FCodePage; + property Prolog: TJclSimpleXMLElemsProlog read FProlog write FProlog; + property Root: TJclSimpleXMLElemClassic read FRoot write SetRoot; + property XMLData: string read SaveToString write LoadFromString; + property FileName: TFileName read FFileName write SetFileName; + property IndentString: string read FIndentString write SetIndentString; + property BaseIndentString: string read FBaseIndentString write SetBaseIndentString; + property Options: TJclSimpleXMLOptions read FOptions write FOptions; + property OnSaveProgress: TJclOnSimpleProgress read FOnSaveProg write FOnSaveProg; + property OnLoadProgress: TJclOnSimpleProgress read FOnLoadProg write FOnLoadProg; + property OnTagParsed: TJclOnSimpleXMLParsed read FOnTagParsed write FOnTagParsed; + property OnValueParsed: TJclOnValueParsed read FOnValue write FOnValue; + property OnEncodeValue: TJclSimpleXMLEncodeEvent read FOnEncodeValue write FOnEncodeValue; + property OnDecodeValue: TJclSimpleXMLEncodeEvent read FOnDecodeValue write FOnDecodeValue; + property OnEncodeStream: TJclSimpleXMLEncodeStreamEvent read FOnEncodeStream write FOnEncodeStream; + property OnDecodeStream: TJclSimpleXMLEncodeStreamEvent read FOnDecodeStream write FOnDecodeStream; + end; + + TXMLVariant = class(TInvokeableVariantType) + public + procedure Clear(var V: TVarData); override; + function IsClear(const V: TVarData): Boolean; override; + procedure Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); override; + procedure CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); override; + + function DoFunction(var Dest: TVarData; const V: TVarData; + const Name: string; const Arguments: TVarDataArray): Boolean; override; + function GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; override; + function SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + end; + +procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); +function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; overload; +function XMLCreate: Variant; overload; +function VarXML: TVarType; + +// Encodes a string into an internal format: +// any character TAB,LF,CR,#32..#127 is preserved +// all other characters are converted to hex notation except +// for some special characters that are converted to XML entities +function SimpleXMLEncode(const S: string): string; +// Decodes a string encoded with SimpleXMLEncode: +// any character TAB,LF,CR,#32..#127 is preserved +// all other characters and substrings are converted from +// the special XML entities to characters or from hex to characters +// NB! Setting TrimBlanks to true will slow down the process considerably +procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); + +function XMLEncode(const S: string): string; +function XMLDecode(const S: string): string; + +// Encodes special characters (', ", <, > and &) into XML entities (@apos;, ", <, > and &) +function EntityEncode(const S: string): string; +// Decodes XML entities (@apos;, ", <, > and &) into special characters (', ", <, > and &) +function EntityDecode(const S: string): string; + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNITSCOPE} + System.Types, + {$ENDIF HAS_UNITSCOPE} + JclCharsets, + JclStrings, + JclUnicode, + JclStringConversions, + JclResources; + +const + cBufferSize = 8192; + +var + GlobalXMLVariant: TXMLVariant = nil; + + PreparedNibbleCharMapping: Boolean = False; + NibbleCharMapping: array [Low(Char)..High(Char)] of Byte; + +function XMLVariant: TXMLVariant; +begin + if not Assigned(GlobalXMLVariant) then + GlobalXMLVariant := TXMLVariant.Create; + Result := GlobalXMLVariant; +end; + +procedure AddEntity(var Res: string; var ResIndex, ResLen: Integer; const Entity: string); +var + EntityIndex, EntityLen: Integer; +begin + EntityLen := Length(Entity); + if (ResIndex + EntityLen) > ResLen then + begin + if ResLen <= EntityLen then + ResLen := ResLen * EntityLen + else + ResLen := ResLen * 2; + SetLength(Res, ResLen); + end; + for EntityIndex := 1 to EntityLen do + begin + Res[ResIndex] := Entity[EntityIndex]; + Inc(ResIndex); + end; +end; + +function EntityEncode(const S: string): string; +var + C: Char; + SIndex, SLen, RIndex, RLen: Integer; + Tmp: string; +begin + SLen := Length(S); + RLen := SLen; + RIndex := 1; + SetLength(Tmp, RLen); + for SIndex := 1 to SLen do + begin + C := S[SIndex]; + case C of + '"': + AddEntity(Tmp, RIndex, RLen, '"'); + '&': + AddEntity(Tmp, RIndex, RLen, '&'); + #39: + AddEntity(Tmp, RIndex, RLen, '''); + '<': + AddEntity(Tmp, RIndex, RLen, '<'); + '>': + AddEntity(Tmp, RIndex, RLen, '>'); + else + if RIndex > RLen then + begin + RLen := RLen * 2; + SetLength(Tmp, RLen); + end; + Tmp[RIndex] := C; + Inc(RIndex); + end; + end; + if RIndex > 1 then + SetLength(Tmp, RIndex - 1); + + Result := Tmp; +end; + +function EntityDecode(const S: string): string; +var + I, J, L: Integer; +begin + Result := S; + I := 1; + J := 1; + L := Length(Result); + + while I <= L do + begin + if Result[I] = '&' then + begin + if StrSame(Copy(Result, I, 5), '&') then + begin + Result[J] := '&'; + Inc(J); + Inc(I, 4); + end + else + if StrSame(Copy(Result, I, 4), '<') then + begin + Result[J] := '<'; + Inc(J); + Inc(I, 3); + end + else + if StrSame(Copy(Result, I, 4), '>') then + begin + Result[J] := '>'; + Inc(J); + Inc(I, 3); + end + else + if StrSame(Copy(Result, I, 6), ''') then + begin + Result[J] := #39; + Inc(J); + Inc(I, 5); + end + else + if StrSame(Copy(Result, I, 6), '"') then + begin + Result[J] := '"'; + Inc(J); + Inc(I, 5); + end + else + begin + Result[J] := Result[I]; + Inc(J); + end; + end + else + begin + Result[J] := Result[I]; + Inc(J); + end; + Inc(I); + end; + if J > 1 then + SetLength(Result, J - 1) + else + SetLength(Result, 0); +end; + +function SimpleXMLEncode(const S: string): string; +var + C: Char; + SIndex, SLen, RIndex, RLen: Integer; + Tmp: string; +begin + SLen := Length(S); + RLen := SLen; + RIndex := 1; + SetLength(Tmp, RLen); + for SIndex := 1 to SLen do + begin + C := S[SIndex]; + case C of + '"': + AddEntity(Tmp, RIndex, RLen, '"'); + '&': + AddEntity(Tmp, RIndex, RLen, '&'); + #39: + AddEntity(Tmp, RIndex, RLen, '''); + '<': + AddEntity(Tmp, RIndex, RLen, '<'); + '>': + AddEntity(Tmp, RIndex, RLen, '>'); + NativeNull..NativeBackspace, // NativeTab, NativeLineFeed + NativeVerticalTab..NativeFormFeed, // NativeCarriageReturn + NativeSo..NativeUs, + Char(128)..Char(255): + AddEntity(Tmp, RIndex, RLen, Format('&#x%.2x;', [Ord(C)])); + {$IFDEF SUPPORTS_UNICODE} + Char(256)..High(Char): + AddEntity(Tmp, RIndex, RLen, Format('&#x%.4x;', [Ord(C)])); + {$ENDIF SUPPORTS_UNICODE} + else + if RIndex > RLen then + begin + RLen := RLen * 2; + SetLength(Tmp, RLen); + end; + Tmp[RIndex] := C; + Inc(RIndex); + end; + end; + if RIndex > 1 then + SetLength(Tmp, RIndex - 1); + + Result := Tmp; +end; + +procedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); + procedure DecodeEntity(var S: string; StringLength: Cardinal; + var ReadIndex, WriteIndex: Cardinal); + const + cHexPrefix: array [Boolean] of string = ('', '$'); + var + I: Cardinal; + Value: Integer; + IsHex: Boolean; + begin + Inc(ReadIndex, 2); + IsHex := (ReadIndex <= StringLength) and ((S[ReadIndex] = 'x') or (S[ReadIndex] = 'X')); + Inc(ReadIndex, Ord(IsHex)); + I := ReadIndex; + while ReadIndex <= StringLength do + begin + if S[ReadIndex] = ';' then + begin + Value := StrToIntDef(cHexPrefix[IsHex] + Copy(S, I, ReadIndex - I), -1); // no characters are less than 0 + if Value >= 0 then + S[WriteIndex] := Chr(Value) + else + ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start + Exit; + end; + Inc(ReadIndex); + end; + ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start + end; + + procedure SkipBlanks(var S: string; StringLength: Cardinal; var ReadIndex: Cardinal); + begin + while ReadIndex < StringLength do + begin + if S[ReadIndex] = NativeCarriageReturn then + S[ReadIndex] := NativeLineFeed + else + if S[ReadIndex + 1] = NativeCarriageReturn then + S[ReadIndex + 1] := NativeLineFeed; + if (S[ReadIndex] < #33) and (S[ReadIndex] = S[ReadIndex + 1]) then + Inc(ReadIndex) + else + Exit; + end; + end; + +var + StringLength, ReadIndex, WriteIndex: Cardinal; +begin + // NB! This procedure replaces the text inplace to speed up the conversion. This + // works because when decoding, the string can only become shorter. This is + // accomplished by keeping track of the current read and write points. + // In addition, the original string length is read only once and passed to the + // inner procedures to speed up conversion as much as possible + ReadIndex := 1; + WriteIndex := 1; + StringLength := Length(S); + while ReadIndex <= StringLength do + begin + // this call lowers conversion speed by ~30%, ie 21MB/sec -> 15MB/sec (repeated tests, various inputs) + if TrimBlanks then + SkipBlanks(S, StringLength, ReadIndex); + if S[ReadIndex] = '&' then + begin + if (ReadIndex < StringLength) and (S[ReadIndex + 1] = '#') then + begin + DecodeEntity(S, StringLength, ReadIndex, WriteIndex); + Inc(WriteIndex); + end + else + if StrSame(Copy(S, ReadIndex, 5), '&') then + begin + S[WriteIndex] := '&'; + Inc(WriteIndex); + Inc(ReadIndex, 4); + end + else + if StrSame(Copy(S, ReadIndex, 4), '<') then + begin + S[WriteIndex] := '<'; + Inc(WriteIndex); + Inc(ReadIndex, 3); + end + else + if StrSame(Copy(S, ReadIndex, 4), '>') then + begin + S[WriteIndex] := '>'; + Inc(WriteIndex); + Inc(ReadIndex, 3); + end + else + if StrSame(Copy(S, ReadIndex, 6), ''') then + begin + S[WriteIndex] := #39; + Inc(WriteIndex); + Inc(ReadIndex, 5); + end + else + if StrSame(Copy(S, ReadIndex, 6), '"') then + begin + S[WriteIndex] := '"'; + Inc(WriteIndex); + Inc(ReadIndex, 5); + end + else + begin + S[WriteIndex] := S[ReadIndex]; + Inc(WriteIndex); + end; + end + else + begin + S[WriteIndex] := S[ReadIndex]; + Inc(WriteIndex); + end; + Inc(ReadIndex); + end; + if WriteIndex > 0 then + SetLength(S, WriteIndex - 1) + else + SetLength(S, 0); + // this call lowers conversion speed by ~65%, ie 21MB/sec -> 7MB/sec (repeated tests, various inputs) +// if TrimBlanks then +// S := AdjustLineBreaks(S); +end; + +function XMLEncode(const S: string): string; +begin + Result := SimpleXMLEncode(S); +end; + +function XMLDecode(const S: string): string; +begin + Result := S; + SimpleXMLDecode(Result, False); +end; + +//=== { TJclSimpleItem } ===================================================== + +procedure TJclSimpleItem.SetName(const Value: string); +begin + FName := Value; +end; + +//=== { TJclSimpleItemHashedList } =========================================== + +procedure TJclSimpleItemHashedList.Clear; +begin + InvalidateHash; + inherited Clear; +end; + +constructor TJclSimpleItemHashedList.Create(ACaseSensitive: Boolean); +begin + inherited Create(True); + FCaseSensitive := ACaseSensitive; +end; + +destructor TJclSimpleItemHashedList.Destroy; +begin + FreeAndNil(FNameHash); + inherited Destroy; +end; + +function TJclSimpleItemHashedList.Add(Item: TJclSimpleItem): Integer; +begin + Result := inherited Add(Item); + if FNameHash <> nil then + begin + if FCaseSensitive then + FNameHash.Add(Item.Name, Result) + else + FNameHash.Add(UpperCase(Item.Name), Result); + end; +end; + +function TJclSimpleItemHashedList.GetSimpleItem(Index: Integer): TJclSimpleItem; +begin + Result := TJclSimpleItem(GetItem(Index)); +end; + +function TJclSimpleItemHashedList.GetSimpleItemByName(const Name: string): TJclSimpleItem; +var + I: Integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := TJclSimpleItem(Items[I]) + else + Result := nil; +end; + +function TJclSimpleItemHashedList.IndexOfSimpleItem(Item: TJclSimpleItem): Integer; +begin + Result := IndexOf(Item); +end; + +function TJclSimpleItemHashedList.IndexOfName(const Name: string): Integer; +var + I: Integer; +begin + if FCaseSensitive then + begin + if FNameHash = nil then + begin + FNameHash := TStringHash.Create(8); + for I := 0 to Count - 1 do + FNameHash.Add(TJclSimpleData(Items[I]).Name, I); + end; + Result := FNameHash.ValueOf(Name); + end + else + begin + if FNameHash = nil then + begin + FNameHash := TStringHash.Create(8); + for I := 0 to Count - 1 do + FNameHash.Add(UpperCase(TJclSimpleData(Items[I]).Name), I); + end; + Result := FNameHash.ValueOf(UpperCase(Name)); + end; +end; + +procedure TJclSimpleItemHashedList.Insert(Index: Integer; Item: TJclSimpleItem); +begin + InvalidateHash; + inherited Insert(Index, Item); +end; + +procedure TJclSimpleItemHashedList.InvalidateHash; +begin + FreeAndNil(FNameHash); +end; + +procedure TJclSimpleItemHashedList.Move(CurIndex, NewIndex: Integer); +begin + InvalidateHash; + inherited Move(CurIndex, NewIndex); +end; + +procedure TJclSimpleItemHashedList.Notify(Ptr: Pointer; Action: TListNotification); +begin + if (Action = lnDeleted) and (FNameHash <> nil) then + begin + InvalidateHash; +// if FCaseSensitive then +// FNameHash.Remove(TJclSimpleItem(Ptr).Name) +// else +// FNameHash.Remove(UpperCase(TJclSimpleItem(Ptr).Name)); + end; + inherited Notify(Ptr, Action); +end; + +procedure TJclSimpleItemHashedList.SetCaseSensitive(const Value: Boolean); +begin + if FCaseSensitive <> Value then + begin + InvalidateHash; + FCaseSensitive := Value; + end; +end; + +//=== { TJclSimpleData } ===================================================== + +constructor TJclSimpleData.Create; +begin + inherited Create; +end; + +constructor TJclSimpleData.Create(const AName: string); +begin + inherited Create; + FName := AName; +end; + +constructor TJclSimpleData.Create(const AName, AValue: string); +begin + inherited Create; + FName := AName; + FValue := AValue; +end; + +function TJclSimpleData.GetAnsiValue: AnsiString; +begin + Result := AnsiString(Value); +end; + +function TJclSimpleData.GetBoolValue: Boolean; +begin + Result := StrToBoolDef(Value, False); +end; + +function TJclSimpleData.GetFloatValue: Extended; +begin + Result := 0.0; + if not TryStrToFloat(Value, Result) then + Result := 0.0; +end; + +function TJclSimpleData.GetIntValue: Int64; +begin + Result := StrToInt64Def(Value, -1); +end; + +procedure TJclSimpleData.SetAnsiValue(const Value: AnsiString); +begin + Self.Value := string(Value); +end; + +procedure TJclSimpleData.SetBoolValue(const Value: Boolean); +begin + FValue := BoolToStr(Value); +end; + +procedure TJclSimpleData.SetFloatValue(const Value: Extended); +begin + FValue := FloatToStr(Value); +end; + +procedure TJclSimpleData.SetIntValue(const Value: Int64); +begin + FValue := IntToStr(Value); +end; + +//=== { TJclSimpleXMLData } ================================================== + +function TJclSimpleXMLData.FullName: string; +begin + if NameSpace <> '' then + Result := NameSpace + ':' + Name + else + Result := Name; +end; + +//=== { TJclSimpleXML } ====================================================== + +constructor TJclSimpleXML.Create; +begin + inherited Create; + FRoot := TJclSimpleXMLElemClassic.Create(Self); + FProlog := TJclSimpleXMLElemsProlog.Create(Self); + FOptions := [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity]; + FIndentString := ' '; +end; + +destructor TJclSimpleXML.Destroy; +begin + FreeAndNil(FRoot); + FreeAndNil(FProlog); + inherited Destroy; +end; + +procedure TJclSimpleXML.DoDecodeValue(var Value: string); +begin + if sxoAutoEncodeValue in Options then + SimpleXMLDecode(Value, False) + else + if sxoAutoEncodeEntity in Options then + Value := EntityDecode(Value); + if Assigned(FOnDecodeValue) then + FOnDecodeValue(Self, Value); +end; + +procedure TJclSimpleXML.DoEncodeValue(var Value: string); +begin + if Assigned(FOnEncodeValue) then + FOnEncodeValue(Self, Value); + if sxoAutoEncodeValue in Options then + Value := SimpleXMLEncode(Value) + else + if sxoAutoEncodeEntity in Options then + Value := EntityEncode(Value); +end; + +procedure TJclSimpleXML.DoLoadProgress(const APosition, ATotal: Integer); +begin + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, APosition, ATotal); +end; + +procedure TJclSimpleXML.DoSaveProgress; +begin + if Assigned(FOnSaveProg) then + begin Inc(FSaveCurrent); - FOnSaveProg(Self, FSaveCurrent, FSaveCount); - end; -end; - -procedure TJclSimpleXML.DoTagParsed(const AName: string); -begin - if Assigned(FOnTagParsed) then - FOnTagParsed(Self, AName); -end; - -procedure TJclSimpleXML.DoValueParsed(const AName, AValue: string); -begin - if Assigned(FOnValue) then - FOnValue(Self, AName, AValue); -end; - -procedure TJclSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); -var - Stream: TMemoryStream; -begin - Stream := TMemoryStream.Create; - try - Stream.LoadFromFile(FileName); - LoadFromStream(Stream, Encoding, CodePage); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromResourceName(Instance: THandle; const ResName: string; - Encoding: TJclStringEncoding; CodePage: Word); -{$IFNDEF MSWINDOWS} -const - RT_RCDATA = PChar(10); -{$ENDIF !MSWINDOWS} -var - Stream: TResourceStream; -begin - Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); - try - LoadFromStream(Stream, Encoding, CodePage); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); -var - AOutStream: TStream; - AStringStream: TJclStringStream; - DoFree: Boolean; -begin - FRoot.Clear; - FProlog.Clear; - AOutStream := nil; - DoFree := False; - try - if Assigned(FOnDecodeStream) then - begin - AOutStream := TMemoryStream.Create; - DoFree := True; - FOnDecodeStream(Self, Stream, AOutStream); - AOutStream.Seek(0, soBeginning); - end - else - AOutStream := Stream; - - case Encoding of - seAnsi: - begin - AStringStream := TJclAnsiStream.Create(AOutStream, False); - TJclAnsiStream(AStringStream).CodePage := CodePage; - end; - seUTF8: - AStringStream := TJclUTF8Stream.Create(AOutStream, False); - seUTF16: - AStringStream := TJclUTF16Stream.Create(AOutStream, False); - else - AStringStream := TJclAutoStream.Create(AOutStream, False); - if CodePage <> CP_ACP then - TJclAutoStream(AStringStream).CodePage := CodePage; - end; - try - AStringStream.SkipBOM; - - LoadFromStringStream(AStringStream); - - // save codepage and encoding for future saves - if AStringStream is TJclAutoStream then - begin - FCodePage := TJclAutoStream(AStringStream).CodePage; - FEncoding := TJclAutoStream(AStringStream).Encoding; - end - else - if AStringStream is TJclAnsiStream then - begin - FCodePage := TJclAnsiStream(AStringStream).CodePage; - FEncoding := Encoding; - end - else - begin - FCodePage := CodePage; - FEncoding := Encoding; - end; - finally - AStringStream.Free; - end; - finally - if DoFree then - AOutStream.Free; - end; -end; - -procedure TJclSimpleXML.LoadFromStringStream(StringStream: TJclStringStream); -var - BufferSize: Integer; -begin - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); - - BufferSize := StringStream.BufferSize; - StringStream.BufferSize := 1; - - // Read doctype and so on - FProlog.LoadFromStringStream(StringStream); - - StringStream.BufferSize := BufferSize; - - // Read elements - FRoot.LoadFromStringStream(StringStream); - - if Assigned(FOnLoadProg) then - FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); -end; - -procedure TJclSimpleXML.LoadFromString(const Value: string); -var - Stream: TStringStream; -begin - Stream := TStringStream.Create(Value {$IFDEF SUPPORTS_UNICODE}, TEncoding.Unicode{$ENDIF}); - try - LoadFromStream(Stream {$IFDEF SUPPORTS_UNICODE}, seUTF16, CP_UTF16LE{$ENDIF}); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); -var - XMLHeader: TJclSimpleXMLElemHeader; - I: Integer; -begin - XMLHeader := nil; - for I := 0 to Prolog.Count - 1 do - if Prolog.Item[I] is TJclSimpleXMLElemHeader then - begin - XMLHeader := TJclSimpleXMLElemHeader(Prolog.Item[I]); - Break; - end; - if Assigned(XMLHeader) then - begin - CodePage := CodePageFromCharsetName(XMLHeader.Encoding); - case CodePage of - CP_UTF8: - Encoding := seUTF8; - CP_UTF16LE: - Encoding := seUTF16; - else - Encoding := seAnsi; - end; - end - else - begin - // restore from previous load - Encoding := FEncoding; - CodePage := FCodePage; - end; -end; - -procedure TJclSimpleXML.SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); -var - Stream: TMemoryStream; -begin - Stream := TMemoryStream.Create; - try - SaveToStream(Stream, Encoding, CodePage); - Stream.SaveToFile(FileName); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); -var - AOutStream: TStream; - AStringStream: TJclStringStream; - DoFree: Boolean; -begin - if Assigned(FOnEncodeStream) then - begin - AOutStream := TMemoryStream.Create; - DoFree := True; - end - else - begin - AOutStream := Stream; - DoFree := False; - end; - try - if Encoding = seAuto then - GetEncodingFromXMLHeader(Encoding, CodePage); - - case Encoding of - seUTF8: - begin - AStringStream := TJclUTF8Stream.Create(AOutStream, False); - FCodePage := CP_UTF8; - end; - seUTF16: - begin - AStringStream := TJclUTF16Stream.Create(AOutStream, False); - FCodePage := CP_UTF16LE; - end - else - AStringStream := TJclAnsiStream.Create(AOutStream); - TJclAnsiStream(AStringStream).CodePage := CodePage; - end; - try - if not (sxoDoNotSaveBOM in Options) then - AStringStream.WriteBOM; - SaveToStringStream(AStringStream); - AStringStream.Flush; - finally - AStringStream.Free; - end; - if Assigned(FOnEncodeStream) then - begin - AOutStream.Seek(0, soBeginning); - FOnEncodeStream(Self, AOutStream, Stream); - end; - finally - if DoFree then - AOutStream.Free; - end; -end; - -procedure TJclSimpleXML.SaveToStringStream(StringStream: TJclStringStream); -var - lCount: Integer; -begin - lCount := Root.ChildsCount + Prolog.Count; - FSaveCount := lCount; - FSaveCurrent := 0; - - if Assigned(FOnSaveProg) then - FOnSaveProg(Self, 0, lCount); - - if not (sxoDoNotSaveProlog in FOptions) then - Prolog.SaveToStringStream(StringStream); - - Root.SaveToStringStream(StringStream, BaseIndentString); - - if Assigned(FOnSaveProg) then - FOnSaveProg(Self, lCount, lCount); -end; - -function TJclSimpleXML.SaveToString: string; -begin - Result := SaveToStringEncoding(seAuto, CP_ACP); -end; - -function TJclSimpleXML.SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word): string; -var - Stream: TStringStream; -begin - {$IFDEF SUPPORTS_UNICODE} - // Use the same logic for seAuto as in SaveToStream for creating the TStringStream. - // Otherwise a Unicode-TStringStream is written to from a TJclAnsiStream proxy. - if Encoding = seAuto then - GetEncodingFromXMLHeader(Encoding, CodePage); - - case Encoding of - seAnsi: - Stream := TStringStream.Create('', TEncoding.{$IFDEF COMPILER16_UP}ANSI{$ELSE}Default{$ENDIF}); - seUTF8: - Stream := TStringStream.Create('', TEncoding.UTF8); - else - //seUTF16: - Stream := TStringStream.Create('', TEncoding.Unicode); - end; - {$ELSE ~SUPPORTS_UNICODE} - Stream := TStringStream.Create(''); - {$ENDIF ~SUPPORTS_UNICODE} - try - SaveToStream(Stream, Encoding, CodePage); - Result := Stream.DataString; - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXML.SetBaseIndentString(const Value: string); -begin - // test if the new value is only made of spaces or tabs - if not StrContainsChars(Value, CharIsWhiteSpace, True) then - Exit; - - FBaseIndentString := Value; -end; - -procedure TJclSimpleXML.SetFileName(const Value: TFileName); -begin - FFileName := Value; - LoadFromFile(Value); -end; - -//=== { TJclSimpleXMLElem } ================================================== - -procedure TJclSimpleXMLElem.Assign(Value: TJclSimpleXMLElem); -var - Elems: TJclSimpleXMLElem; - SrcElem, DestElem: TJclSimpleXMLElem; - I: Integer; - SrcProps, DestProps: TJclSimpleXMLProps; - SrcProp: TJclSimpleXMLProp; - SrcElems, DestElems: TJclSimpleXMLElems; -begin - Clear; - if Value = nil then - Exit; - Elems := TJclSimpleXMLElem(Value); - Name := Elems.Name; - Self.Value := Elems.Value; - SrcProps := Elems.FProps; - if Assigned(SrcProps) then - begin - DestProps := Properties; - for I := 0 to SrcProps.Count - 1 do - begin - SrcProp := SrcProps.Item[I]; - DestProps.Add(SrcProp.Name, SrcProp.Value); - end; - end; - - SrcElems := Elems.FItems; - if Assigned(SrcElems) then - begin - DestElems := Items; - for I := 0 to SrcElems.Count - 1 do - begin - // Create from the class type, so that the virtual constructor is called - // creating an element of the correct class type. - SrcElem := SrcElems.Item[I]; - DestElem := TJclSimpleXMLElemClass(SrcElem.ClassType).Create(SrcElem.Name, SrcElem.Value); - DestElem.Assign(SrcElem); - DestElems.Add(DestElem); - end; - end; -end; - -procedure TJclSimpleXMLElem.Clear; -begin - if FItems <> nil then - FItems.Clear; - if FProps <> nil then - FProps.Clear; -end; - -constructor TJclSimpleXMLElem.Create(ASimpleXML: TJclSimpleXML); -begin - Create; - FSimpleXML := ASimpleXML; -end; - -destructor TJclSimpleXMLElem.Destroy; -begin - FSimpleXML := nil; - FParent := nil; - Clear; - FreeAndNil(FItems); - FreeAndNil(FProps); - inherited Destroy; -end; - -procedure TJclSimpleXMLElem.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -procedure TJclSimpleXMLElem.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -procedure TJclSimpleXMLElem.GetBinaryValue(Stream: TStream); -var - I, J, ValueLength, RequiredStreamSize: Integer; - Buf: array [0..cBufferSize - 1] of Byte; - N1, N2: Byte; - - function NibbleCharToNibble(const AChar: Char): Byte; - begin - case AChar of - '0': Result := 0; - '1': Result := 1; - '2': Result := 2; - '3': Result := 3; - '4': Result := 4; - '5': Result := 5; - '6': Result := 6; - '7': Result := 7; - '8': Result := 8; - '9': Result := 9; - 'a', 'A': Result := 10; - 'b', 'B': Result := 11; - 'c', 'C': Result := 12; - 'd', 'D': Result := 13; - 'e', 'E': Result := 14; - 'f', 'F': Result := 15; - else - Result := 16; - end; - end; - - procedure PrepareNibbleCharMapping; - var - C: Char; - begin - if not PreparedNibbleCharMapping then - begin - for C := Low(Char) to High(Char) do - NibbleCharMapping[C] := NibbleCharToNibble(C); - PreparedNibbleCharMapping := True; - end; - end; - -var - CurrentStreamPosition: Integer; -begin - PrepareNibbleCharMapping; - I := 1; - J := 0; - ValueLength := Length(Value); - RequiredStreamSize := Stream.Position + ValueLength div 2; - if Stream.Size < RequiredStreamSize then - begin - CurrentStreamPosition := Stream.Position; - Stream.Size := RequiredStreamSize; - Stream.Seek(CurrentStreamPosition, soBeginning); - end; - while I < ValueLength do - begin - //faster replacement for St := '$' + Value[I] + Value[I + 1]; Buf[J] := StrToIntDef(St, 0); - N1 := NibbleCharMapping[Value[I]]; - N2 := NibbleCharMapping[Value[I + 1]]; - Inc(I, 2); - if (N1 > 15) or (N2 > 15) then - Buf[J] := 0 - else - Buf[J] := (N1 shl 4) or N2; - Inc(J); - if J = cBufferSize - 1 then //Buffered write to speed up the process a little - begin - Stream.Write(Buf, J); - J := 0; - end; - end; - Stream.Write(Buf, J); -end; - -function TJclSimpleXMLElem.GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; -begin - if FItems = nil then - Result := -1 - else - Result := FItems.FElems.IndexOfSimpleItem(AChild); -end; - -function TJclSimpleXMLElem.GetChildsCount: Integer; -var - I: Integer; -begin - Result := 1; - if FItems <> nil then - for I := 0 to FItems.Count - 1 do - Result := Result + FItems[I].ChildsCount; -end; - -function TJclSimpleXMLElem.GetHasItems: Boolean; -begin - Result := Assigned(FItems) and (FItems.Count > 0); -end; - -function TJclSimpleXMLElem.GetHasProperties: Boolean; -begin - Result := Assigned(FProps) and (FProps.Count > 0); -end; - -function TJclSimpleXMLElem.GetItemCount: Integer; -begin - Result := 0; - if Assigned(FItems) then - Result := FItems.Count; -end; - -function TJclSimpleXMLElem.GetItems: TJclSimpleXMLElems; -begin - if FItems = nil then - FItems := TJclSimpleXMLElems.Create(Self); - Result := FItems; -end; - -function TJclSimpleXMLElem.GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; -begin - Result := Items.NamedElems[AChild.Name].IndexOf(AChild); -end; - -function TJclSimpleXMLElem.GetPropertyCount: Integer; -begin - Result := 0; - if Assigned(FProps) then - Result := FProps.Count; -end; - -function TJclSimpleXMLElem.GetProps: TJclSimpleXMLProps; -begin - if FProps = nil then - FProps := TJclSimpleXMLProps.Create(Self); - Result := FProps; -end; - -procedure TJclSimpleXMLElem.LoadFromString(const Value: string); -var - Stream: TJclStringStream; - StrStream: TStringStream; -begin - StrStream := TStringStream.Create(Value); - try - Stream := TJclAutoStream.Create(StrStream); - try - LoadFromStringStream(Stream); - finally - Stream.Free; - end; - finally - StrStream.Free; - end; -end; - -function TJclSimpleXMLElem.SaveToString: string; -var - Stream: TJclStringStream; - StrStream: TStringStream; -begin - StrStream := TStringStream.Create(''); - try - Stream := TJclAutoStream.Create(StrStream); - try - SaveToStringStream(Stream); - Stream.Flush; - finally - Stream.Free; - end; - Result := StrStream.DataString; - finally - StrStream.Free; - end; -end; - -procedure TJclSimpleXMLElem.SetName(const Value: string); -begin - if (Value <> Name) and (Value <> '') then - begin - if (Parent <> nil) and (Name <> '') then - Parent.Items.DoItemRename(Self, Value); - inherited SetName(Value); - end; -end; - -//=== { TJclSimpleXMLNamedElemsEnumerator } ================================== - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLNamedElemsEnumerator.Create(AList: TJclSimpleXMLNamedElems); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLNamedElemsEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLNamedElemsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLNamedElems } ============================================ - -constructor TJclSimpleXMLNamedElems.Create(AElems: TJclSimpleXMLElems; const AName: string); -begin - inherited Create; - FElems := AElems; - FName := AName; - FItems := TList.Create; -end; - -destructor TJclSimpleXMLNamedElems.Destroy; -begin - FItems.Free; - inherited Destroy; -end; - -function TJclSimpleXMLNamedElems.Add(const Value: Int64): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add(Value: TStream): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add(const Value: Boolean): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.Add: TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name); -end; - -function TJclSimpleXMLNamedElems.Add(const Value: string): TJclSimpleXMLElemClassic; -begin - Result := Elems.Add(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddCData(const Value: string): TJclSimpleXMLElemCData; -begin - Result := Elems.AddCData(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddComment(const Value: string): TJclSimpleXMLElemComment; -begin - Result := Elems.AddComment(Name, Value); -end; - -function TJclSimpleXMLNamedElems.AddFirst: TJclSimpleXMLElemClassic; -begin - Result := Elems.AddFirst(Name); -end; - -function TJclSimpleXMLNamedElems.AddText(const Value: string): TJclSimpleXMLElemText; -begin - Result := Elems.AddText(Name, Value); -end; - -procedure TJclSimpleXMLNamedElems.Clear; -var - Index: Integer; -begin - for Index := FItems.Count - 1 downto 0 do - Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); -end; - -procedure TJclSimpleXMLNamedElems.Delete(const Index: Integer); -begin - if (Index >= 0) and (Index < FItems.Count) then - Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); -end; - -function TJclSimpleXMLNamedElems.GetCount: Integer; -begin - Result := FItems.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLNamedElems.GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; -begin - Result := TJclSimpleXMLNamedElemsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLNamedElems.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - if (Index >= 0) then - begin - While (Index >= Count) do - if Assigned(Elems.Parent) and Assigned(Elems.Parent.SimpleXML) and - (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then - Add - else - break; - if Index < Count then - Result := TJclSimpleXMLElem(FItems.Items[Index]) - else - Result := nil; - end - else - Result := nil; -end; - -function TJclSimpleXMLNamedElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; -begin - Result := FItems.IndexOf(Value); -end; - -function TJclSimpleXMLNamedElems.IndexOf(const Value: string): Integer; -var - Index: Integer; - NewItem: TJclSimpleXMLElem; -begin - Result := -1; - for Index := 0 to FItems.Count - 1 do - if TJclSimpleXMLElem(FItems.Items[Index]).Value = Value then - begin - Result := Index; - Break; - end; - if (Result = -1) and (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then - begin - NewItem := Elems.Add(Name, Value); - Result := FItems.IndexOf(NewItem); - end; -end; - -procedure TJclSimpleXMLNamedElems.Move(const CurIndex, NewIndex: Integer); -var - ElemsCurIndex, ElemsNewIndex: Integer; -begin - ElemsCurIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[CurIndex])); - ElemsNewIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[NewIndex])); - Elems.Move(ElemsCurIndex, ElemsNewIndex); - FItems.Move(CurIndex, NewIndex); -end; - -procedure TJclSimpleXMLNamedElems.SetName(const Value: string); -begin - raise EJclSimpleXMLError.CreateRes(@SReadOnlyProperty); -end; - -//=== { TJclSimpleXMLElemsEnumerator } ======================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLElemsEnumerator.Create(AList: TJclSimpleXMLElems); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLElemsEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLElemsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLElems } ================================================= - -function TJclSimpleXMLElems.Add(const Name: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name, Value: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, IntToStr(Value)); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; -begin - if Value <> nil then - AddChild(Value); - Result := Value; -end; - -function TJclSimpleXMLElems.Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name, BoolToStr(Value)); - AddChild(Result); -end; - -function TJclSimpleXMLElems.Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; -var - Stream: TStringStream; - Buf: array [0..cBufferSize - 1] of Byte; - St: string; - I, Count: Integer; -begin - Stream := TStringStream.Create(''); - try - Buf[0] := 0; - repeat - Count := Value.Read(Buf, Length(Buf)); - St := ''; - for I := 0 to Count - 1 do - St := St + IntToHex(Buf[I], 2); - Stream.WriteString(St); - until Count = 0; - Result := TJclSimpleXMLElemClassic.Create(Name, Stream.DataString); - AddChild(Result); - finally - Stream.Free; - end; -end; - -procedure TJclSimpleXMLElems.AddChild(const Value: TJclSimpleXMLElem); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Add(Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; - - Notify(Value, opInsert); -end; - -procedure TJclSimpleXMLElems.AddChildFirst(const Value: TJclSimpleXMLElem); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Insert(0, Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Insert(0, Value); - end; - - Notify(Value, opInsert); -end; - -function TJclSimpleXMLElems.AddFirst(const Name: string): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - AddChildFirst(Result); -end; - -function TJclSimpleXMLElems.AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; -begin - if Value <> nil then - AddChildFirst(Value); - Result := Value; -end; - -function TJclSimpleXMLElems.AddComment(const Name, - Value: string): TJclSimpleXMLElemComment; -begin - Result := TJclSimpleXMLElemComment.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.AddCData(const Name, Value: string): TJclSimpleXMLElemCData; -begin - Result := TJclSimpleXMLElemCData.Create(Name, Value); - AddChild(Result); -end; - -function TJclSimpleXMLElems.AddText(const Name, Value: string): TJclSimpleXMLElemText; -begin - Result := TJclSimpleXMLElemText.Create(Name, Value); - AddChild(Result); -end; - -procedure TJclSimpleXMLElems.BinaryValue(const Name: string; Stream: TStream); -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamed(Name); - if Elem <> nil then - Elem.GetBinaryValue(Stream); -end; - -function TJclSimpleXMLElems.BoolValue(const Name: string; Default: Boolean): Boolean; -var - Elem: TJclSimpleXMLElem; -begin - try - Elem := GetItemNamedDefault(Name, BoolToStr(Default)); - if (Elem = nil) or (Elem.Value = '') then - Result := Default - else - Result := Elem.BoolValue; - except - Result := Default; - end; -end; - -procedure TJclSimpleXMLElems.Clear; -begin - if FElems <> nil then - FElems.Clear; - if FNamedElems <> nil then - FNamedElems.Clear; -end; - -constructor TJclSimpleXMLElems.Create(AParent: TJclSimpleXMLElem); -begin - inherited Create; - FParent := AParent; -end; - -procedure TJclSimpleXMLElems.CreateElems; -var - CaseSensitive: Boolean; -begin - if FElems = nil then - begin - CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) - and (sxoCaseSensitive in Parent.SimpleXML.Options); - FElems := TJclSimpleItemHashedList.Create(CaseSensitive); - end; -end; - -procedure TJclSimpleXMLElems.Delete(const Index: Integer); -var - Elem: TJclSimpleXMLElem; - NamedIndex: Integer; -begin - if (FElems <> nil) and (Index >= 0) and (Index < FElems.Count) then - begin - Elem := TJclSimpleXMLElem(FElems.SimpleItems[Index]); - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Elem.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Elem); - end; - FElems.Delete(Index); - end; -end; - -procedure TJclSimpleXMLElems.Delete(const Name: string); -begin - if FElems <> nil then - Delete(FElems.IndexOfName(Name)); -end; - -destructor TJclSimpleXMLElems.Destroy; -begin - FParent := nil; - Clear; - FreeAndNil(FElems); - FreeAndNil(FNamedElems); - inherited Destroy; -end; - -procedure TJclSimpleXMLElems.DoItemRename(Value: TJclSimpleXMLElem; const Name: string); -var - NamedIndex: Integer; -begin - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); - - NamedIndex := FNamedElems.IndexOfName(Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; -end; - -function TJclSimpleXMLElems.FloatValue(const Name: string; - const Default: Extended): Extended; -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamedDefault(Name, FloatToStr(Default)); - if Elem = nil then - Result := Default - else - Result := Elem.FloatValue; -end; - -function TJclSimpleXMLElems.GetCount: Integer; -begin - if FElems = nil then - Result := 0 - else - Result := FElems.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLElems.GetEnumerator: TJclSimpleXMLElemsEnumerator; -begin - Result := TJclSimpleXMLElemsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLElems.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - if (FElems = nil) or (Index > FElems.Count) then - Result := nil - else - Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); -end; - -function TJclSimpleXMLElems.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; -var - I: Integer; -begin - Result := nil; - if FElems <> nil then - begin - I := FElems.IndexOfName(Name); - if I <> -1 then - Result := TJclSimpleXMLElem(FElems.SimpleItems[I]) - else - if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then - Result := Add(Name, Default); - end - else - if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then - Result := Add(Name, Default); -end; - -function TJclSimpleXMLElems.GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; -var - NamedIndex: Integer; - CaseSensitive: Boolean; -begin - if FNamedElems = nil then - begin - CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) - and (sxoCaseSensitive in Parent.SimpleXML.Options); - FNamedElems := TJclSimpleItemHashedList.Create(CaseSensitive); - end; - NamedIndex := FNamedElems.IndexOfName(Name); - if NamedIndex = -1 then - begin - Result := TJclSimpleXMLNamedElems.Create(Self, Name); - FNamedElems.Add(Result); - if FElems <> nil then - for NamedIndex := 0 to FElems.Count - 1 do - if FElems.SimpleItems[NamedIndex].Name = Name then - Result.FItems.Add(FElems.SimpleItems[NamedIndex]); - end - else - Result := TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]); -end; - -function TJclSimpleXMLElems.GetItemNamed(const Name: string): TJclSimpleXMLElem; -begin - Result := GetItemNamedDefault(Name, ''); -end; - -function TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64; -var - Elem: TJclSimpleXMLElem; -begin - Elem := GetItemNamedDefault(Name, IntToStr(Default)); - if Elem = nil then - Result := Default - else - Result := Elem.IntValue; -end; - -procedure TJclSimpleXMLElems.LoadFromStringStream(StringStream: TJclStringStream); -type - TReadStatus = (rsWaitingTag, rsReadingTagKind); -var - lPos: TReadStatus; - St: TUCS4Array; - lElem: TJclSimpleXMLElem; - Ch: UCS4; - ContainsText, ContainsWhiteSpace, KeepWhiteSpace: Boolean; - SimpleXML: TJclSimpleXML; -begin - SetLength(St, 0); - lPos := rsWaitingTag; - SimpleXML := Parent.SimpleXML; - KeepWhiteSpace := (SimpleXML <> nil) and (sxoKeepWhitespace in SimpleXML.Options); - ContainsText := False; - ContainsWhiteSpace := False; - - // We read from a stream, thus replacing the existing items - Clear; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - rsWaitingTag: //We are waiting for a tag and thus avoiding spaces - begin - if Ch = Ord('<') then - begin - lPos := rsReadingTagKind; - St := UCS4Array(Ch); - end - else - if UnicodeIsWhiteSpace(Ch) then - ContainsWhiteSpace := True - else - ContainsText := True; - end; - - rsReadingTagKind: //We are trying to determine the kind of the tag - begin - lElem := nil; - case Ch of - Ord('/'): - if UCS4ArrayEquals(St, '<') then - begin // "'), Ord(':'): //This should be a classic tag - begin // " - lElem := TJclSimpleXMLElemClassic.Create; - SetLength(St, 0); - lPos := rsWaitingTag; - end; - else - if ContainsText or (ContainsWhiteSpace and KeepWhiteSpace) then - begin - // inner text - lElem := TJclSimpleXMLElemText.Create; - lPos := rsReadingTagKind; - ContainsText := False; - ContainsWhiteSpace := False; - end - else - begin - if not UCS4ArrayEquals(St, ' nil then - begin - CreateElems; - Notify(lElem, opInsert); - lElem.LoadFromStringStream(StringStream); - FElems.Add(lElem); - end; - end; - end; - end; -end; - -procedure TJclSimpleXMLElems.Notify(Value: TJclSimpleXMLElem; Operation: TOperation); -var - NamedIndex: Integer; -begin - case Operation of - opRemove: - if Value.Parent = Parent then // Only remove if we have it - begin - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); - end; - FElems.Remove(Value); - Value.FParent := nil; - Value.FSimpleXML := nil; - end; - opInsert: - begin - Value.FParent := Parent; - Value.FSimpleXML := Parent.SimpleXML; - end; - end; -end; - -function TJclSimpleXMLElems.Remove(Value: TJclSimpleXMLElem): Integer; -begin - if FElems = nil - then Result := -1 // like TList.IndexOf(alien) - else begin - Result := FElems.IndexOfSimpleItem(Value); - Notify(Value, opRemove); - end; -end; - -procedure TJclSimpleXMLElems.SaveToStringStream(StringStream: TJclStringStream; - const Level: string); -var - I: Integer; -begin - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream, Level); -end; - -function TJclSimpleXMLElems.SimpleCompare(Elems: TJclSimpleXMLElems; Index1, - Index2: Integer): Integer; -begin - Result := CompareText(Elems.Item[Index1].Name, Elems.Item[Index2].Name); -end; - -function TJclSimpleXMLElems.Value(const Name, Default: string): string; -var - Elem: TJclSimpleXMLElem; -begin - Result := ''; - Elem := GetItemNamedDefault(Name, Default); - if Elem = nil then - Result := Default - else - Result := Elem.Value; -end; - -procedure TJclSimpleXMLElems.Move(const CurIndex, NewIndex: Integer); -begin - if FElems <> nil then - FElems.Move(CurIndex, NewIndex); -end; - -function TJclSimpleXMLElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; -begin - if FElems = nil then - Result := -1 - else - Result := FElems.IndexOfSimpleItem(Value); -end; - -function TJclSimpleXMLElems.IndexOf(const Name: string): Integer; -begin - if FElems = nil then - Result := -1 - else - Result := FElems.IndexOfName(Name); -end; - -procedure TJclSimpleXMLElems.InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); -var - NamedIndex: Integer; -begin - CreateElems; - - // If there already is a container, notify it to remove the element - if Assigned(Value.Parent) then - Value.Parent.Items.Notify(Value, opRemove); - - FElems.Insert(Index, Value); - - if FNamedElems <> nil then - begin - NamedIndex := FNamedElems.IndexOfName(Value.Name); - if NamedIndex >= 0 then - TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); - end; - - Notify(Value, opInsert); -end; - -function TJclSimpleXMLElems.Insert(Value: TJclSimpleXMLElem; - Index: Integer): TJclSimpleXMLElem; -begin - if Value <> nil then - InsertChild(Value, Index); - Result := Value; -end; - -function TJclSimpleXMLElems.Insert(const Name: string; - Index: Integer): TJclSimpleXMLElemClassic; -begin - Result := TJclSimpleXMLElemClassic.Create(Name); - InsertChild(Result, Index); -end; - -procedure QuickSort(Elems: TJclSimpleXMLElems; List: TList; L, R: Integer; - AFunction: TJclSimpleXMLElemCompare); -var - I, J, M: Integer; -begin - repeat - I := L; - J := R; - M := (L + R) shr 1; - repeat - while AFunction(Elems, I, M) < 0 do - Inc(I); - while AFunction(Elems, J, M) > 0 do - Dec(J); - if I < J then - begin - List.Exchange(I, J); - Inc(I); - Dec(J); - end - else - if I = J then - begin - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(Elems, List, L, J, AFunction); - L := I; - until I >= R; -end; - -procedure TJclSimpleXMLElems.CustomSort(AFunction: TJclSimpleXMLElemCompare); -begin - if FElems <> nil then - QuickSort(Self, FElems, 0, FElems.Count - 1, AFunction); -end; - -procedure TJclSimpleXMLElems.Sort; -begin - CustomSort(SimpleCompare); -end; - -//=== { TJclSimpleXMLPropsEnumerator } ======================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLPropsEnumerator.Create(AList: TJclSimpleXMLProps); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLPropsEnumerator.GetCurrent: TJclSimpleXMLProp; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLPropsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLProps } ================================================= - -function TJclSimpleXMLProps.Add(const Name, Value: string): TJclSimpleXMLProp; -begin - if FProperties = nil then - FProperties := TStringList.Create; - Result := TJclSimpleXMLProp.Create(Parent, Name, Value); - FProperties.AddObject(Name, Result); -end; - -function TJclSimpleXMLProps.Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; -begin - Result := Add(Name, IntToStr(Value)); -end; - -function TJclSimpleXMLProps.Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; -begin - Result := Add(Name, BoolToStr(Value)); -end; - -{$IFDEF SUPPORTS_UNICODE} -function TJclSimpleXMLProps.Add(const Name: string; - const Value: AnsiString): TJclSimpleXMLProp; -begin - Result := Add(Name, string(Value)); -end; -{$ENDIF SUPPORTS_UNICODE} - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; -begin - if FProperties = nil then - FProperties := TStringList.Create; - Result := TJclSimpleXMLProp.Create(Parent, Name, Value); - FProperties.InsertObject(Index, Name, Result); -end; - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; -begin - Result := Insert(Index, Name, IntToStr(Value)); -end; - -function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; -begin - Result := Insert(Index, Name, BoolToStr(Value)); -end; - -function TJclSimpleXMLProps.BoolValue(const Name: string; Default: Boolean): Boolean; -var - Prop: TJclSimpleXMLProp; -begin - try - Prop := GetItemNamedDefault(Name, BoolToStr(Default)); - if (Prop = nil) or (Prop.Value = '') then - Result := Default - else - Result := Prop.BoolValue; - except - Result := Default; - end; -end; - -procedure TJclSimpleXMLProps.Clear; -var - I: Integer; -begin - if FProperties <> nil then - begin - for I := 0 to FProperties.Count - 1 do - begin - TJclSimpleXMLProp(FProperties.Objects[I]).Free; - FProperties.Objects[I] := nil; - end; - FProperties.Clear; - end; -end; - -procedure TJclSimpleXMLProps.Delete(const Index: Integer); -begin - if (FProperties <> nil) and (Index >= 0) and (Index < FProperties.Count) then - begin - TObject(FProperties.Objects[Index]).Free; - FProperties.Delete(Index); - end; -end; - -constructor TJclSimpleXMLProps.Create(AParent: TJclSimpleXMLElem); -begin - inherited Create; - FParent := AParent; -end; - -procedure TJclSimpleXMLProps.Delete(const Name: string); -begin - if FProperties <> nil then - Delete(FProperties.IndexOf(Name)); -end; - -destructor TJclSimpleXMLProps.Destroy; -begin - FParent := nil; - Clear; - FreeAndNil(FProperties); - inherited Destroy; -end; - -procedure TJclSimpleXMLProps.DoItemRename(Value: TJclSimpleXMLProp; const Name: string); -var - I: Integer; -begin - if FProperties = nil then - Exit; - I := FProperties.IndexOfObject(Value); - if I <> -1 then - FProperties[I] := Name; -end; - -procedure TJclSimpleXMLProps.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -function TJclSimpleXMLProps.FloatValue(const Name: string; - const Default: Extended): Extended; -var - Prop: TJclSimpleXMLProp; -begin - Prop := GetItemNamedDefault(Name, FloatToStr(Default)); - if Prop = nil then - Result := Default - else - Result := Prop.FloatValue; -end; - -procedure TJclSimpleXMLProps.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -function TJclSimpleXMLProps.GetCount: Integer; -begin - if FProperties = nil then - Result := 0 - else - Result := FProperties.Count; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLProps.GetEnumerator: TJclSimpleXMLPropsEnumerator; -begin - Result := TJclSimpleXMLPropsEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLProps.GetItem(const Index: Integer): TJclSimpleXMLProp; -begin - if FProperties <> nil then - Result := TJclSimpleXMLProp(FProperties.Objects[Index]) - else - Result := nil; -end; - -function TJclSimpleXMLProps.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; -var - I: Integer; -begin - Result := nil; - if FProperties <> nil then - begin - I := FProperties.IndexOf(Name); - if I <> -1 then - Result := TJclSimpleXMLProp(FProperties.Objects[I]) - else - if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then - Result := Add(Name, Default); - end - else - if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then - begin - Result := Add(Name, Default); - end; -end; - -function TJclSimpleXMLProps.GetItemNamed(const Name: string): TJclSimpleXMLProp; -begin - Result := GetItemNamedDefault(Name, ''); -end; - -function TJclSimpleXMLProps.GetSimpleXML: TJclSimpleXML; -begin - if FParent <> nil then - Result := FParent.SimpleXML - else - Result := nil; -end; - -function TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64; -var - Prop: TJclSimpleXMLProp; -begin - Prop := GetItemNamedDefault(Name, IntToStr(Default)); - if Prop = nil then - Result := Default - else - Result := Prop.IntValue; -end; - -procedure TJclSimpleXMLProps.LoadFromStringStream(StringStream: TJclStringStream); -// -//Stop on / or ? or > -type - TPosType = ( - ptWaiting, - ptReadingName, - ptStartingContent, - ptReadingValue, - ptSpaceBeforeEqual - ); -var - lPos: TPosType; - lName, lValue, lNameSpace: TUCS4Array; - sValue: string; - lPropStart: UCS4; - Ch: UCS4; -begin - SetLength(lValue, 0); - SetLength(lNameSpace, 0); - SetLength(lName, 0); - lPropStart := Ord(NativeSpace); - lPos := ptWaiting; - - // We read from a stream, thus replacing the existing properties - Clear; - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - ptWaiting: //We are waiting for a property - begin - if UnicodeIsWhiteSpace(Ch) then - StringStream.ReadUCS4(Ch) - else - if UnicodeIsIdentifierStart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord('_')) then - begin - StringStream.ReadUCS4(Ch); - lName := UCS4Array(Ch); - SetLength(lNameSpace, 0); - lPos := ptReadingName; - end - else - if (Ch = Ord('/')) or (Ch = Ord('>')) or (Ch = Ord('?')) then - // end of properties - Break - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptReadingName: //We are reading a property name - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - begin - UCS4ArrayConcat(lName, Ch); - end - else - if Ch = Ord(':') then - begin - lNameSpace := lName; - SetLength(lName, 0); - end - else - if Ch = Ord('=') then - lPos := ptStartingContent - else - if UnicodeIsWhiteSpace(Ch) then - lPos := ptSpaceBeforeEqual - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptStartingContent: //We are going to start a property content - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsWhiteSpace(Ch) then - // ignore white space - else - if (Ch = Ord('''')) or (Ch = Ord('"')) then - begin - lPropStart := Ch; - SetLength(lValue, 0); - lPos := ptReadingValue; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte_), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - - ptReadingValue: //We are reading a property - begin - StringStream.ReadUCS4(Ch); - if Ch = lPropStart then - begin - sValue := UCS4ToString(lValue); - if GetSimpleXML <> nil then - GetSimpleXML.DoDecodeValue(sValue); - with Add(UCS4ToString(lName), sValue) do - NameSpace := UCS4ToString(lNameSpace); - lPos := ptWaiting; - end - else - UCS4ArrayConcat(lValue, Ch); - end; - - ptSpaceBeforeEqual: // We are reading the white space between a property name and the = sign - begin - StringStream.ReadUCS4(Ch); - if UnicodeIsWhiteSpace(Ch) then - // more white space, stay in this state and ignore - else - if Ch = Ord('=') then - lPos := ptStartingContent - else - FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - else - Assert(False, RsEUnexpectedValueForLPos); - end; - end; -end; - -procedure TJclSimpleXMLProps.SaveToStringStream(StringStream: TJclStringStream); -var - I: Integer; -begin - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream); -end; - -function TJclSimpleXMLProps.Value(const Name, Default: string): string; -var - Prop: TJclSimpleXMLProp; -begin - Result := ''; - Prop := GetItemNamedDefault(Name, Default); - if Prop = nil then - Result := Default - else - Result := Prop.Value; -end; - -//=== { TJclSimpleXMLProp } ================================================== - -constructor TJclSimpleXMLProp.Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); -begin - inherited Create(AName, AValue); - FParent := AParent; -end; - -function TJclSimpleXMLProp.GetSimpleXML: TJclSimpleXML; -begin - if FParent <> nil then - Result := FParent.SimpleXML - else - Result := nil; -end; - -procedure TJclSimpleXMLProp.SaveToStringStream(StringStream: TJclStringStream); -var - AEncoder: TJclSimpleXML; - Tmp: string; -begin - AEncoder := GetSimpleXML; - Tmp := Value; - if AEncoder <> nil then - AEncoder.DoEncodeValue(Tmp); - if NameSpace <> '' then - Tmp := Format(' %s:%s="%s"', [NameSpace, Name, Tmp]) - else - Tmp := Format(' %s="%s"', [Name, tmp]); - StringStream.WriteString(Tmp, 1, Length(Tmp)); -end; - -procedure TJclSimpleXMLProp.SetName(const Value: string); -begin - if (Value <> Name) and (Value <> '') then - begin - if (Parent <> nil) and (Name <> '') then - FParent.Properties.DoItemRename(Self, Value); - inherited SetName(Value); - end; -end; - -//=== { TJclSimpleXMLElemClassic } =========================================== - -procedure TJclSimpleXMLElemClassic.LoadFromStringStream(StringStream: TJclStringStream); -// -//foorbeuhbar -//foorbeuhbar -type - TReadStatus = (rsWaitingOpeningTag, rsOpeningName, rsTypeOpeningTag, rsEndSingleTag, - rsWaitingClosingTag1, rsWaitingClosingTag2, rsClosingName); -var - lPos: TReadStatus; - St, lName, lNameSpace: TUCS4Array; - sValue: string; - Ch: UCS4; -begin - SetLength(St, 0); - SetLength(lName, 0); - SetLength(lNameSpace, 0); - sValue := ''; - lPos := rsWaitingOpeningTag; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - rsWaitingOpeningTag: // wait beginning of tag - if Ch = Ord('<') then - lPos := rsOpeningName // read name - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsOpeningName: - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - UCS4ArrayConcat(St, Ch) - else - if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then - begin - lNameSpace := St; - SetLength(st, 0); - end - else - if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then - // whitespace after "<" (no name) - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) - else - if UnicodeIsWhiteSpace(Ch) then - begin - lName := St; - SetLength(St, 0); - Properties.LoadFromStringStream(StringStream); - lPos := rsTypeOpeningTag; - end - else - if Ch = Ord('/') then // single tag - begin - lName := St; - lPos := rsEndSingleTag - end - else - if Ch = Ord('>') then // 2 tags - begin - lName := St; - SetLength(St, 0); - //Load elements - Items.LoadFromStringStream(StringStream); - lPos := rsWaitingClosingTag1; - end - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsTypeOpeningTag: - if UnicodeIsWhiteSpace(Ch) then - // nothing, spaces after name or properties - else - if Ch = Ord('/') then - lPos := rsEndSingleTag // single tag - else - if Ch = Ord('>') then // 2 tags - begin - //Load elements - Items.LoadFromStringStream(StringStream); - lPos := rsWaitingClosingTag1; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsEndSingleTag: - if Ch = Ord('>') then - Break - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsWaitingClosingTag1: - if UnicodeIsWhiteSpace(Ch) then - // nothing, spaces before closing tag - else - if Ch = Ord('<') then - lPos := rsWaitingClosingTag2 - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsWaitingClosingTag2: - if Ch = Ord('/') then - lPos := rsClosingName - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsClosingName: - if UnicodeIsWhiteSpace(Ch) or (Ch = Ord('>')) then - begin - if Length(lNameSpace) > 0 then - begin - if not StrSame(UCS4ToString(lNameSpace) + ':' + UCS4ToString(lName), UCS4ToString(St)) then - FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); - end - else - if not UCS4ArrayEquals(lName, St) then - FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); - //Set value if only one sub element - //This might reduce speed, but this is for compatibility issues - if (Items.Count = 1) and (Items[0] is TJclSimpleXMLElemText) then - begin - sValue := Items[0].Value; - Items.Clear; - // free some memory - FreeAndNil(FItems); - end; - Break; - end - else - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord(':')) then - UCS4ArrayConcat(St, Ch) - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - end; - end; - - Name := UCS4ToString(lName); - if SimpleXML <> nil then - SimpleXML.DoDecodeValue(sValue); - Value := sValue; - NameSpace := UCS4ToString(lNameSpace); - - if SimpleXML <> nil then - begin - SimpleXML.DoTagParsed(Name); - SimpleXML.DoValueParsed(Name, sValue); - end; -end; - -procedure TJclSimpleXMLElemClassic.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St, AName, tmp: string; - LevelAdd: string; - AutoIndent: Boolean; -begin - if(NameSpace <> '') then - AName := NameSpace + ':' + Name - else - AName := Name; - - if Name <> '' then - begin - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(AName); - St := Level + '<' + AName; - - StringStream.WriteString(St, 1, Length(St)); - if Assigned(FProps) then - FProps.SaveToStringStream(StringStream); - end; - - AutoIndent := (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options); - - if (ItemCount = 0) then - begin - tmp := Value; - if (Name <> '') then - begin - if Value = '' then - begin - if AutoIndent then - St := '/>' + sLineBreak - else - St := '/>'; - end - else - begin - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(tmp); - if AutoIndent then - St := '>' + tmp + '' + sLineBreak - else - St := '>' + tmp + ''; - end; - StringStream.WriteString(St, 1, Length(St)); - end; - end - else - begin - if (Name <> '') then - begin - if AutoIndent then - St := '>' + sLineBreak - else - St := '>'; - StringStream.WriteString(St, 1, Length(St)); - end; - if AutoIndent then - begin - LevelAdd := SimpleXML.IndentString; - end; - FItems.SaveToStringStream(StringStream, Level + LevelAdd); - if Name <> '' then - begin - if AutoIndent then - St := Level + '' + sLineBreak - else - St := Level + ''; - StringStream.WriteString(St, 1, Length(St)); - end; - end; - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemComment } =========================================== - -procedure TJclSimpleXMLElemComment.LoadFromStringStream(StringStream: TJclStringStream); -// -const - CS_START_COMMENT = ''; -var - lPos: Integer; - St: TUCS4Array; - Ch: UCS4; - lOk: Boolean; -begin - SetLength(St, 0); - lPos := 1; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..4: //' + sLineBreak - else - St := '-->'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemCData } ============================================= - -procedure TJclSimpleXMLElemCData.LoadFromStringStream(StringStream: TJclStringStream); -//Hello, world!]]> -const - CS_START_CDATA = ''; -var - lPos: Integer; - St: TUCS4Array; - Ch: UCS4; - lOk: Boolean; -begin - SetLength(St, 0); - lPos := 1; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..9: // - if Ch = Ord(CS_STOP_CDATA[lPos]) then - begin - lOk := True; - Break; //End if - end - else - // ]]] - if Ch = Ord(CS_STOP_CDATA[lPos-1]) then - UCS4ArrayConcat(St, Ord(']')) - else - begin - UCS4ArrayConcat(St, Ord(']')); - UCS4ArrayConcat(St, Ord(']')); - UCS4ArrayConcat(St, Ch); - Dec(lPos, 2); - end; - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCDATAUnexpectedEndOfData), [StringStream.PeekPosition]); - - Value := UCS4ToString(St); - Name := ''; - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', Value); -end; - -procedure TJclSimpleXMLElemCData.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St: string; -begin - St := Level + ' '' then - StringStream.WriteString(Value, 1, Length(Value)); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := ']]>' + sLineBreak - else - St := ']]>'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemText } ============================================== - -procedure TJclSimpleXMLElemText.LoadFromStringStream(StringStream: TJclStringStream); -var - Ch: UCS4; - USt: TUCS4Array; - St, TrimValue: string; -begin - SetLength(USt, 0); - St := ''; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case Ch of - Ord('<'): - //Quit text - Break; - else - begin - StringStream.ReadUCS4(Ch); - UCS4ArrayConcat(USt, Ch); - end; - end; - end; - - St := UCS4ToString(USt); - - if Assigned(SimpleXML) then - begin - SimpleXML.DoDecodeValue(St); - - TrimValue := St; - if sxoTrimPrecedingTextWhitespace in SimpleXML.Options then - TrimValue := TrimLeft(TrimValue); - if sxoTrimFollowingTextWhitespace in SimpleXML.Options then - TrimValue := TrimRight(TrimValue); - if (TrimValue <> '') or not (sxoKeepWhitespace in SimpleXML.Options) then - St := TrimValue; - end; - - Value := St; - Name := ''; - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', St); -end; - -procedure TJclSimpleXMLElemText.SaveToStringStream(StringStream: TJclStringStream; const Level: string); -var - St, tmp: string; -begin - // should never be used - if Value <> '' then - begin - tmp := Value; - if SimpleXML <> nil then - SimpleXML.DoEncodeValue(tmp); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := Level + tmp + sLineBreak - else - St := Level + tmp; - StringStream.WriteString(St, 1, Length(St)); - end; - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemProcessingInstruction } ============================= - -procedure TJclSimpleXMLElemProcessingInstruction.LoadFromStringStream( - StringStream: TJclStringStream); -type - TReadStatus = (rsWaitingOpeningTag, rsOpeningTag, rsOpeningName, rsEndTag1, rsEndTag2); -var - lPos: TReadStatus; - lOk: Boolean; - St, lName, lNameSpace: TUCS4Array; - Ch: UCS4; -begin - SetLength(St, 0); - SetLength(lName, 0); - SetLength(lNameSpace, 0); - lPos := rsWaitingOpeningTag; - lOk := False; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - rsWaitingOpeningTag: // wait beginning of tag - if Ch = Ord('<') then - lPos := rsOpeningTag - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsOpeningTag: - if Ch = Ord('?') then - lPos := rsOpeningName // read name - else - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsOpeningName: - if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then - UCS4ArrayConcat(St, Ch) - else - if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then - begin - lNameSpace := St; - SetLength(St, 0); - end - else - if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then - // whitespace after "<" (no name) - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) - else - if UnicodeIsWhiteSpace(Ch) then - begin - lName := St; - SetLength(St, 0); - Properties.LoadFromStringStream(StringStream); - lPos := rsEndTag1; - end - else - if Ch = Ord('?') then - begin - lName := St; - lPos := rsEndTag2; - end - else - // other invalid characters - FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); - - rsEndTag1: - if Ch = Ord('?') then - lPos := rsEndTag2 - else - if not UnicodeIsWhiteSpace(Ch) then - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - - rsEndTag2: - if Ch = Ord('>') then - begin - lOk := True; - Break; - end - else - FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); - - Name := UCS4ToString(lName); - NameSpace := UCS4ToString(lNameSpace); -end; - -procedure TJclSimpleXMLElemProcessingInstruction.SaveToStringStream( - StringStream: TJclStringStream; const Level: string); -var - St: string; -begin - St := Level + ' '' then - St := St + NameSpace + ':' + Name - else - St := St + Name; - StringStream.WriteString(St, 1, Length(St)); - if Assigned(FProps) then - FProps.SaveToStringStream(StringStream); - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := '?>' + sLineBreak - else - St := '?>'; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemHeader } ============================================ - -constructor TJclSimpleXMLElemHeader.Create; -begin - inherited Create; - - Name := 'xml'; -end; - -function TJclSimpleXMLElemHeader.GetEncoding: string; -var - ASimpleXML: TJclSimpleXML; - DefaultCodePage: Word; -begin - ASimpleXML := SimpleXML; - if Assigned(ASimpleXML) then - begin - DefaultCodePage := ASimpleXML.CodePage; - {$IFDEF MSWINDOWS} - if DefaultCodePage = CP_ACP then - DefaultCodePage := GetAcp; - {$ENDIF MSWINDOWS} - end - else - {$IFDEF UNICODE} - DefaultCodePage := CP_UTF16LE; - {$ELSE ~UNICODE} - {$IFDEF MSWINDOWS} - DefaultCodePage := GetACP; - {$ELSE ~MSWINDOWS} - DefaultCodePage := 1252; - {$ENDIF ~MSWINDOWS} - {$ENDIF ~UNICODE} - Result := Properties.Value('encoding', CharsetNameFromCodePage(DefaultCodePage)); -end; - -function TJclSimpleXMLElemHeader.GetStandalone: Boolean; -begin - Result := Properties.Value('standalone') = 'yes'; -end; - -function TJclSimpleXMLElemHeader.GetVersion: string; -begin - Result := Properties.Value('version', '1.0'); -end; - -procedure TJclSimpleXMLElemHeader.LoadFromStringStream(StringStream: TJclStringStream); -// -var - CodePage: Word; - EncodingProp: TJclSimpleXMLProp; -begin - inherited LoadFromStringStream(StringStream); - - if Assigned(FProps) then - EncodingProp := FProps.ItemNamed['encoding'] - else - EncodingProp := nil; - if Assigned(EncodingProp) and (EncodingProp.Value <> '') then - CodePage := CodePageFromCharsetName(EncodingProp.Value) - else - CodePage := CP_ACP; - - // set current stringstream codepage - if StringStream is TJclAutoStream then - TJclAutoStream(StringStream).CodePage := CodePage - else - if StringStream is TJclAnsiStream then - TJclAnsiStream(StringStream).CodePage := CodePage - else - if not (StringStream is TJclUTF8Stream) and not (StringStream is TJclUTF16Stream) then - Error(LoadResString(@RsENoCharset)); -end; - -procedure TJclSimpleXMLElemHeader.SaveToStringStream( - StringStream: TJclStringStream; const Level: string); -begin - SetVersion(GetVersion); - SetEncoding(GetEncoding); - SetStandalone(GetStandalone); - - inherited SaveToStringStream(StringStream, Level); -end; - -procedure TJclSimpleXMLElemHeader.SetEncoding(const Value: string); -var - Prop: TJclSimpleXMLProp; -begin - Prop := Properties.ItemNamed['encoding']; - if Assigned(Prop) then - Prop.Value := Value - else - Properties.Add('encoding', Value); -end; - -procedure TJclSimpleXMLElemHeader.SetStandalone(const Value: Boolean); -var - Prop: TJclSimpleXMLProp; -const - BooleanValues: array [Boolean] of string = ('no', 'yes'); -begin - Prop := Properties.ItemNamed['standalone']; - if Assigned(Prop) then - Prop.Value := BooleanValues[Value] - else - Properties.Add('standalone', BooleanValues[Value]); -end; - -procedure TJclSimpleXMLElemHeader.SetVersion(const Value: string); -var - Prop: TJclSimpleXMLProp; -begin - Prop := Properties.ItemNamed['version']; - if Assigned(Prop) then - Prop.Value := Value - else - // Various XML parsers (including MSIE, Firefox) require the "version" to be the first - Properties.Insert(0, 'version', Value); -end; - -//=== { TJclSimpleXMLElemDocType } =========================================== - -procedure TJclSimpleXMLElemDocType.LoadFromStringStream(StringStream: TJclStringStream); -{ - - -' > -%xx; -]> - - -} -const - CS_START_DOCTYPE = ''); - SetLength(St, 0); - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.ReadUCS4(Ch) do - begin - case lPos of - 1..9: // or > - if lChar = Ch then - begin - if lChar = Ord('>') then - begin - lOk := True; - Break; //This is the end - end - else - begin - UCS4ArrayConcat(St, Ch); - lChar := Ord('>'); - end; - end - else - begin - UCS4ArrayConcat(St, Ch); - if Ch = Ord('[') then - lChar := Ord(']'); - end; - end; - end; - - if not lOk then - FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); - - Name := ''; - Value := StrTrimCharsLeft(UCS4ToString(St), CharIsWhiteSpace); - - if SimpleXML <> nil then - SimpleXML.DoValueParsed('', Value); -end; - -procedure TJclSimpleXMLElemDocType.SaveToStringStream(StringStream: TJclStringStream; - const Level: string); -var - St: string; -begin - if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then - St := Level + '' + sLineBreak - else - St := Level + ''; - StringStream.WriteString(St, 1, Length(St)); - if SimpleXML <> nil then - SimpleXML.DoSaveProgress; -end; - -//=== { TJclSimpleXMLElemsPrologEnumerator } ================================= - -{$IFDEF SUPPORTS_FOR_IN} -constructor TJclSimpleXMLElemsPrologEnumerator.Create(AList: TJclSimpleXMLElemsProlog); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -function TJclSimpleXMLElemsPrologEnumerator.GetCurrent: TJclSimpleXMLElem; -begin - Result := FList[FIndex]; -end; - -function TJclSimpleXMLElemsPrologEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FList.Count - 1; - if Result then - Inc(FIndex); -end; -{$ENDIF SUPPORTS_FOR_IN} - -//=== { TJclSimpleXMLElemsProlog } =========================================== - -constructor TJclSimpleXMLElemsProlog.Create(ASimpleXML: TJclSimpleXML); -var - CaseSensitive: Boolean; -begin - inherited Create; - FSimpleXML := ASimpleXML; - CaseSensitive := Assigned(ASimpleXML) and (sxoCaseSensitive in ASimpleXML.Options); - FElems := TJclSimpleItemHashedList.Create(CaseSensitive); -end; - -destructor TJclSimpleXMLElemsProlog.Destroy; -begin - Clear; - FreeAndNil(FElems); - inherited Destroy; -end; - -procedure TJclSimpleXMLElemsProlog.Clear; -begin - FElems.Clear; -end; - -function TJclSimpleXMLElemsProlog.GetCount: Integer; -begin - Result := FElems.Count; -end; - -function TJclSimpleXMLElemsProlog.GetItem(const Index: Integer): TJclSimpleXMLElem; -begin - Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); -end; - -procedure TJclSimpleXMLElemsProlog.LoadFromStringStream(StringStream: TJclStringStream); -{ - - -]> -Hello, world! - - Hello, world! -} -var - lPos: Integer; - St: TUCS4Array; - lEnd: Boolean; - lElem: TJclSimpleXMLElem; - Ch: UCS4; -begin - SetLength(St, 0); - lPos := 0; - - if SimpleXML <> nil then - SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); - - while StringStream.PeekUCS4(Ch) do - begin - case lPos of - 0: //We are waiting for a tag and thus avoiding spaces and any BOM - begin - if UnicodeIsWhiteSpace(Ch) then - // still waiting - else - if Ch = Ord('<') then - begin - lPos := 1; - St := UCS4Array(Ch); - end - else - FmtError(LoadResString(@RsEInvalidDocumentUnexpectedTextInFile), [StringStream.PeekPosition]); - end; - 1: //We are trying to determine the kind of the tag - begin - lElem := nil; - lEnd := False; - - if not UCS4ArrayEquals(St, ' 3) and (St[1] = Ord('?')) and UnicodeIsWhiteSpace(St[High(St)]) then - lElem := TJclSimpleXMLElemProcessingInstruction.Create(SimpleXML) - else - if (Length(St) > 1) and (St[1] <> Ord('!')) and (St[1] <> Ord('?')) then - lEnd := True; - - if lEnd then - Break - else - if lElem <> nil then - begin - FElems.Add(lElem); - lElem.LoadFromStringStream(StringStream); - SetLength(St, 0); - lPos := 0; - end; - end; - end; - end; -end; - -procedure TJclSimpleXMLElemsProlog.SaveToStringStream(StringStream: TJclStringStream); -var - I: Integer; -begin - FindHeader; - for I := 0 to Count - 1 do - Item[I].SaveToStringStream(StringStream, ''); -end; - -function VarXML: TVarType; -begin - Result := XMLVariant.VarType; -end; - -procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); -begin - TVarData(ADest).vType := VarXML; - TVarData(ADest).vAny := AXML; -end; - -function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; -begin - XMLCreateInto(Result, AXML); -end; - -function XMLCreate: Variant; -begin - XMLCreateInto(Result, TJclSimpleXMLElemClassic.Create(nil)); -end; - -//=== { TXMLVariant } ======================================================== - -procedure TXMLVariant.CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); -var - StorageStream: TStringStream; - ConversionString: TJclStringStream; -begin - if Source.vType = VarType then - begin - case AVarType of - varOleStr: - begin - StorageStream := TStringStream.Create(''); - try - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataFromOleStr(Dest, StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - varString: - begin - StorageStream := TStringStream.Create(''); - try - {$IFDEF SUPPORTS_UNICODE} - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - {$ELSE ~SUPPORTS_UNICODE} - ConversionString := TJclAnsiStream.Create(StorageStream, False); - {$ENDIF ~SUPPORTS_UNICODE} - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataFromStr(Dest, StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - {$IFDEF SUPPORTS_UNICODE_STRING} - varUString: - begin - StorageStream := TStringStream.Create(''); - try - ConversionString := TJclUTF16Stream.Create(StorageStream, False); - try - ConversionString.WriteBOM; - TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); - ConversionString.Flush; - finally - ConversionString.Free; - end; - VarDataClear(Dest); - Dest.VUString := nil; - Dest.VType := varUString; - UnicodeString(Dest.VUString) := UnicodeString(StorageStream.DataString); - finally - StorageStream.Free; - end; - end; - {$ENDIF SUPPORTS_UNICODE_STRING} - else - RaiseCastError; - end; - end - else - inherited CastTo(Dest, Source, AVarType); -end; - -procedure TXMLVariant.Clear(var V: TVarData); -begin - V.vType := varEmpty; - V.vAny := nil; -end; - -procedure TXMLVariant.Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); -begin - if Indirect and VarDataIsByRef(Source) then - VarDataCopyNoInd(Dest, Source) - else - begin - Dest.vType := Source.vType; - Dest.vAny := Source.vAny; - end; -end; - -function TXMLVariant.DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; -var - VXML, LXML: TJclSimpleXMLElem; - VElems: TJclSimpleXMLElems; - I, J, K: Integer; -begin - Result := False; - if (Length(Arguments) = 1) and (Arguments[0].vType in [vtInteger, vtExtended]) then - begin - VXML := TJclSimpleXMLElem(V.VAny); - K := Arguments[0].vInteger; - J := 0; - - if (K > 0) and VXML.HasItems then - begin - VElems := VXML.Items; - for I := 0 to VElems.Count - 1 do - if UpperCase(VElems.Item[I].Name) = Name then - begin - Inc(J); - if J = K then - Break; - end; - end; - - if (J = K) and (J < VXML.ItemCount) then - begin - LXML := VXML.Items[J]; - if LXML <> nil then - begin - Dest.vType := VarXML; - Dest.vAny := Pointer(LXML); - Result := True; - end - end; - end -end; - -function TXMLVariant.GetProperty(var Dest: TVarData; const V: TVarData; - const Name: string): Boolean; -var - VXML, LXML: TJclSimpleXMLElem; - lProp: TJclSimpleXMLProp; -begin - Result := False; - VXML := TJclSimpleXMLElem(V.VAny); - if VXML.HasItems then - begin - LXML := VXML.Items.ItemNamed[Name]; - if LXML <> nil then - begin - Dest.vType := VarXML; - Dest.vAny := Pointer(LXML); - Result := True; - end; - end; - if (not Result) and VXML.HasProperties then - begin - lProp := VXML.Properties.ItemNamed[Name]; - if lProp <> nil then - begin - VarDataFromOleStr(Dest, lProp.Value); - Result := True; - end; - end; -end; - -function TXMLVariant.IsClear(const V: TVarData): Boolean; -var - VXML: TJclSimpleXMLElem; -begin - VXML := TJclSimpleXMLElem(V.VAny); - Result := (VXML = nil) or (not VXML.HasItems); -end; - -function TXMLVariant.SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; - - function GetStrValue: string; - begin - try - Result := Value.VOleStr; - except - Result := ''; - end; - end; - -var - VXML, LXML: TJclSimpleXMLElem; - lProp: TJclSimpleXMLProp; -begin - Result := False; - VXML := TJclSimpleXMLElem(V.VAny); - if VXML.HasItems then - begin - LXML := VXML.Items.ItemNamed[Name]; - if LXML <> nil then - begin - LXML.Value := GetStrValue; - Result := True; - end; - end; - if (not Result) and VXML.HasProperties then - begin - lProp := VXML.Properties.ItemNamed[Name]; - if lProp <> nil then - begin - lProp.Value := GetStrValue; - Result := True; - end; - end; -end; - -procedure TJclSimpleXMLElemsProlog.Error(const S: string); -begin - raise EJclSimpleXMLError.Create(S); -end; - -procedure TJclSimpleXMLElemsProlog.FmtError(const S: string; - const Args: array of const); -begin - Error(Format(S, Args)); -end; - -procedure TJclSimpleXML.SetIndentString(const Value: string); -begin - // test if the new value is only made of spaces or tabs - if not StrContainsChars(Value, CharIsWhiteSpace, True) then - Exit; - FIndentString := Value; -end; - -procedure TJclSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic); -begin - if Value <> FRoot then - begin -// FRoot.FSimpleXML := nil; - FRoot := Value; -// FRoot.FSimpleXML := Self; - end; -end; - -function TJclSimpleXMLElemsProlog.GetEncoding: string; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.Encoding - else - Result := 'UTF-8'; -end; - -{$IFDEF SUPPORTS_FOR_IN} -function TJclSimpleXMLElemsProlog.GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; -begin - Result := TJclSimpleXMLElemsPrologEnumerator.Create(Self); -end; -{$ENDIF SUPPORTS_FOR_IN} - -function TJclSimpleXMLElemsProlog.GetStandAlone: Boolean; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.StandAlone - else - Result := False; -end; - -function TJclSimpleXMLElemsProlog.GetVersion: string; -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Result := Elem.Version - else - Result := '1.0'; -end; - -procedure TJclSimpleXMLElemsProlog.SetEncoding(const Value: string); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.Encoding := Value; -end; - -procedure TJclSimpleXMLElemsProlog.SetStandAlone(const Value: Boolean); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.StandAlone := Value; -end; - -procedure TJclSimpleXMLElemsProlog.SetVersion(const Value: string); -var - Elem: TJclSimpleXMLElemHeader; -begin - Elem := TJclSimpleXMLElemHeader(FindHeader); - if Elem <> nil then - Elem.Version := Value; -end; - -function TJclSimpleXMLElemsProlog.FindHeader: TJclSimpleXMLElem; -var - I: Integer; -begin - for I := 0 to Count - 1 do - if Item[I] is TJclSimpleXMLElemHeader then - begin - Result := Item[I]; - Exit; - end; - // (p3) if we get here, an xml header was not found - Result := TJclSimpleXMLElemHeader.Create(SimpleXML); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemSheet.Create('xml-stylesheet'); - Result.Properties.Add('type',AType); - Result.Properties.Add('href',AHRef); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemMSOApplication.Create('mso-application'); - Result.Properties.Add('progid',AProgId); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemComment.Create('', AValue); - FElems.Add(Result); -end; - -function TJclSimpleXMLElemsProlog.AddDocType(const AValue: string): TJclSimpleXMLElemDocType; -begin - // make sure there is an xml header - FindHeader; - Result := TJclSimpleXMLElemDocType.Create('', AValue); - FElems.Add(Result); -end; - -initialization - {$IFDEF UNITVERSIONING} - RegisterUnitVersion(HInstance, UnitVersioning); - {$ENDIF UNITVERSIONING} - -finalization - FreeAndNil(GlobalXMLVariant); - {$IFDEF UNITVERSIONING} - UnregisterUnitVersion(HInstance); - {$ENDIF UNITVERSIONING} - -end. + FOnSaveProg(Self, FSaveCurrent, FSaveCount); + end; +end; + +procedure TJclSimpleXML.DoTagParsed(const AName: string); +begin + if Assigned(FOnTagParsed) then + FOnTagParsed(Self, AName); +end; + +procedure TJclSimpleXML.DoValueParsed(const AName, AValue: string); +begin + if Assigned(FOnValue) then + FOnValue(Self, AName, AValue); +end; + +procedure TJclSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); +var + Stream: TMemoryStream; +begin + Stream := TMemoryStream.Create; + try + Stream.LoadFromFile(FileName); + LoadFromStream(Stream, Encoding, CodePage); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromResourceName(Instance: THandle; const ResName: string; + Encoding: TJclStringEncoding; CodePage: Word); +{$IFNDEF MSWINDOWS} +const + RT_RCDATA = PChar(10); +{$ENDIF !MSWINDOWS} +var + Stream: TResourceStream; +begin + Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); + try + LoadFromStream(Stream, Encoding, CodePage); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); +var + AOutStream: TStream; + AStringStream: TJclStringStream; + DoFree: Boolean; +begin + FRoot.Clear; + FProlog.Clear; + AOutStream := nil; + DoFree := False; + try + if Assigned(FOnDecodeStream) then + begin + AOutStream := TMemoryStream.Create; + DoFree := True; + FOnDecodeStream(Self, Stream, AOutStream); + AOutStream.Seek(0, soBeginning); + end + else + AOutStream := Stream; + + case Encoding of + seAnsi: + begin + AStringStream := TJclAnsiStream.Create(AOutStream, False); + TJclAnsiStream(AStringStream).CodePage := CodePage; + end; + seUTF8: + AStringStream := TJclUTF8Stream.Create(AOutStream, False); + seUTF16: + AStringStream := TJclUTF16Stream.Create(AOutStream, False); + else + AStringStream := TJclAutoStream.Create(AOutStream, False); + if CodePage <> CP_ACP then + TJclAutoStream(AStringStream).CodePage := CodePage; + end; + try + AStringStream.SkipBOM; + + LoadFromStringStream(AStringStream); + + // save codepage and encoding for future saves + if AStringStream is TJclAutoStream then + begin + FCodePage := TJclAutoStream(AStringStream).CodePage; + FEncoding := TJclAutoStream(AStringStream).Encoding; + end + else + if AStringStream is TJclAnsiStream then + begin + FCodePage := TJclAnsiStream(AStringStream).CodePage; + FEncoding := Encoding; + end + else + begin + FCodePage := CodePage; + FEncoding := Encoding; + end; + finally + AStringStream.Free; + end; + finally + if DoFree then + AOutStream.Free; + end; +end; + +procedure TJclSimpleXML.LoadFromStringStream(StringStream: TJclStringStream); +var + BufferSize: Integer; +begin + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); + + BufferSize := StringStream.BufferSize; + StringStream.BufferSize := 1; + + // Read doctype and so on + FProlog.LoadFromStringStream(StringStream); + + StringStream.BufferSize := BufferSize; + + // Read elements + FRoot.LoadFromStringStream(StringStream); + + if Assigned(FOnLoadProg) then + FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size); +end; + +procedure TJclSimpleXML.LoadFromString(const Value: string); +var + Stream: TStringStream; +begin + Stream := TStringStream.Create(Value {$IFDEF SUPPORTS_UNICODE}, TEncoding.Unicode{$ENDIF}); + try + LoadFromStream(Stream {$IFDEF SUPPORTS_UNICODE}, seUTF16, CP_UTF16LE{$ENDIF}); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word); +var + XMLHeader: TJclSimpleXMLElemHeader; + I: Integer; +begin + XMLHeader := nil; + for I := 0 to Prolog.Count - 1 do + if Prolog.Item[I] is TJclSimpleXMLElemHeader then + begin + XMLHeader := TJclSimpleXMLElemHeader(Prolog.Item[I]); + Break; + end; + if Assigned(XMLHeader) then + begin + CodePage := CodePageFromCharsetName(XMLHeader.Encoding); + case CodePage of + CP_UTF8: + Encoding := seUTF8; + CP_UTF16LE: + Encoding := seUTF16; + else + Encoding := seAnsi; + end; + end + else + begin + // restore from previous load + Encoding := FEncoding; + CodePage := FCodePage; + end; +end; + +procedure TJclSimpleXML.SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word); +var + Stream: TMemoryStream; +begin + Stream := TMemoryStream.Create; + try + SaveToStream(Stream, Encoding, CodePage); + Stream.SaveToFile(FileName); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word); +var + AOutStream: TStream; + AStringStream: TJclStringStream; + DoFree: Boolean; +begin + if Assigned(FOnEncodeStream) then + begin + AOutStream := TMemoryStream.Create; + DoFree := True; + end + else + begin + AOutStream := Stream; + DoFree := False; + end; + try + if Encoding = seAuto then + GetEncodingFromXMLHeader(Encoding, CodePage); + + case Encoding of + seUTF8: + begin + AStringStream := TJclUTF8Stream.Create(AOutStream, False); + FCodePage := CP_UTF8; + end; + seUTF16: + begin + AStringStream := TJclUTF16Stream.Create(AOutStream, False); + FCodePage := CP_UTF16LE; + end + else + AStringStream := TJclAnsiStream.Create(AOutStream); + TJclAnsiStream(AStringStream).CodePage := CodePage; + end; + try + if not (sxoDoNotSaveBOM in Options) then + AStringStream.WriteBOM; + SaveToStringStream(AStringStream); + AStringStream.Flush; + finally + AStringStream.Free; + end; + if Assigned(FOnEncodeStream) then + begin + AOutStream.Seek(0, soBeginning); + FOnEncodeStream(Self, AOutStream, Stream); + end; + finally + if DoFree then + AOutStream.Free; + end; +end; + +procedure TJclSimpleXML.SaveToStringStream(StringStream: TJclStringStream); +var + lCount: Integer; +begin + lCount := Root.ChildsCount + Prolog.Count; + FSaveCount := lCount; + FSaveCurrent := 0; + + if Assigned(FOnSaveProg) then + FOnSaveProg(Self, 0, lCount); + + if not (sxoDoNotSaveProlog in FOptions) then + Prolog.SaveToStringStream(StringStream); + + Root.SaveToStringStream(StringStream, BaseIndentString); + + if Assigned(FOnSaveProg) then + FOnSaveProg(Self, lCount, lCount); +end; + +function TJclSimpleXML.SaveToString: string; +begin + Result := SaveToStringEncoding(seAuto, CP_ACP); +end; + +function TJclSimpleXML.SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word): string; +var + Stream: TStringStream; +begin + {$IFDEF SUPPORTS_UNICODE} + // Use the same logic for seAuto as in SaveToStream for creating the TStringStream. + // Otherwise a Unicode-TStringStream is written to from a TJclAnsiStream proxy. + if Encoding = seAuto then + GetEncodingFromXMLHeader(Encoding, CodePage); + + case Encoding of + seAnsi: + Stream := TStringStream.Create('', TEncoding.{$IFDEF COMPILER16_UP}ANSI{$ELSE}Default{$ENDIF}); + seUTF8: + Stream := TStringStream.Create('', TEncoding.UTF8); + else + //seUTF16: + Stream := TStringStream.Create('', TEncoding.Unicode); + end; + {$ELSE ~SUPPORTS_UNICODE} + Stream := TStringStream.Create(''); + {$ENDIF ~SUPPORTS_UNICODE} + try + SaveToStream(Stream, Encoding, CodePage); + Result := Stream.DataString; + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXML.SetBaseIndentString(const Value: string); +begin + // test if the new value is only made of spaces or tabs + if not StrContainsChars(Value, CharIsWhiteSpace, True) then + Exit; + + FBaseIndentString := Value; +end; + +procedure TJclSimpleXML.SetFileName(const Value: TFileName); +begin + FFileName := Value; + LoadFromFile(Value); +end; + +//=== { TJclSimpleXMLElem } ================================================== + +procedure TJclSimpleXMLElem.Assign(Value: TJclSimpleXMLElem); +var + Elems: TJclSimpleXMLElem; + SrcElem, DestElem: TJclSimpleXMLElem; + I: Integer; + SrcProps, DestProps: TJclSimpleXMLProps; + SrcProp: TJclSimpleXMLProp; + SrcElems, DestElems: TJclSimpleXMLElems; +begin + Clear; + if Value = nil then + Exit; + Elems := TJclSimpleXMLElem(Value); + Name := Elems.Name; + Self.Value := Elems.Value; + SrcProps := Elems.FProps; + if Assigned(SrcProps) then + begin + DestProps := Properties; + for I := 0 to SrcProps.Count - 1 do + begin + SrcProp := SrcProps.Item[I]; + DestProps.Add(SrcProp.Name, SrcProp.Value); + end; + end; + + SrcElems := Elems.FItems; + if Assigned(SrcElems) then + begin + DestElems := Items; + for I := 0 to SrcElems.Count - 1 do + begin + // Create from the class type, so that the virtual constructor is called + // creating an element of the correct class type. + SrcElem := SrcElems.Item[I]; + DestElem := TJclSimpleXMLElemClass(SrcElem.ClassType).Create(SrcElem.Name, SrcElem.Value); + DestElem.Assign(SrcElem); + DestElems.Add(DestElem); + end; + end; +end; + +procedure TJclSimpleXMLElem.Clear; +begin + if FItems <> nil then + FItems.Clear; + if FProps <> nil then + FProps.Clear; +end; + +constructor TJclSimpleXMLElem.Create(ASimpleXML: TJclSimpleXML); +begin + Create; + FSimpleXML := ASimpleXML; +end; + +destructor TJclSimpleXMLElem.Destroy; +begin + FSimpleXML := nil; + FParent := nil; + Clear; + FreeAndNil(FItems); + FreeAndNil(FProps); + inherited Destroy; +end; + +procedure TJclSimpleXMLElem.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +procedure TJclSimpleXMLElem.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +procedure TJclSimpleXMLElem.GetBinaryValue(Stream: TStream); +var + I, J, ValueLength, RequiredStreamSize: Integer; + Buf: array [0..cBufferSize - 1] of Byte; + N1, N2: Byte; + + function NibbleCharToNibble(const AChar: Char): Byte; + begin + case AChar of + '0': Result := 0; + '1': Result := 1; + '2': Result := 2; + '3': Result := 3; + '4': Result := 4; + '5': Result := 5; + '6': Result := 6; + '7': Result := 7; + '8': Result := 8; + '9': Result := 9; + 'a', 'A': Result := 10; + 'b', 'B': Result := 11; + 'c', 'C': Result := 12; + 'd', 'D': Result := 13; + 'e', 'E': Result := 14; + 'f', 'F': Result := 15; + else + Result := 16; + end; + end; + + procedure PrepareNibbleCharMapping; + var + C: Char; + begin + if not PreparedNibbleCharMapping then + begin + for C := Low(Char) to High(Char) do + NibbleCharMapping[C] := NibbleCharToNibble(C); + PreparedNibbleCharMapping := True; + end; + end; + +var + CurrentStreamPosition: Integer; +begin + PrepareNibbleCharMapping; + I := 1; + J := 0; + ValueLength := Length(Value); + RequiredStreamSize := Stream.Position + ValueLength div 2; + if Stream.Size < RequiredStreamSize then + begin + CurrentStreamPosition := Stream.Position; + Stream.Size := RequiredStreamSize; + Stream.Seek(CurrentStreamPosition, soBeginning); + end; + while I < ValueLength do + begin + //faster replacement for St := '$' + Value[I] + Value[I + 1]; Buf[J] := StrToIntDef(St, 0); + N1 := NibbleCharMapping[Value[I]]; + N2 := NibbleCharMapping[Value[I + 1]]; + Inc(I, 2); + if (N1 > 15) or (N2 > 15) then + Buf[J] := 0 + else + Buf[J] := (N1 shl 4) or N2; + Inc(J); + if J = cBufferSize - 1 then //Buffered write to speed up the process a little + begin + Stream.Write(Buf, J); + J := 0; + end; + end; + Stream.Write(Buf, J); +end; + +function TJclSimpleXMLElem.GetChildIndex(const AChild: TJclSimpleXMLElem): Integer; +begin + if FItems = nil then + Result := -1 + else + Result := FItems.FElems.IndexOfSimpleItem(AChild); +end; + +function TJclSimpleXMLElem.GetChildsCount: Integer; +var + I: Integer; +begin + Result := 1; + if FItems <> nil then + for I := 0 to FItems.Count - 1 do + Result := Result + FItems[I].ChildsCount; +end; + +function TJclSimpleXMLElem.GetHasItems: Boolean; +begin + Result := Assigned(FItems) and (FItems.Count > 0); +end; + +function TJclSimpleXMLElem.GetHasProperties: Boolean; +begin + Result := Assigned(FProps) and (FProps.Count > 0); +end; + +function TJclSimpleXMLElem.GetItemCount: Integer; +begin + Result := 0; + if Assigned(FItems) then + Result := FItems.Count; +end; + +function TJclSimpleXMLElem.GetItems: TJclSimpleXMLElems; +begin + if FItems = nil then + FItems := TJclSimpleXMLElems.Create(Self); + Result := FItems; +end; + +function TJclSimpleXMLElem.GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer; +begin + Result := Items.NamedElems[AChild.Name].IndexOf(AChild); +end; + +function TJclSimpleXMLElem.GetPropertyCount: Integer; +begin + Result := 0; + if Assigned(FProps) then + Result := FProps.Count; +end; + +function TJclSimpleXMLElem.GetProps: TJclSimpleXMLProps; +begin + if FProps = nil then + FProps := TJclSimpleXMLProps.Create(Self); + Result := FProps; +end; + +procedure TJclSimpleXMLElem.LoadFromString(const Value: string); +var + Stream: TJclStringStream; + StrStream: TStringStream; +begin + StrStream := TStringStream.Create(Value); + try + Stream := TJclAutoStream.Create(StrStream); + try + LoadFromStringStream(Stream); + finally + Stream.Free; + end; + finally + StrStream.Free; + end; +end; + +function TJclSimpleXMLElem.SaveToString: string; +var + Stream: TJclStringStream; + StrStream: TStringStream; +begin + StrStream := TStringStream.Create(''); + try + Stream := TJclAutoStream.Create(StrStream); + try + SaveToStringStream(Stream); + Stream.Flush; + finally + Stream.Free; + end; + Result := StrStream.DataString; + finally + StrStream.Free; + end; +end; + +procedure TJclSimpleXMLElem.SetName(const Value: string); +begin + if (Value <> Name) and (Value <> '') then + begin + if (Parent <> nil) and (Name <> '') then + Parent.Items.DoItemRename(Self, Value); + inherited SetName(Value); + end; +end; + +//=== { TJclSimpleXMLNamedElemsEnumerator } ================================== + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLNamedElemsEnumerator.Create(AList: TJclSimpleXMLNamedElems); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLNamedElemsEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLNamedElemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLNamedElems } ============================================ + +constructor TJclSimpleXMLNamedElems.Create(AElems: TJclSimpleXMLElems; const AName: string); +begin + inherited Create; + FElems := AElems; + FName := AName; + FItems := TList.Create; +end; + +destructor TJclSimpleXMLNamedElems.Destroy; +begin + FItems.Free; + inherited Destroy; +end; + +function TJclSimpleXMLNamedElems.Add(const Value: Int64): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add(Value: TStream): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add(const Value: Boolean): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.Add: TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name); +end; + +function TJclSimpleXMLNamedElems.Add(const Value: string): TJclSimpleXMLElemClassic; +begin + Result := Elems.Add(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddCData(const Value: string): TJclSimpleXMLElemCData; +begin + Result := Elems.AddCData(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddComment(const Value: string): TJclSimpleXMLElemComment; +begin + Result := Elems.AddComment(Name, Value); +end; + +function TJclSimpleXMLNamedElems.AddFirst: TJclSimpleXMLElemClassic; +begin + Result := Elems.AddFirst(Name); +end; + +function TJclSimpleXMLNamedElems.AddText(const Value: string): TJclSimpleXMLElemText; +begin + Result := Elems.AddText(Name, Value); +end; + +procedure TJclSimpleXMLNamedElems.Clear; +var + Index: Integer; +begin + for Index := FItems.Count - 1 downto 0 do + Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); +end; + +procedure TJclSimpleXMLNamedElems.Delete(const Index: Integer); +begin + if (Index >= 0) and (Index < FItems.Count) then + Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index])); +end; + +function TJclSimpleXMLNamedElems.GetCount: Integer; +begin + Result := FItems.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLNamedElems.GetEnumerator: TJclSimpleXMLNamedElemsEnumerator; +begin + Result := TJclSimpleXMLNamedElemsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLNamedElems.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + if (Index >= 0) then + begin + While (Index >= Count) do + if Assigned(Elems.Parent) and Assigned(Elems.Parent.SimpleXML) and + (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then + Add + else + break; + if Index < Count then + Result := TJclSimpleXMLElem(FItems.Items[Index]) + else + Result := nil; + end + else + Result := nil; +end; + +function TJclSimpleXMLNamedElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; +begin + Result := FItems.IndexOf(Value); +end; + +function TJclSimpleXMLNamedElems.IndexOf(const Value: string): Integer; +var + Index: Integer; + NewItem: TJclSimpleXMLElem; +begin + Result := -1; + for Index := 0 to FItems.Count - 1 do + if TJclSimpleXMLElem(FItems.Items[Index]).Value = Value then + begin + Result := Index; + Break; + end; + if (Result = -1) and (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then + begin + NewItem := Elems.Add(Name, Value); + Result := FItems.IndexOf(NewItem); + end; +end; + +procedure TJclSimpleXMLNamedElems.Move(const CurIndex, NewIndex: Integer); +var + ElemsCurIndex, ElemsNewIndex: Integer; +begin + ElemsCurIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[CurIndex])); + ElemsNewIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[NewIndex])); + Elems.Move(ElemsCurIndex, ElemsNewIndex); + FItems.Move(CurIndex, NewIndex); +end; + +procedure TJclSimpleXMLNamedElems.SetName(const Value: string); +begin + raise EJclSimpleXMLError.CreateRes(@SReadOnlyProperty); +end; + +//=== { TJclSimpleXMLElemsEnumerator } ======================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLElemsEnumerator.Create(AList: TJclSimpleXMLElems); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLElemsEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLElemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLElems } ================================================= + +function TJclSimpleXMLElems.Add(const Name: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name, Value: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, IntToStr(Value)); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; +begin + if Value <> nil then + AddChild(Value); + Result := Value; +end; + +function TJclSimpleXMLElems.Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name, BoolToStr(Value)); + AddChild(Result); +end; + +function TJclSimpleXMLElems.Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; +var + Stream: TStringStream; + Buf: array [0..cBufferSize - 1] of Byte; + St: string; + I, Count: Integer; +begin + Stream := TStringStream.Create(''); + try + Buf[0] := 0; + repeat + Count := Value.Read(Buf, Length(Buf)); + St := ''; + for I := 0 to Count - 1 do + St := St + IntToHex(Buf[I], 2); + Stream.WriteString(St); + until Count = 0; + Result := TJclSimpleXMLElemClassic.Create(Name, Stream.DataString); + AddChild(Result); + finally + Stream.Free; + end; +end; + +procedure TJclSimpleXMLElems.AddChild(const Value: TJclSimpleXMLElem); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Add(Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; + + Notify(Value, opInsert); +end; + +procedure TJclSimpleXMLElems.AddChildFirst(const Value: TJclSimpleXMLElem); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Insert(0, Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Insert(0, Value); + end; + + Notify(Value, opInsert); +end; + +function TJclSimpleXMLElems.AddFirst(const Name: string): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + AddChildFirst(Result); +end; + +function TJclSimpleXMLElems.AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; +begin + if Value <> nil then + AddChildFirst(Value); + Result := Value; +end; + +function TJclSimpleXMLElems.AddComment(const Name, + Value: string): TJclSimpleXMLElemComment; +begin + Result := TJclSimpleXMLElemComment.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.AddCData(const Name, Value: string): TJclSimpleXMLElemCData; +begin + Result := TJclSimpleXMLElemCData.Create(Name, Value); + AddChild(Result); +end; + +function TJclSimpleXMLElems.AddText(const Name, Value: string): TJclSimpleXMLElemText; +begin + Result := TJclSimpleXMLElemText.Create(Name, Value); + AddChild(Result); +end; + +procedure TJclSimpleXMLElems.BinaryValue(const Name: string; Stream: TStream); +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamed(Name); + if Elem <> nil then + Elem.GetBinaryValue(Stream); +end; + +function TJclSimpleXMLElems.BoolValue(const Name: string; Default: Boolean): Boolean; +var + Elem: TJclSimpleXMLElem; +begin + try + Elem := GetItemNamedDefault(Name, BoolToStr(Default)); + if (Elem = nil) or (Elem.Value = '') then + Result := Default + else + Result := Elem.BoolValue; + except + Result := Default; + end; +end; + +procedure TJclSimpleXMLElems.Clear; +begin + if FElems <> nil then + FElems.Clear; + if FNamedElems <> nil then + FNamedElems.Clear; +end; + +constructor TJclSimpleXMLElems.Create(AParent: TJclSimpleXMLElem); +begin + inherited Create; + FParent := AParent; +end; + +procedure TJclSimpleXMLElems.CreateElems; +var + CaseSensitive: Boolean; +begin + if FElems = nil then + begin + CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) + and (sxoCaseSensitive in Parent.SimpleXML.Options); + FElems := TJclSimpleItemHashedList.Create(CaseSensitive); + end; +end; + +procedure TJclSimpleXMLElems.Delete(const Index: Integer); +var + Elem: TJclSimpleXMLElem; + NamedIndex: Integer; +begin + if (FElems <> nil) and (Index >= 0) and (Index < FElems.Count) then + begin + Elem := TJclSimpleXMLElem(FElems.SimpleItems[Index]); + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Elem.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Elem); + end; + FElems.Delete(Index); + end; +end; + +procedure TJclSimpleXMLElems.Delete(const Name: string); +begin + if FElems <> nil then + Delete(FElems.IndexOfName(Name)); +end; + +destructor TJclSimpleXMLElems.Destroy; +begin + FParent := nil; + Clear; + FreeAndNil(FElems); + FreeAndNil(FNamedElems); + inherited Destroy; +end; + +procedure TJclSimpleXMLElems.DoItemRename(Value: TJclSimpleXMLElem; const Name: string); +var + NamedIndex: Integer; +begin + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); + + NamedIndex := FNamedElems.IndexOfName(Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; +end; + +function TJclSimpleXMLElems.FloatValue(const Name: string; + const Default: Extended): Extended; +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamedDefault(Name, FloatToStr(Default)); + if Elem = nil then + Result := Default + else + Result := Elem.FloatValue; +end; + +function TJclSimpleXMLElems.GetCount: Integer; +begin + if FElems = nil then + Result := 0 + else + Result := FElems.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLElems.GetEnumerator: TJclSimpleXMLElemsEnumerator; +begin + Result := TJclSimpleXMLElemsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLElems.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + if (FElems = nil) or (Index > FElems.Count) then + Result := nil + else + Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); +end; + +function TJclSimpleXMLElems.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem; +var + I: Integer; +begin + Result := nil; + if FElems <> nil then + begin + I := FElems.IndexOfName(Name); + if I <> -1 then + Result := TJclSimpleXMLElem(FElems.SimpleItems[I]) + else + if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then + Result := Add(Name, Default); + end + else + if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then + Result := Add(Name, Default); +end; + +function TJclSimpleXMLElems.GetNamedElems(const Name: string): TJclSimpleXMLNamedElems; +var + NamedIndex: Integer; + CaseSensitive: Boolean; +begin + if FNamedElems = nil then + begin + CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML) + and (sxoCaseSensitive in Parent.SimpleXML.Options); + FNamedElems := TJclSimpleItemHashedList.Create(CaseSensitive); + end; + NamedIndex := FNamedElems.IndexOfName(Name); + if NamedIndex = -1 then + begin + Result := TJclSimpleXMLNamedElems.Create(Self, Name); + FNamedElems.Add(Result); + if FElems <> nil then + for NamedIndex := 0 to FElems.Count - 1 do + if FElems.SimpleItems[NamedIndex].Name = Name then + Result.FItems.Add(FElems.SimpleItems[NamedIndex]); + end + else + Result := TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]); +end; + +function TJclSimpleXMLElems.GetItemNamed(const Name: string): TJclSimpleXMLElem; +begin + Result := GetItemNamedDefault(Name, ''); +end; + +function TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64; +var + Elem: TJclSimpleXMLElem; +begin + Elem := GetItemNamedDefault(Name, IntToStr(Default)); + if Elem = nil then + Result := Default + else + Result := Elem.IntValue; +end; + +procedure TJclSimpleXMLElems.LoadFromStringStream(StringStream: TJclStringStream); +type + TReadStatus = (rsWaitingTag, rsReadingTagKind); +var + lPos: TReadStatus; + St: TUCS4Array; + lElem: TJclSimpleXMLElem; + Ch: UCS4; + ContainsText, ContainsWhiteSpace, KeepWhiteSpace: Boolean; + SimpleXML: TJclSimpleXML; +begin + SetLength(St, 0); + lPos := rsWaitingTag; + SimpleXML := Parent.SimpleXML; + KeepWhiteSpace := (SimpleXML <> nil) and (sxoKeepWhitespace in SimpleXML.Options); + ContainsText := False; + ContainsWhiteSpace := False; + + // We read from a stream, thus replacing the existing items + Clear; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + rsWaitingTag: //We are waiting for a tag and thus avoiding spaces + begin + if Ch = Ord('<') then + begin + lPos := rsReadingTagKind; + St := UCS4Array(Ch); + end + else + if UnicodeIsWhiteSpace(Ch) then + ContainsWhiteSpace := True + else + ContainsText := True; + end; + + rsReadingTagKind: //We are trying to determine the kind of the tag + begin + lElem := nil; + case Ch of + Ord('/'): + if UCS4ArrayEquals(St, '<') then + begin // "'), Ord(':'): //This should be a classic tag + begin // " + lElem := TJclSimpleXMLElemClassic.Create; + SetLength(St, 0); + lPos := rsWaitingTag; + end; + else + if ContainsText or (ContainsWhiteSpace and KeepWhiteSpace) then + begin + // inner text + lElem := TJclSimpleXMLElemText.Create; + lPos := rsReadingTagKind; + ContainsText := False; + ContainsWhiteSpace := False; + end + else + begin + if not UCS4ArrayEquals(St, ' nil then + begin + CreateElems; + Notify(lElem, opInsert); + lElem.LoadFromStringStream(StringStream); + FElems.Add(lElem); + end; + end; + end; + end; +end; + +procedure TJclSimpleXMLElems.Notify(Value: TJclSimpleXMLElem; Operation: TOperation); +var + NamedIndex: Integer; +begin + case Operation of + opRemove: + if Value.Parent = Parent then // Only remove if we have it + begin + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value); + end; + FElems.Remove(Value); + Value.FParent := nil; + Value.FSimpleXML := nil; + end; + opInsert: + begin + Value.FParent := Parent; + Value.FSimpleXML := Parent.SimpleXML; + end; + end; +end; + +function TJclSimpleXMLElems.Remove(Value: TJclSimpleXMLElem): Integer; +begin + if FElems = nil + then Result := -1 // like TList.IndexOf(alien) + else begin + Result := FElems.IndexOfSimpleItem(Value); + Notify(Value, opRemove); + end; +end; + +procedure TJclSimpleXMLElems.SaveToStringStream(StringStream: TJclStringStream; + const Level: string); +var + I: Integer; +begin + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream, Level); +end; + +function TJclSimpleXMLElems.SimpleCompare(Elems: TJclSimpleXMLElems; Index1, + Index2: Integer): Integer; +begin + Result := CompareText(Elems.Item[Index1].Name, Elems.Item[Index2].Name); +end; + +function TJclSimpleXMLElems.Value(const Name, Default: string): string; +var + Elem: TJclSimpleXMLElem; +begin + Result := ''; + Elem := GetItemNamedDefault(Name, Default); + if Elem = nil then + Result := Default + else + Result := Elem.Value; +end; + +procedure TJclSimpleXMLElems.Move(const CurIndex, NewIndex: Integer); +begin + if FElems <> nil then + FElems.Move(CurIndex, NewIndex); +end; + +function TJclSimpleXMLElems.IndexOf(const Value: TJclSimpleXMLElem): Integer; +begin + if FElems = nil then + Result := -1 + else + Result := FElems.IndexOfSimpleItem(Value); +end; + +function TJclSimpleXMLElems.IndexOf(const Name: string): Integer; +begin + if FElems = nil then + Result := -1 + else + Result := FElems.IndexOfName(Name); +end; + +procedure TJclSimpleXMLElems.InsertChild(const Value: TJclSimpleXMLElem; Index: Integer); +var + NamedIndex: Integer; +begin + CreateElems; + + // If there already is a container, notify it to remove the element + if Assigned(Value.Parent) then + Value.Parent.Items.Notify(Value, opRemove); + + FElems.Insert(Index, Value); + + if FNamedElems <> nil then + begin + NamedIndex := FNamedElems.IndexOfName(Value.Name); + if NamedIndex >= 0 then + TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value); + end; + + Notify(Value, opInsert); +end; + +function TJclSimpleXMLElems.Insert(Value: TJclSimpleXMLElem; + Index: Integer): TJclSimpleXMLElem; +begin + if Value <> nil then + InsertChild(Value, Index); + Result := Value; +end; + +function TJclSimpleXMLElems.Insert(const Name: string; + Index: Integer): TJclSimpleXMLElemClassic; +begin + Result := TJclSimpleXMLElemClassic.Create(Name); + InsertChild(Result, Index); +end; + +procedure QuickSort(Elems: TJclSimpleXMLElems; List: TList; L, R: Integer; + AFunction: TJclSimpleXMLElemCompare); +var + I, J, M: Integer; +begin + repeat + I := L; + J := R; + M := (L + R) shr 1; + repeat + while AFunction(Elems, I, M) < 0 do + Inc(I); + while AFunction(Elems, J, M) > 0 do + Dec(J); + if I < J then + begin + List.Exchange(I, J); + Inc(I); + Dec(J); + end + else + if I = J then + begin + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(Elems, List, L, J, AFunction); + L := I; + until I >= R; +end; + +procedure TJclSimpleXMLElems.CustomSort(AFunction: TJclSimpleXMLElemCompare); +begin + if FElems <> nil then + QuickSort(Self, FElems, 0, FElems.Count - 1, AFunction); +end; + +procedure TJclSimpleXMLElems.Sort; +begin + CustomSort(SimpleCompare); +end; + +//=== { TJclSimpleXMLPropsEnumerator } ======================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLPropsEnumerator.Create(AList: TJclSimpleXMLProps); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLPropsEnumerator.GetCurrent: TJclSimpleXMLProp; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLPropsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLProps } ================================================= + +function TJclSimpleXMLProps.Add(const Name, Value: string): TJclSimpleXMLProp; +begin + if FProperties = nil then + FProperties := TStringList.Create; + Result := TJclSimpleXMLProp.Create(Parent, Name, Value); + FProperties.AddObject(Name, Result); +end; + +function TJclSimpleXMLProps.Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; +begin + Result := Add(Name, IntToStr(Value)); +end; + +function TJclSimpleXMLProps.Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; +begin + Result := Add(Name, BoolToStr(Value)); +end; + +{$IFDEF SUPPORTS_UNICODE} +function TJclSimpleXMLProps.Add(const Name: string; + const Value: AnsiString): TJclSimpleXMLProp; +begin + Result := Add(Name, string(Value)); +end; +{$ENDIF SUPPORTS_UNICODE} + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; +begin + if FProperties = nil then + FProperties := TStringList.Create; + Result := TJclSimpleXMLProp.Create(Parent, Name, Value); + FProperties.InsertObject(Index, Name, Result); +end; + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; +begin + Result := Insert(Index, Name, IntToStr(Value)); +end; + +function TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; +begin + Result := Insert(Index, Name, BoolToStr(Value)); +end; + +function TJclSimpleXMLProps.BoolValue(const Name: string; Default: Boolean): Boolean; +var + Prop: TJclSimpleXMLProp; +begin + try + Prop := GetItemNamedDefault(Name, BoolToStr(Default)); + if (Prop = nil) or (Prop.Value = '') then + Result := Default + else + Result := Prop.BoolValue; + except + Result := Default; + end; +end; + +procedure TJclSimpleXMLProps.Clear; +var + I: Integer; +begin + if FProperties <> nil then + begin + for I := 0 to FProperties.Count - 1 do + begin + TJclSimpleXMLProp(FProperties.Objects[I]).Free; + FProperties.Objects[I] := nil; + end; + FProperties.Clear; + end; +end; + +procedure TJclSimpleXMLProps.Delete(const Index: Integer); +begin + if (FProperties <> nil) and (Index >= 0) and (Index < FProperties.Count) then + begin + TObject(FProperties.Objects[Index]).Free; + FProperties.Delete(Index); + end; +end; + +constructor TJclSimpleXMLProps.Create(AParent: TJclSimpleXMLElem); +begin + inherited Create; + FParent := AParent; +end; + +procedure TJclSimpleXMLProps.Delete(const Name: string); +begin + if FProperties <> nil then + Delete(FProperties.IndexOf(Name)); +end; + +destructor TJclSimpleXMLProps.Destroy; +begin + FParent := nil; + Clear; + FreeAndNil(FProperties); + inherited Destroy; +end; + +procedure TJclSimpleXMLProps.DoItemRename(Value: TJclSimpleXMLProp; const Name: string); +var + I: Integer; +begin + if FProperties = nil then + Exit; + I := FProperties.IndexOfObject(Value); + if I <> -1 then + FProperties[I] := Name; +end; + +procedure TJclSimpleXMLProps.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +function TJclSimpleXMLProps.FloatValue(const Name: string; + const Default: Extended): Extended; +var + Prop: TJclSimpleXMLProp; +begin + Prop := GetItemNamedDefault(Name, FloatToStr(Default)); + if Prop = nil then + Result := Default + else + Result := Prop.FloatValue; +end; + +procedure TJclSimpleXMLProps.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +function TJclSimpleXMLProps.GetCount: Integer; +begin + if FProperties = nil then + Result := 0 + else + Result := FProperties.Count; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLProps.GetEnumerator: TJclSimpleXMLPropsEnumerator; +begin + Result := TJclSimpleXMLPropsEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLProps.GetItem(const Index: Integer): TJclSimpleXMLProp; +begin + if FProperties <> nil then + Result := TJclSimpleXMLProp(FProperties.Objects[Index]) + else + Result := nil; +end; + +function TJclSimpleXMLProps.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp; +var + I: Integer; +begin + Result := nil; + if FProperties <> nil then + begin + I := FProperties.IndexOf(Name); + if I <> -1 then + Result := TJclSimpleXMLProp(FProperties.Objects[I]) + else + if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then + Result := Add(Name, Default); + end + else + if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then + begin + Result := Add(Name, Default); + end; +end; + +function TJclSimpleXMLProps.GetItemNamed(const Name: string): TJclSimpleXMLProp; +begin + Result := GetItemNamedDefault(Name, ''); +end; + +function TJclSimpleXMLProps.GetSimpleXML: TJclSimpleXML; +begin + if FParent <> nil then + Result := FParent.SimpleXML + else + Result := nil; +end; + +function TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64; +var + Prop: TJclSimpleXMLProp; +begin + Prop := GetItemNamedDefault(Name, IntToStr(Default)); + if Prop = nil then + Result := Default + else + Result := Prop.IntValue; +end; + +procedure TJclSimpleXMLProps.LoadFromStringStream(StringStream: TJclStringStream); +// +//Stop on / or ? or > +type + TPosType = ( + ptWaiting, + ptReadingName, + ptStartingContent, + ptReadingValue, + ptSpaceBeforeEqual + ); +var + lPos: TPosType; + lName, lValue, lNameSpace: TUCS4Array; + sValue: string; + lPropStart: UCS4; + Ch: UCS4; +begin + SetLength(lValue, 0); + SetLength(lNameSpace, 0); + SetLength(lName, 0); + lPropStart := Ord(NativeSpace); + lPos := ptWaiting; + + // We read from a stream, thus replacing the existing properties + Clear; + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + ptWaiting: //We are waiting for a property + begin + if UnicodeIsWhiteSpace(Ch) then + StringStream.ReadUCS4(Ch) + else + if UnicodeIsIdentifierStart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord('_')) then + begin + StringStream.ReadUCS4(Ch); + lName := UCS4Array(Ch); + SetLength(lNameSpace, 0); + lPos := ptReadingName; + end + else + if (Ch = Ord('/')) or (Ch = Ord('>')) or (Ch = Ord('?')) then + // end of properties + Break + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptReadingName: //We are reading a property name + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + begin + UCS4ArrayConcat(lName, Ch); + end + else + if Ch = Ord(':') then + begin + lNameSpace := lName; + SetLength(lName, 0); + end + else + if Ch = Ord('=') then + lPos := ptStartingContent + else + if UnicodeIsWhiteSpace(Ch) then + lPos := ptSpaceBeforeEqual + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptStartingContent: //We are going to start a property content + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsWhiteSpace(Ch) then + // ignore white space + else + if (Ch = Ord('''')) or (Ch = Ord('"')) then + begin + lPropStart := Ch; + SetLength(lValue, 0); + lPos := ptReadingValue; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte_), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + + ptReadingValue: //We are reading a property + begin + StringStream.ReadUCS4(Ch); + if Ch = lPropStart then + begin + sValue := UCS4ToString(lValue); + if GetSimpleXML <> nil then + GetSimpleXML.DoDecodeValue(sValue); + with Add(UCS4ToString(lName), sValue) do + NameSpace := UCS4ToString(lNameSpace); + lPos := ptWaiting; + end + else + UCS4ArrayConcat(lValue, Ch); + end; + + ptSpaceBeforeEqual: // We are reading the white space between a property name and the = sign + begin + StringStream.ReadUCS4(Ch); + if UnicodeIsWhiteSpace(Ch) then + // more white space, stay in this state and ignore + else + if Ch = Ord('=') then + lPos := ptStartingContent + else + FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + else + Assert(False, RsEUnexpectedValueForLPos); + end; + end; +end; + +procedure TJclSimpleXMLProps.SaveToStringStream(StringStream: TJclStringStream); +var + I: Integer; +begin + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream); +end; + +function TJclSimpleXMLProps.Value(const Name, Default: string): string; +var + Prop: TJclSimpleXMLProp; +begin + Result := ''; + Prop := GetItemNamedDefault(Name, Default); + if Prop = nil then + Result := Default + else + Result := Prop.Value; +end; + +//=== { TJclSimpleXMLProp } ================================================== + +constructor TJclSimpleXMLProp.Create(AParent: TJclSimpleXMLElem; const AName, AValue: string); +begin + inherited Create(AName, AValue); + FParent := AParent; +end; + +function TJclSimpleXMLProp.GetSimpleXML: TJclSimpleXML; +begin + if FParent <> nil then + Result := FParent.SimpleXML + else + Result := nil; +end; + +procedure TJclSimpleXMLProp.SaveToStringStream(StringStream: TJclStringStream); +var + AEncoder: TJclSimpleXML; + Tmp: string; +begin + AEncoder := GetSimpleXML; + Tmp := Value; + if AEncoder <> nil then + AEncoder.DoEncodeValue(Tmp); + if NameSpace <> '' then + Tmp := Format(' %s:%s="%s"', [NameSpace, Name, Tmp]) + else + Tmp := Format(' %s="%s"', [Name, tmp]); + StringStream.WriteString(Tmp, 1, Length(Tmp)); +end; + +procedure TJclSimpleXMLProp.SetName(const Value: string); +begin + if (Value <> Name) and (Value <> '') then + begin + if (Parent <> nil) and (Name <> '') then + FParent.Properties.DoItemRename(Self, Value); + inherited SetName(Value); + end; +end; + +//=== { TJclSimpleXMLElemClassic } =========================================== + +procedure TJclSimpleXMLElemClassic.LoadFromStringStream(StringStream: TJclStringStream); +// +//foorbeuhbar +//foorbeuhbar +type + TReadStatus = (rsWaitingOpeningTag, rsOpeningName, rsTypeOpeningTag, rsEndSingleTag, + rsWaitingClosingTag1, rsWaitingClosingTag2, rsClosingName); +var + lPos: TReadStatus; + St, lName, lNameSpace: TUCS4Array; + sValue: string; + Ch: UCS4; +begin + SetLength(St, 0); + SetLength(lName, 0); + SetLength(lNameSpace, 0); + sValue := ''; + lPos := rsWaitingOpeningTag; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + rsWaitingOpeningTag: // wait beginning of tag + if Ch = Ord('<') then + lPos := rsOpeningName // read name + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsOpeningName: + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + UCS4ArrayConcat(St, Ch) + else + if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then + begin + lNameSpace := St; + SetLength(st, 0); + end + else + if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then + // whitespace after "<" (no name) + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) + else + if UnicodeIsWhiteSpace(Ch) then + begin + lName := St; + SetLength(St, 0); + Properties.LoadFromStringStream(StringStream); + lPos := rsTypeOpeningTag; + end + else + if Ch = Ord('/') then // single tag + begin + lName := St; + lPos := rsEndSingleTag + end + else + if Ch = Ord('>') then // 2 tags + begin + lName := St; + SetLength(St, 0); + //Load elements + Items.LoadFromStringStream(StringStream); + lPos := rsWaitingClosingTag1; + end + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsTypeOpeningTag: + if UnicodeIsWhiteSpace(Ch) then + // nothing, spaces after name or properties + else + if Ch = Ord('/') then + lPos := rsEndSingleTag // single tag + else + if Ch = Ord('>') then // 2 tags + begin + //Load elements + Items.LoadFromStringStream(StringStream); + lPos := rsWaitingClosingTag1; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsEndSingleTag: + if Ch = Ord('>') then + Break + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsWaitingClosingTag1: + if UnicodeIsWhiteSpace(Ch) then + // nothing, spaces before closing tag + else + if Ch = Ord('<') then + lPos := rsWaitingClosingTag2 + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsWaitingClosingTag2: + if Ch = Ord('/') then + lPos := rsClosingName + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsClosingName: + if UnicodeIsWhiteSpace(Ch) or (Ch = Ord('>')) then + begin + if Length(lNameSpace) > 0 then + begin + if not StrSame(UCS4ToString(lNameSpace) + ':' + UCS4ToString(lName), UCS4ToString(St)) then + FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); + end + else + if not UCS4ArrayEquals(lName, St) then + FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]); + //Set value if only one sub element + //This might reduce speed, but this is for compatibility issues + if (Items.Count = 1) and (Items[0] is TJclSimpleXMLElemText) then + begin + sValue := Items[0].Value; + Items.Clear; + // free some memory + FreeAndNil(FItems); + end; + Break; + end + else + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord(':')) then + UCS4ArrayConcat(St, Ch) + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + end; + end; + + Name := UCS4ToString(lName); + if SimpleXML <> nil then + SimpleXML.DoDecodeValue(sValue); + Value := sValue; + NameSpace := UCS4ToString(lNameSpace); + + if SimpleXML <> nil then + begin + SimpleXML.DoTagParsed(Name); + SimpleXML.DoValueParsed(Name, sValue); + end; +end; + +procedure TJclSimpleXMLElemClassic.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St, AName, tmp: string; + LevelAdd: string; + AutoIndent: Boolean; +begin + if(NameSpace <> '') then + AName := NameSpace + ':' + Name + else + AName := Name; + + if Name <> '' then + begin + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(AName); + St := Level + '<' + AName; + + StringStream.WriteString(St, 1, Length(St)); + if Assigned(FProps) then + FProps.SaveToStringStream(StringStream); + end; + + AutoIndent := (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options); + + if (ItemCount = 0) then + begin + tmp := Value; + if (Name <> '') then + begin + if Value = '' then + begin + if AutoIndent then + St := '/>' + sLineBreak + else + St := '/>'; + end + else + begin + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(tmp); + if AutoIndent then + St := '>' + tmp + '' + sLineBreak + else + St := '>' + tmp + ''; + end; + StringStream.WriteString(St, 1, Length(St)); + end; + end + else + begin + if (Name <> '') then + begin + if AutoIndent then + St := '>' + sLineBreak + else + St := '>'; + StringStream.WriteString(St, 1, Length(St)); + end; + if AutoIndent then + begin + LevelAdd := SimpleXML.IndentString; + end; + FItems.SaveToStringStream(StringStream, Level + LevelAdd); + if Name <> '' then + begin + if AutoIndent then + St := Level + '' + sLineBreak + else + St := Level + ''; + StringStream.WriteString(St, 1, Length(St)); + end; + end; + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemComment } =========================================== + +procedure TJclSimpleXMLElemComment.LoadFromStringStream(StringStream: TJclStringStream); +// +const + CS_START_COMMENT = ''; +var + lPos: Integer; + St: TUCS4Array; + Ch: UCS4; + lOk: Boolean; +begin + SetLength(St, 0); + lPos := 1; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..4: //' + sLineBreak + else + St := '-->'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemCData } ============================================= + +procedure TJclSimpleXMLElemCData.LoadFromStringStream(StringStream: TJclStringStream); +//Hello, world!]]> +const + CS_START_CDATA = ''; +var + lPos: Integer; + St: TUCS4Array; + Ch: UCS4; + lOk: Boolean; +begin + SetLength(St, 0); + lPos := 1; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..9: // + if Ch = Ord(CS_STOP_CDATA[lPos]) then + begin + lOk := True; + Break; //End if + end + else + // ]]] + if Ch = Ord(CS_STOP_CDATA[lPos-1]) then + UCS4ArrayConcat(St, Ord(']')) + else + begin + UCS4ArrayConcat(St, Ord(']')); + UCS4ArrayConcat(St, Ord(']')); + UCS4ArrayConcat(St, Ch); + Dec(lPos, 2); + end; + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCDATAUnexpectedEndOfData), [StringStream.PeekPosition]); + + Value := UCS4ToString(St); + Name := ''; + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', Value); +end; + +procedure TJclSimpleXMLElemCData.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St: string; +begin + St := Level + ' '' then + StringStream.WriteString(Value, 1, Length(Value)); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := ']]>' + sLineBreak + else + St := ']]>'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemText } ============================================== + +procedure TJclSimpleXMLElemText.LoadFromStringStream(StringStream: TJclStringStream); +var + Ch: UCS4; + USt: TUCS4Array; + St, TrimValue: string; +begin + SetLength(USt, 0); + St := ''; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case Ch of + Ord('<'): + //Quit text + Break; + else + begin + StringStream.ReadUCS4(Ch); + UCS4ArrayConcat(USt, Ch); + end; + end; + end; + + St := UCS4ToString(USt); + + if Assigned(SimpleXML) then + begin + SimpleXML.DoDecodeValue(St); + + TrimValue := St; + if sxoTrimPrecedingTextWhitespace in SimpleXML.Options then + TrimValue := TrimLeft(TrimValue); + if sxoTrimFollowingTextWhitespace in SimpleXML.Options then + TrimValue := TrimRight(TrimValue); + if (TrimValue <> '') or not (sxoKeepWhitespace in SimpleXML.Options) then + St := TrimValue; + end; + + Value := St; + Name := ''; + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', St); +end; + +procedure TJclSimpleXMLElemText.SaveToStringStream(StringStream: TJclStringStream; const Level: string); +var + St, tmp: string; +begin + // should never be used + if Value <> '' then + begin + tmp := Value; + if SimpleXML <> nil then + SimpleXML.DoEncodeValue(tmp); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := Level + tmp + sLineBreak + else + St := Level + tmp; + StringStream.WriteString(St, 1, Length(St)); + end; + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemProcessingInstruction } ============================= + +procedure TJclSimpleXMLElemProcessingInstruction.LoadFromStringStream( + StringStream: TJclStringStream); +type + TReadStatus = (rsWaitingOpeningTag, rsOpeningTag, rsOpeningName, rsEndTag1, rsEndTag2); +var + lPos: TReadStatus; + lOk: Boolean; + St, lName, lNameSpace: TUCS4Array; + Ch: UCS4; +begin + SetLength(St, 0); + SetLength(lName, 0); + SetLength(lNameSpace, 0); + lPos := rsWaitingOpeningTag; + lOk := False; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + rsWaitingOpeningTag: // wait beginning of tag + if Ch = Ord('<') then + lPos := rsOpeningTag + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsOpeningTag: + if Ch = Ord('?') then + lPos := rsOpeningName // read name + else + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsOpeningName: + if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then + UCS4ArrayConcat(St, Ch) + else + if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then + begin + lNameSpace := St; + SetLength(St, 0); + end + else + if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then + // whitespace after "<" (no name) + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]) + else + if UnicodeIsWhiteSpace(Ch) then + begin + lName := St; + SetLength(St, 0); + Properties.LoadFromStringStream(StringStream); + lPos := rsEndTag1; + end + else + if Ch = Ord('?') then + begin + lName := St; + lPos := rsEndTag2; + end + else + // other invalid characters + FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]); + + rsEndTag1: + if Ch = Ord('?') then + lPos := rsEndTag2 + else + if not UnicodeIsWhiteSpace(Ch) then + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + + rsEndTag2: + if Ch = Ord('>') then + begin + lOk := True; + Break; + end + else + FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]); + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); + + Name := UCS4ToString(lName); + NameSpace := UCS4ToString(lNameSpace); +end; + +procedure TJclSimpleXMLElemProcessingInstruction.SaveToStringStream( + StringStream: TJclStringStream; const Level: string); +var + St: string; +begin + St := Level + ' '' then + St := St + NameSpace + ':' + Name + else + St := St + Name; + StringStream.WriteString(St, 1, Length(St)); + if Assigned(FProps) then + FProps.SaveToStringStream(StringStream); + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := '?>' + sLineBreak + else + St := '?>'; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemHeader } ============================================ + +constructor TJclSimpleXMLElemHeader.Create; +begin + inherited Create; + + Name := 'xml'; +end; + +function TJclSimpleXMLElemHeader.GetEncoding: string; +var + ASimpleXML: TJclSimpleXML; + DefaultCodePage: Word; +begin + ASimpleXML := SimpleXML; + if Assigned(ASimpleXML) then + begin + DefaultCodePage := ASimpleXML.CodePage; + {$IFDEF MSWINDOWS} + if DefaultCodePage = CP_ACP then + DefaultCodePage := GetAcp; + {$ENDIF MSWINDOWS} + end + else + {$IFDEF UNICODE} + DefaultCodePage := CP_UTF16LE; + {$ELSE ~UNICODE} + {$IFDEF MSWINDOWS} + DefaultCodePage := GetACP; + {$ELSE ~MSWINDOWS} + DefaultCodePage := 1252; + {$ENDIF ~MSWINDOWS} + {$ENDIF ~UNICODE} + Result := Properties.Value('encoding', CharsetNameFromCodePage(DefaultCodePage)); +end; + +function TJclSimpleXMLElemHeader.GetStandalone: Boolean; +begin + Result := Properties.Value('standalone') = 'yes'; +end; + +function TJclSimpleXMLElemHeader.GetVersion: string; +begin + Result := Properties.Value('version', '1.0'); +end; + +procedure TJclSimpleXMLElemHeader.LoadFromStringStream(StringStream: TJclStringStream); +// +var + CodePage: Word; + EncodingProp: TJclSimpleXMLProp; +begin + inherited LoadFromStringStream(StringStream); + + if Assigned(FProps) then + EncodingProp := FProps.ItemNamed['encoding'] + else + EncodingProp := nil; + if Assigned(EncodingProp) and (EncodingProp.Value <> '') then + CodePage := CodePageFromCharsetName(EncodingProp.Value) + else + CodePage := CP_ACP; + + // set current stringstream codepage + if StringStream is TJclAutoStream then + TJclAutoStream(StringStream).CodePage := CodePage + else + if StringStream is TJclAnsiStream then + TJclAnsiStream(StringStream).CodePage := CodePage + else + if not (StringStream is TJclUTF8Stream) and not (StringStream is TJclUTF16Stream) then + Error(LoadResString(@RsENoCharset)); +end; + +procedure TJclSimpleXMLElemHeader.SaveToStringStream( + StringStream: TJclStringStream; const Level: string); +begin + SetVersion(GetVersion); + SetEncoding(GetEncoding); + SetStandalone(GetStandalone); + + inherited SaveToStringStream(StringStream, Level); +end; + +procedure TJclSimpleXMLElemHeader.SetEncoding(const Value: string); +var + Prop: TJclSimpleXMLProp; +begin + Prop := Properties.ItemNamed['encoding']; + if Assigned(Prop) then + Prop.Value := Value + else + Properties.Add('encoding', Value); +end; + +procedure TJclSimpleXMLElemHeader.SetStandalone(const Value: Boolean); +var + Prop: TJclSimpleXMLProp; +const + BooleanValues: array [Boolean] of string = ('no', 'yes'); +begin + Prop := Properties.ItemNamed['standalone']; + if Assigned(Prop) then + Prop.Value := BooleanValues[Value] + else + Properties.Add('standalone', BooleanValues[Value]); +end; + +procedure TJclSimpleXMLElemHeader.SetVersion(const Value: string); +var + Prop: TJclSimpleXMLProp; +begin + Prop := Properties.ItemNamed['version']; + if Assigned(Prop) then + Prop.Value := Value + else + // Various XML parsers (including MSIE, Firefox) require the "version" to be the first + Properties.Insert(0, 'version', Value); +end; + +//=== { TJclSimpleXMLElemDocType } =========================================== + +procedure TJclSimpleXMLElemDocType.LoadFromStringStream(StringStream: TJclStringStream); +{ + + +' > +%xx; +]> + + +} +const + CS_START_DOCTYPE = ''); + SetLength(St, 0); + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadUCS4(Ch) do + begin + case lPos of + 1..9: // or > + if lChar = Ch then + begin + if lChar = Ord('>') then + begin + lOk := True; + Break; //This is the end + end + else + begin + UCS4ArrayConcat(St, Ch); + lChar := Ord('>'); + end; + end + else + begin + UCS4ArrayConcat(St, Ch); + if Ch = Ord('[') then + lChar := Ord(']'); + end; + end; + end; + + if not lOk then + FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]); + + Name := ''; + Value := StrTrimCharsLeft(UCS4ToString(St), CharIsWhiteSpace); + + if SimpleXML <> nil then + SimpleXML.DoValueParsed('', Value); +end; + +procedure TJclSimpleXMLElemDocType.SaveToStringStream(StringStream: TJclStringStream; + const Level: string); +var + St: string; +begin + if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then + St := Level + '' + sLineBreak + else + St := Level + ''; + StringStream.WriteString(St, 1, Length(St)); + if SimpleXML <> nil then + SimpleXML.DoSaveProgress; +end; + +//=== { TJclSimpleXMLElemsPrologEnumerator } ================================= + +{$IFDEF SUPPORTS_FOR_IN} +constructor TJclSimpleXMLElemsPrologEnumerator.Create(AList: TJclSimpleXMLElemsProlog); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TJclSimpleXMLElemsPrologEnumerator.GetCurrent: TJclSimpleXMLElem; +begin + Result := FList[FIndex]; +end; + +function TJclSimpleXMLElemsPrologEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FList.Count - 1; + if Result then + Inc(FIndex); +end; +{$ENDIF SUPPORTS_FOR_IN} + +//=== { TJclSimpleXMLElemsProlog } =========================================== + +constructor TJclSimpleXMLElemsProlog.Create(ASimpleXML: TJclSimpleXML); +var + CaseSensitive: Boolean; +begin + inherited Create; + FSimpleXML := ASimpleXML; + CaseSensitive := Assigned(ASimpleXML) and (sxoCaseSensitive in ASimpleXML.Options); + FElems := TJclSimpleItemHashedList.Create(CaseSensitive); +end; + +destructor TJclSimpleXMLElemsProlog.Destroy; +begin + Clear; + FreeAndNil(FElems); + inherited Destroy; +end; + +procedure TJclSimpleXMLElemsProlog.Clear; +begin + FElems.Clear; +end; + +function TJclSimpleXMLElemsProlog.GetCount: Integer; +begin + Result := FElems.Count; +end; + +function TJclSimpleXMLElemsProlog.GetItem(const Index: Integer): TJclSimpleXMLElem; +begin + Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]); +end; + +procedure TJclSimpleXMLElemsProlog.LoadFromStringStream(StringStream: TJclStringStream); +{ + + +]> +Hello, world! + + Hello, world! +} +var + lPos: Integer; + St: TUCS4Array; + lEnd: Boolean; + lElem: TJclSimpleXMLElem; + Ch: UCS4; +begin + SetLength(St, 0); + lPos := 0; + + if SimpleXML <> nil then + SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.PeekUCS4(Ch) do + begin + case lPos of + 0: //We are waiting for a tag and thus avoiding spaces and any BOM + begin + if UnicodeIsWhiteSpace(Ch) then + // still waiting + else + if Ch = Ord('<') then + begin + lPos := 1; + St := UCS4Array(Ch); + end + else + FmtError(LoadResString(@RsEInvalidDocumentUnexpectedTextInFile), [StringStream.PeekPosition]); + end; + 1: //We are trying to determine the kind of the tag + begin + lElem := nil; + lEnd := False; + + if not UCS4ArrayEquals(St, ' 3) and (St[1] = Ord('?')) and UnicodeIsWhiteSpace(St[High(St)]) then + lElem := TJclSimpleXMLElemProcessingInstruction.Create(SimpleXML) + else + if (Length(St) > 1) and (St[1] <> Ord('!')) and (St[1] <> Ord('?')) then + lEnd := True; + + if lEnd then + Break + else + if lElem <> nil then + begin + FElems.Add(lElem); + lElem.LoadFromStringStream(StringStream); + SetLength(St, 0); + lPos := 0; + end; + end; + end; + end; +end; + +procedure TJclSimpleXMLElemsProlog.SaveToStringStream(StringStream: TJclStringStream); +var + I: Integer; +begin + FindHeader; + for I := 0 to Count - 1 do + Item[I].SaveToStringStream(StringStream, ''); +end; + +function VarXML: TVarType; +begin + Result := XMLVariant.VarType; +end; + +procedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem); +begin + TVarData(ADest).vType := VarXML; + TVarData(ADest).vAny := AXML; +end; + +function XMLCreate(const AXML: TJclSimpleXMLElem): Variant; +begin + XMLCreateInto(Result, AXML); +end; + +function XMLCreate: Variant; +begin + XMLCreateInto(Result, TJclSimpleXMLElemClassic.Create(nil)); +end; + +//=== { TXMLVariant } ======================================================== + +procedure TXMLVariant.CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); +var + StorageStream: TStringStream; + ConversionString: TJclStringStream; +begin + if Source.vType = VarType then + begin + case AVarType of + varOleStr: + begin + StorageStream := TStringStream.Create(''); + try + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataFromOleStr(Dest, StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + varString: + begin + StorageStream := TStringStream.Create(''); + try + {$IFDEF SUPPORTS_UNICODE} + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + {$ELSE ~SUPPORTS_UNICODE} + ConversionString := TJclAnsiStream.Create(StorageStream, False); + {$ENDIF ~SUPPORTS_UNICODE} + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataFromStr(Dest, StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + {$IFDEF SUPPORTS_UNICODE_STRING} + varUString: + begin + StorageStream := TStringStream.Create(''); + try + ConversionString := TJclUTF16Stream.Create(StorageStream, False); + try + ConversionString.WriteBOM; + TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, ''); + ConversionString.Flush; + finally + ConversionString.Free; + end; + VarDataClear(Dest); + Dest.VUString := nil; + Dest.VType := varUString; + UnicodeString(Dest.VUString) := UnicodeString(StorageStream.DataString); + finally + StorageStream.Free; + end; + end; + {$ENDIF SUPPORTS_UNICODE_STRING} + else + RaiseCastError; + end; + end + else + inherited CastTo(Dest, Source, AVarType); +end; + +procedure TXMLVariant.Clear(var V: TVarData); +begin + V.vType := varEmpty; + V.vAny := nil; +end; + +procedure TXMLVariant.Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); +begin + if Indirect and VarDataIsByRef(Source) then + VarDataCopyNoInd(Dest, Source) + else + begin + Dest.vType := Source.vType; + Dest.vAny := Source.vAny; + end; +end; + +function TXMLVariant.DoFunction(var Dest: TVarData; const V: TVarData; + const Name: string; const Arguments: TVarDataArray): Boolean; +var + VXML, LXML: TJclSimpleXMLElem; + VElems: TJclSimpleXMLElems; + I, J, K: Integer; +begin + Result := False; + if (Length(Arguments) = 1) and (Arguments[0].vType in [vtInteger, vtExtended]) then + begin + VXML := TJclSimpleXMLElem(V.VAny); + K := Arguments[0].vInteger; + J := 0; + + if (K > 0) and VXML.HasItems then + begin + VElems := VXML.Items; + for I := 0 to VElems.Count - 1 do + if UpperCase(VElems.Item[I].Name) = Name then + begin + Inc(J); + if J = K then + Break; + end; + end; + + if (J = K) and (J < VXML.ItemCount) then + begin + LXML := VXML.Items[J]; + if LXML <> nil then + begin + Dest.vType := VarXML; + Dest.vAny := Pointer(LXML); + Result := True; + end + end; + end +end; + +function TXMLVariant.GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; +var + VXML, LXML: TJclSimpleXMLElem; + lProp: TJclSimpleXMLProp; +begin + Result := False; + VXML := TJclSimpleXMLElem(V.VAny); + if VXML.HasItems then + begin + LXML := VXML.Items.ItemNamed[Name]; + if LXML <> nil then + begin + Dest.vType := VarXML; + Dest.vAny := Pointer(LXML); + Result := True; + end; + end; + if (not Result) and VXML.HasProperties then + begin + lProp := VXML.Properties.ItemNamed[Name]; + if lProp <> nil then + begin + VarDataFromOleStr(Dest, lProp.Value); + Result := True; + end; + end; +end; + +function TXMLVariant.IsClear(const V: TVarData): Boolean; +var + VXML: TJclSimpleXMLElem; +begin + VXML := TJclSimpleXMLElem(V.VAny); + Result := (VXML = nil) or (not VXML.HasItems); +end; + +function TXMLVariant.SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; + + function GetStrValue: string; + begin + try + Result := Value.VOleStr; + except + Result := ''; + end; + end; + +var + VXML, LXML: TJclSimpleXMLElem; + lProp: TJclSimpleXMLProp; +begin + Result := False; + VXML := TJclSimpleXMLElem(V.VAny); + if VXML.HasItems then + begin + LXML := VXML.Items.ItemNamed[Name]; + if LXML <> nil then + begin + LXML.Value := GetStrValue; + Result := True; + end; + end; + if (not Result) and VXML.HasProperties then + begin + lProp := VXML.Properties.ItemNamed[Name]; + if lProp <> nil then + begin + lProp.Value := GetStrValue; + Result := True; + end; + end; +end; + +procedure TJclSimpleXMLElemsProlog.Error(const S: string); +begin + raise EJclSimpleXMLError.Create(S); +end; + +procedure TJclSimpleXMLElemsProlog.FmtError(const S: string; + const Args: array of const); +begin + Error(Format(S, Args)); +end; + +procedure TJclSimpleXML.SetIndentString(const Value: string); +begin + // test if the new value is only made of spaces or tabs + if not StrContainsChars(Value, CharIsWhiteSpace, True) then + Exit; + FIndentString := Value; +end; + +procedure TJclSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic); +begin + if Value <> FRoot then + begin +// FRoot.FSimpleXML := nil; + FRoot := Value; +// FRoot.FSimpleXML := Self; + end; +end; + +function TJclSimpleXMLElemsProlog.GetEncoding: string; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.Encoding + else + Result := 'UTF-8'; +end; + +{$IFDEF SUPPORTS_FOR_IN} +function TJclSimpleXMLElemsProlog.GetEnumerator: TJclSimpleXMLElemsPrologEnumerator; +begin + Result := TJclSimpleXMLElemsPrologEnumerator.Create(Self); +end; +{$ENDIF SUPPORTS_FOR_IN} + +function TJclSimpleXMLElemsProlog.GetStandAlone: Boolean; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.StandAlone + else + Result := False; +end; + +function TJclSimpleXMLElemsProlog.GetVersion: string; +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Result := Elem.Version + else + Result := '1.0'; +end; + +procedure TJclSimpleXMLElemsProlog.SetEncoding(const Value: string); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.Encoding := Value; +end; + +procedure TJclSimpleXMLElemsProlog.SetStandAlone(const Value: Boolean); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.StandAlone := Value; +end; + +procedure TJclSimpleXMLElemsProlog.SetVersion(const Value: string); +var + Elem: TJclSimpleXMLElemHeader; +begin + Elem := TJclSimpleXMLElemHeader(FindHeader); + if Elem <> nil then + Elem.Version := Value; +end; + +function TJclSimpleXMLElemsProlog.FindHeader: TJclSimpleXMLElem; +var + I: Integer; +begin + for I := 0 to Count - 1 do + if Item[I] is TJclSimpleXMLElemHeader then + begin + Result := Item[I]; + Exit; + end; + // (p3) if we get here, an xml header was not found + Result := TJclSimpleXMLElemHeader.Create(SimpleXML); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemSheet.Create('xml-stylesheet'); + Result.Properties.Add('type',AType); + Result.Properties.Add('href',AHRef); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemMSOApplication.Create('mso-application'); + Result.Properties.Add('progid',AProgId); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemComment.Create('', AValue); + FElems.Add(Result); +end; + +function TJclSimpleXMLElemsProlog.AddDocType(const AValue: string): TJclSimpleXMLElemDocType; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemDocType.Create('', AValue); + FElems.Add(Result); +end; + +initialization + {$IFDEF UNITVERSIONING} + RegisterUnitVersion(HInstance, UnitVersioning); + {$ENDIF UNITVERSIONING} + +finalization + FreeAndNil(GlobalXMLVariant); + {$IFDEF UNITVERSIONING} + UnregisterUnitVersion(HInstance); + {$ENDIF UNITVERSIONING} + +end. diff --git a/jcl/source/common/JclStringLists.pas b/jcl/source/common/JclStringLists.pas index a6cccee949..9a84c56dd1 100644 --- a/jcl/source/common/JclStringLists.pas +++ b/jcl/source/common/JclStringLists.pas @@ -1,1462 +1,1462 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 NewStringListUnit.pas. } -{ } -{ The Initial Developer of the Original Code is Romullo Sousa. } -{ Portions created by Romullo Sousa are Copyright (C) Romullo Sousa. All rights reserved. } -{ } -{ Contributor(s): } -{ Romullo Sousa (romullobr) } -{ Leo Simas (Leh_U) } -{ } -{**************************************************************************************************} -{ } -{ This unit contains several improvements of the standard TStringList. } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -unit JclStringLists; - -{$I jcl.inc} - -interface - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Winapi.Windows, - {$ENDIF MSWINDOWS} - System.Variants, - System.Classes, System.SysUtils, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF MSWINDOWS} - Variants, - Classes, SysUtils, - {$ENDIF ~HAS_UNITSCOPE} - JclBase, - JclPCRE; - -{$DEFINE HAS_TSTRINGS_COMPARESTRINGS} -{$IFDEF FPC} - {$UNDEF HAS_TSTRINGS_COMPARESTRINGS} -{$ENDIF FPC} - -type - EJclStringListError = class(EJclError); - - IJclStringList = interface; - - TJclStringListObjectsMode = (omNone, omObjects, omVariants, omInterfaces); - - TJclStringListSortCompare = function(List: IJclStringList; Index1, Index2: Integer): Integer; - - IJclStringList = interface(IInterface) - ['{8DC5B71C-4756-404D-8636-7872CD299796}'] - { From TStrings/TStringList } - function Add(const S: string): Integer; overload; - function AddObject(const S: string; AObject: TObject): Integer; - function Get(Index: Integer): string; - function GetCapacity: Integer; - function GetCount: Integer; - function GetObjects(Index: Integer): TObject; - function GetTextStr: string; - function GetValue(const Name: string): string; - {$IFDEF FPC} - function Find(const S: string; out Index: Integer): Boolean; - {$ELSE ~FPC} - function Find(const S: string; var Index: Integer): Boolean; - {$ENDIF ~FPC} - function IndexOf(const S: string): Integer; - function GetCaseSensitive: Boolean; - function GetDuplicates: TDuplicates; - function GetOnChange: TNotifyEvent; - function GetOnChanging: TNotifyEvent; - function GetSorted: Boolean; - function Equals(Strings: TStrings): Boolean; - function IndexOfName(const Name: string): Integer; - function IndexOfObject(AObject: TObject): Integer; - function LoadFromFile(const FileName: string): IJclStringList; - function LoadFromStream(Stream: TStream): IJclStringList; - function SaveToFile(const FileName: string): IJclStringList; - function SaveToStream(Stream: TStream): IJclStringList; - function GetCommaText: string; - function GetDelimitedText: string; - function GetDelimiter: Char; - function GetName(Index: Integer): string; - {$IFDEF COMPILER7_UP} - function GetNameValueSeparator: Char; - function GetValueFromIndex(Index: Integer): string; - {$ENDIF COMPILER7_UP} - function GetQuoteChar: Char; - procedure SetCommaText(const Value: string); - procedure SetDelimitedText(const Value: string); - procedure SetDelimiter(const Value: Char); - {$IFDEF COMPILER7_UP} - procedure SetNameValueSeparator(const Value: Char); - procedure SetValueFromIndex(Index: Integer; const Value: string); - {$ENDIF COMPILER7_UP} - procedure SetQuoteChar(const Value: Char); - procedure AddStrings(Strings: TStrings); overload; - procedure SetObjects(Index: Integer; const Value: TObject); - procedure Put(Index: Integer; const S: string); - procedure SetCapacity(NewCapacity: Integer); - procedure SetTextStr(const Value: string); - procedure SetValue(const Name, Value: string); - procedure SetCaseSensitive(const Value: Boolean); - procedure SetDuplicates(const Value: TDuplicates); - procedure SetOnChange(const Value: TNotifyEvent); - procedure SetOnChanging(const Value: TNotifyEvent); - procedure SetSorted(const Value: Boolean); - property Count: Integer read GetCount; - property Strings[Index: Integer]: string read Get write Put; default; - property Text: string read GetTextStr write SetTextStr; - property Objects[Index: Integer]: TObject read GetObjects write SetObjects; - property Capacity: Integer read GetCapacity write SetCapacity; - property Values[const Name: string]: string read GetValue write SetValue; - property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; - property Sorted: Boolean read GetSorted write SetSorted; - property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read GetOnChange write SetOnChange; - property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; - property DelimitedText: string read GetDelimitedText write SetDelimitedText; - property Delimiter: Char read GetDelimiter write SetDelimiter; - property Names[Index: Integer]: string read GetName; - property QuoteChar: Char read GetQuoteChar write SetQuoteChar; - property CommaText: string read GetCommaText write SetCommaText; - {$IFDEF COMPILER7_UP} - property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; - {$ENDIF COMPILER7_UP} - { New } - function Assign(Source: TPersistent): IJclStringList; - function LoadExeParams: IJclStringList; - function Exists(const S: string): Boolean; - function ExistsName(const S: string): Boolean; - function DeleteBlanks: IJclStringList; - function KeepIntegers: IJclStringList; - function DeleteIntegers: IJclStringList; - function ReleaseInterfaces: IJclStringList; - function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; - function Clone: IJclStringList; - function Insert(Index: Integer; const S: string): IJclStringList; - function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; - function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; - function SortAsInteger: IJclStringList; - function SortByName: IJclStringList; - function Delete(AIndex: Integer): IJclStringList; overload; - function Delete(const AString: string): IJclStringList; overload; - function Exchange(Index1, Index2: Integer): IJclStringList; - function Add(const A: array of const): IJclStringList; overload; - function AddStrings(const A: array of string): IJclStringList; overload; - function BeginUpdate: IJclStringList; - function EndUpdate: IJclStringList; - function Trim: IJclStringList; - function Join(const ASeparator: string = ''): string; - function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; - function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; - function Last: string; - function First: string; - function LastIndex: Integer; - function Clear: IJclStringList; - {$IFDEF JCL_PCRE} - function DeleteRegEx(const APattern: string): IJclStringList; - function KeepRegEx(const APattern: string): IJclStringList; - function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - {$ENDIF JCL_PCRE} - function GetStringsRef: TStrings; - function ConfigAsSet: IJclStringList; - function Delimit(const ADelimiter: string): IJclStringList; - function GetInterfaceByIndex(Index: Integer): IInterface; - function GetLists(Index: Integer): IJclStringList; - function GetVariants(AIndex: Integer): Variant; - function GetKeyInterface(const AKey: string): IInterface; - function GetKeyObject(const AKey: string): TObject; - function GetKeyVariant(const AKey: string): Variant; - function GetKeyList(const AKey: string): IJclStringList; - function GetObjectsMode: TJclStringListObjectsMode; - procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); - procedure SetLists(Index: Integer; const Value: IJclStringList); - procedure SetVariants(Index: Integer; const Value: Variant); - procedure SetKeyInterface(const AKey: string; const Value: IInterface); - procedure SetKeyObject(const AKey: string; const Value: TObject); - procedure SetKeyVariant(const AKey: string; const Value: Variant); - procedure SetKeyList(const AKey: string; const Value: IJclStringList); - property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; - property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; - property Variants[Index: Integer]: Variant read GetVariants write SetVariants; - property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; - property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; - property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; - property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; - property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; - end; - -type - TJclInterfacedStringList = class(TStringList, IInterface) - private - FOwnerInterface: IInterface; - public - { IInterface } - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall; - procedure AfterConstruction; override; - end; - - - TJclStringList = class(TJclInterfacedStringList, IInterface, IJclStringList) - private - FObjectsMode: TJclStringListObjectsMode; - FSelfAsInterface: IJclStringList; - {$IFDEF JCL_PCRE} - FLastRegExPattern: string; - FRegEx: TJclRegEx; - {$ENDIF JCL_PCRE} - FCompareFunction: TJclStringListSortCompare; - function CanFreeObjects: Boolean; - {$IFDEF JCL_PCRE} - function MatchRegEx(const S, APattern: string): Boolean; - {$ENDIF JCL_PCRE} - procedure EnsureObjectsMode(AMode: TJclStringListObjectsMode); - protected - FRefCount: Integer; - {$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} - function CompareStrings(const S1, S2: string): Integer; virtual; - {$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} - public - constructor Create; - destructor Destroy; override; - { IInterface } - // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - { IJclStringList } - // function Add(const S: string): Integer; overload; - // function AddObject(const S: string; AObject: TObject): Integer; - // function Get(Index: Integer): string; - // function GetCapacity: Integer; - // function GetCount: Integer; - function GetObjects(Index: Integer): TObject; - // function GetTextStr: string; - function GetValue(const Name: string): string; - // function Find(const S: string; var Index: Integer): Boolean; - // function IndexOf(const S: string): Integer; - function GetCaseSensitive: Boolean; - function GetDuplicates: TDuplicates; - function GetOnChange: TNotifyEvent; - function GetOnChanging: TNotifyEvent; - function GetSorted: Boolean; - // function Equals(Strings: TStrings): Boolean; - // function IndexOfName(const Name: string): Integer; - // function IndexOfObject(AObject: TObject): Integer; - function LoadFromFile(const FileName: string): IJclStringList; reintroduce; - function LoadFromStream(Stream: TStream): IJclStringList; reintroduce; - function SaveToFile(const FileName: string): IJclStringList; reintroduce; - function SaveToStream(Stream: TStream): IJclStringList; reintroduce; - function GetCommaText: string; - function GetDelimitedText: string; - function GetDelimiter: Char; - function GetName(Index: Integer): string; - {$IFDEF COMPILER7_UP} - function GetNameValueSeparator: Char; - function GetValueFromIndex(Index: Integer): string; - {$ENDIF COMPILER7_UP} - function GetQuoteChar: Char; - procedure SetCommaText(const Value: string); - procedure SetDelimitedText(const Value: string); - procedure SetDelimiter(const Value: Char); - {$IFDEF COMPILER7_UP} - procedure SetNameValueSeparator(const Value: Char); - procedure SetValueFromIndex(Index: Integer; const Value: string); - {$ENDIF COMPILER7_UP} - procedure SetQuoteChar(const Value: Char); - // procedure AddStrings(Strings: TStrings); overload; - procedure SetObjects(Index: Integer; const Value: TObject); - // procedure Put(Index: Integer; const S: string); - // procedure SetCapacity(NewCapacity: Integer); - // procedure SetTextStr(const Value: string); - procedure SetValue(const Name, Value: string); - procedure SetCaseSensitive(const Value: Boolean); - procedure SetDuplicates(const Value: TDuplicates); - procedure SetOnChange(const Value: TNotifyEvent); - procedure SetOnChanging(const Value: TNotifyEvent); - procedure SetSorted(const Value: Boolean); - property Count: Integer read GetCount; - property Strings[Index: Integer]: string read Get write Put; default; - property Text: string read GetTextStr write SetTextStr; - property Objects[Index: Integer]: TObject read GetObjects write SetObjects; - property Capacity: Integer read GetCapacity write SetCapacity; - property Values[const Name: string]: string read GetValue write SetValue; - property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; - property Sorted: Boolean read GetSorted write SetSorted; - property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read GetOnChange write SetOnChange; - property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; - property DelimitedText: string read GetDelimitedText write SetDelimitedText; - property Delimiter: Char read GetDelimiter write SetDelimiter; - property Names[Index: Integer]: string read GetName; - property QuoteChar: Char read GetQuoteChar write SetQuoteChar; - property CommaText: string read GetCommaText write SetCommaText; - {$IFDEF COMPILER7_UP} - property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; - {$ENDIF COMPILER7_UP} - { New } - function Assign(Source: TPersistent): IJclStringList; reintroduce; - function LoadExeParams: IJclStringList; - function Exists(const S: string): Boolean; - function ExistsName(const S: string): Boolean; - function DeleteBlanks: IJclStringList; - function KeepIntegers: IJclStringList; - function DeleteIntegers: IJclStringList; - function ReleaseInterfaces: IJclStringList; - function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; - function Clone: IJclStringList; - function Insert(Index: Integer; const S: string): IJclStringList; reintroduce; - function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; reintroduce; - function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; reintroduce; - function SortAsInteger: IJclStringList; - function SortByName: IJclStringList; - function Delete(AIndex: Integer): IJclStringList; reintroduce; overload; - function Delete(const AString: string): IJclStringList; reintroduce; overload; - function Exchange(Index1, Index2: Integer): IJclStringList; reintroduce; - function Add(const A: array of const): IJclStringList; reintroduce; overload; - function AddStrings(const A: array of string): IJclStringList; reintroduce; overload; - function BeginUpdate: IJclStringList; - function EndUpdate: IJclStringList; - function Trim: IJclStringList; - function Join(const ASeparator: string = ''): string; - function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; - function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; - function Last: string; - function First: string; - function LastIndex: Integer; - function Clear: IJclStringList; reintroduce; - {$IFDEF JCL_PCRE} - function DeleteRegEx(const APattern: string): IJclStringList; - function KeepRegEx(const APattern: string): IJclStringList; - function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - {$ENDIF JCL_PCRE} - function GetStringsRef: TStrings; - function ConfigAsSet: IJclStringList; - function Delimit(const ADelimiter: string): IJclStringList; - function GetInterfaceByIndex(Index: Integer): IInterface; - function GetLists(Index: Integer): IJclStringList; - function GetVariants(AIndex: Integer): Variant; - function GetKeyInterface(const AKey: string): IInterface; - function GetKeyObject(const AKey: string): TObject; - function GetKeyVariant(const AKey: string): Variant; - function GetKeyList(const AKey: string): IJclStringList; - function GetObjectsMode: TJclStringListObjectsMode; - procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); - procedure SetLists(Index: Integer; const Value: IJclStringList); - procedure SetVariants(Index: Integer; const Value: Variant); - procedure SetKeyInterface(const AKey: string; const Value: IInterface); - procedure SetKeyObject(const AKey: string; const Value: TObject); - procedure SetKeyVariant(const AKey: string; const Value: Variant); - procedure SetKeyList(const AKey: string; const Value: IJclStringList); - property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; - property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; - property Variants[Index: Integer]: Variant read GetVariants write SetVariants; - property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; - property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; - property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; - property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; - property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; - end; - -function JclStringList: IJclStringList; overload; -function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; -function JclStringListStrings(const A: array of string): IJclStringList; overload; -function JclStringList(const A: array of const): IJclStringList; overload; -function JclStringList(const AText: string): IJclStringList; overload; - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNITSCOPE} - System.TypInfo, - {$ELSE ~HAS_UNITSCOPE} - TypInfo, - {$ENDIF ~HAS_UNITSCOPE} - JclFileUtils, - JclStrings; - -type - TVariantWrapper = class(TObject) - private - FValue: Variant; - end; - - TInterfaceWrapper = class(TObject) - private - FValue: IInterface; - end; - -function JclStringList: IJclStringList; -begin - Result := TJclStringList.Create; -end; - -function JclStringList(const AText: string): IJclStringList; overload; -begin - Result := JclStringList; - Result.Text := AText; -end; - -function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; -begin - Result := JclStringList; - Result.AddStrings(AStrings); -end; - -function JclStringListStrings(const A: array of string): IJclStringList; -begin - Result := JclStringList.AddStrings(A); -end; - -function JclStringList(const A: array of const): IJclStringList; -begin - Result := JclStringList.Add(A); -end; - -//=== { TJclInterfacedStringList } ============================================== - -procedure TJclInterfacedStringList.AfterConstruction; -Var - MyOwner : TPersistent; -begin - inherited; - MyOwner := GetOwner; - if Assigned(MyOwner) then - MyOwner.GetInterface(IUnknown,FOwnerInterface); -end; - - -function TJclInterfacedStringList._AddRef: Integer;stdcall; -begin - if assigned(FOwnerInterface) then - Result := FOwnerInterface._AddRef - else - Result := -1; -end; - - -function TJclInterfacedStringList._Release: Integer;stdcall; -begin - if assigned(FOwnerInterface) then - Result := FOwnerInterface._Release - else - Result := -1; -end; - - -function TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall; -begin - if GetInterface(IID, Obj) then - Result := 0 - else - Result := E_NOINTERFACE; -end; - -//=== { TJclStringList } ===================================================== - -function TJclStringList.Add(const A: array of const): IJclStringList; -const - BoolToStr: array [Boolean] of string[5] = ('false', 'true'); -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := Low(A) to High(A) do - case A[I].VType of - vtInteger: - Add(IntToStr(A[I].VInteger)); - vtBoolean: - Add(string(BoolToStr[A[I].VBoolean])); - vtChar: - Add(string(AnsiString(A[I].VChar))); - vtExtended: - Add(FloatToStr(A[I].VExtended^)); - vtString: - Add(string(A[I].VString^)); - vtPChar: - Add(string(AnsiString(A[I].VPChar))); - vtPWideChar: - Add(string(WideString(A[I].VPWideChar))); - vtObject: - Add(A[I].VObject.ClassName); - vtClass: - Add(A[I].VClass.ClassName); - vtAnsiString: - Add(string(A[I].VAnsiString)); - vtWideString: - Add(string(A[I].VWideString)); - vtCurrency: - Add(CurrToStr(A[I].VCurrency^)); - vtVariant: - Add(string(A[I].VVariant^)); - vtInt64: - Add(IntToStr(A[I].VInt64^)); - {$IFDEF SUPPORTS_UNICODE_STRING} - vtUnicodeString: - Add(string(A[I].VUnicodeString)); - {$ENDIF SUPPORTS_UNICODE_STRING} - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.AddStrings(const A: array of string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := Low(A) to High(A) do - Add(A[I]); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.BeginUpdate: IJclStringList; -begin - inherited BeginUpdate; - Result := FSelfAsInterface; -end; - -function TJclStringList.Clear: IJclStringList; -begin - if CanFreeObjects then - FreeObjects(False); - inherited Clear; - Result := FSelfAsInterface; -end; - -function TJclStringList.EndUpdate: IJclStringList; -begin - inherited EndUpdate; - Result := FSelfAsInterface; -end; - -function TJclStringList.ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar; - AClearBeforeAdd: Boolean): IJclStringList; -var - L, I, X: Integer; -begin - Result := BeginUpdate; - try - if AClearBeforeAdd then - Clear; - I := 1; - L := Length(AText); - while I <= L do - begin - while (I <= L) and (AnsiChar(AText[I]) in ADelims) do - Inc(I); - X := I; - while (I <= L) and not (AnsiChar(AText[I]) in ADelims) do - Inc(I); - if X <> I then - Add(Copy(AText, X, I - X)); - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.First: string; -begin - Result := Strings[0]; -end; - -function TJclStringList.Join(const ASeparator: string): string; -var - I: Integer; - SB: TStringBuilder; // Implemented by JclStrings, if missed in RTL -begin - if Count <= 0 then - Result := '' - else begin - SB := TStringBuilder.Create(First); - // Warming up ? Worth it ? Capacity: Sum([Strings]) + (Count-1) * [ASeparator] ? - try - for I := 1 to LastIndex do - SB.Append(ASeparator).Append(Strings[i]); - Result := SB.ToString; - finally - SB.Free; - end; - end; -// for I := 0 to LastIndex - 1 do -// Result := Result + Strings[I] + ASeparator; -// if Count > 0 then -// Result := Result + Last; -end; - -function TJclStringList.Last: string; -begin - Result := Strings[LastIndex]; -end; - -function TJclStringList.Split(const AText, ASeparator: string; - AClearBeforeAdd: Boolean = True): IJclStringList; -var - LStartIndex, LEndIndex: Integer; - LLengthSeparator: Integer; -begin - Result := FSelfAsInterface; - if AText <> '' then - begin - Result := BeginUpdate; - try - if AClearBeforeAdd then - Clear; - LLengthSeparator := Length(ASeparator); - LStartIndex := 1; - LEndIndex := StrSearch(ASeparator, AText, LStartIndex); - while LEndIndex > 0 do - begin - Add(Copy(AText, LStartIndex, LEndIndex - LStartIndex)); - LStartIndex := LEndIndex + LLengthSeparator; - LEndIndex := StrSearch(ASeparator, AText, LStartIndex); - end; - Add(Copy(AText, LStartIndex, MaxInt)); - finally - Result := EndUpdate; - end; - end; -end; - -function TJclStringList.Trim: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Strings[I] := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList._AddRef: Integer; -begin - Result := InterlockedIncrement(FRefCount); -end; - -function TJclStringList._Release: Integer; -begin - Result := InterlockedDecrement(FRefCount); - if Result = 1 then - begin - // When there is only one reference, it is the internal reference, - // so we release it. The compiler will call _Release again and - // the object will be destroyed. - FSelfAsInterface := nil; - end - else - if Result = 0 then begin - pointer(FSelfAsInterface) := nil; // should work in .create / FreeAndNil scenario - Destroy; - end; -end; - -{$IFDEF JCL_PCRE} -function TJclStringList.DeleteRegEx(const APattern: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if MatchRegEx(Strings[I], APattern) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.KeepRegEx(const APattern: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if not MatchRegEx(Strings[I], APattern) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.MatchRegEx(const S, APattern: string): Boolean; -begin - if FRegEx = nil then - FRegEx := TJclRegEx.Create; - if FLastRegExPattern <> APattern then - begin - if CaseSensitive then - FRegEx.Options := FRegEx.Options - [roIgnoreCase] - else - FRegEx.Options := FRegEx.Options + [roIgnoreCase]; - FRegEx.Compile(APattern, False, True); - FLastRegExPattern := APattern; - end; - Result := FRegEx.Match(S); -end; -{$ENDIF JCL_PCRE} - -destructor TJclStringList.Destroy; -begin - if (FRefCount = 1) and (FSelfAsInterface <> nil) then begin - pointer(FSelfAsInterface) := nil; - FRefCount := 0; // should work in .Create -> FreeAndNil scenario - end; - if CanFreeObjects then - FreeObjects(False); - {$IFDEF JCL_PCRE} - FreeAndNil(FRegEx); - {$ENDIF JCL_PCRE} - inherited Destroy; -end; - -{$IFDEF JCL_PCRE} -function TJclStringList.Directories(const APattern: string = '*'; - ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - - procedure DoDirectories(const APattern: string); - var - LSearchRec: TSearchRec; - LFullName: string; - LPath: string; - begin - LPath := ExtractFilePath(APattern); - if FindFirst(APattern, faAnyFile, LSearchRec) = 0 then - try - repeat - if (LSearchRec.Attr and faDirectory = 0) or - (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then - Continue; - LFullName := LPath + LSearchRec.Name; - if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then - Add(LFullName); - if ARecursive then - DoDirectories(PathAddSeparator(LFullName) + ExtractFileName(APattern)); - until FindNext(LSearchRec) <> 0; - finally - FindClose(LSearchRec); - end; - end; - -begin - Result := BeginUpdate; - try - if DirectoryExists(APattern) then - DoDirectories(PathAddSeparator(APattern) + '*') - else - DoDirectories(APattern); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Files(const APattern: string = '*'; - ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; - - procedure DoFiles(const APattern: string); - var - LSearchRec: TSearchRec; - LFullName: string; - LDirectories: IJclStringList; - LPath: string; - I: Integer; - begin - LPath := ExtractFilePath(APattern); - if FindFirst(APattern, faAnyFile and not faDirectory, LSearchRec) = 0 then - begin - try - repeat - if (LSearchRec.Attr and faDirectory <> 0) or - (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then - Continue; - LFullName := LPath + LSearchRec.Name; - if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then - Add(LFullName); - until FindNext(LSearchRec) <> 0; - finally - FindClose(LSearchRec); - end; - end; - if ARecursive then - begin - LDirectories := JclStringList.Directories(LPath + '*', False); - for I := 0 to LDirectories.LastIndex do - DoFiles(PathAddSeparator(LDirectories[I]) + ExtractFileName(APattern)); - end; - end; - -begin - Result := BeginUpdate; - try - if DirectoryExists(APattern) then - DoFiles(PathAddSeparator(APattern) + '*') - else - DoFiles(APattern); - finally - Result := EndUpdate; - end; -end; -{$ENDIF JCL_PCRE} - -function TJclStringList.LastIndex: Integer; -begin - { The code bellow is more optimized than "Result := Count - 1". } - Result := Count; - Dec(Result); -end; - -constructor TJclStringList.Create; -begin - inherited Create; - if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then - System.Error(reIntfCastError); - // InterlockedDecrement(FRefCount); // should work w/o dangling pointers - bug #6081 -end; - -function TJclStringList.GetLists(Index: Integer): IJclStringList; -begin - Result := Interfaces[Index] as IJclStringList; - if Result = nil then - begin - Result := JclStringList; - Interfaces[Index] := Result; - end; -end; - -procedure TJclStringList.SetLists(Index: Integer; const Value: IJclStringList); -begin - Interfaces[Index] := Value; -end; - -function TJclStringList.GetStringsRef: TStrings; -begin - Result := Self; -end; - -function TJclStringList.GetKeyInterface(const AKey: string): IInterface; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Interfaces[I] - else - Result := nil; -end; - -function TJclStringList.GetKeyObject(const AKey: string): TObject; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Objects[I] - else - Result := nil; -end; - -procedure TJclStringList.SetKeyInterface(const AKey: string; const Value: IInterface); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - I := Add(AKey); - Interfaces[I] := Value -end; - -procedure TJclStringList.SetKeyObject(const AKey: string; const Value: TObject); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - AddObject(AKey, Value) - else - Objects[I] := Value; -end; - -function TJclStringList.ConfigAsSet: IJclStringList; -begin - Sorted := True; - Duplicates := dupIgnore; - Result := FSelfAsInterface; -end; - -function TJclStringList.GetKeyVariant(const AKey: string): Variant; -var - I: Integer; -begin - I := IndexOf(AKey); - if I >= 0 then - Result := Variants[I] - else - Result := Unassigned; -end; - -procedure TJclStringList.SetKeyVariant(const AKey: string; const Value: Variant); -var - I: Integer; -begin - I := IndexOf(AKey); - if I < 0 then - I := Add(AKey); - Variants[I] := Value -end; - -function TJclStringList.GetValue(const Name: string): string; -begin - Result := inherited Values[Name]; -end; - -procedure TJclStringList.SetValue(const Name, Value: string); -begin - inherited Values[Name] := Value; -end; - -function TJclStringList.GetInterfaceByIndex(Index: Integer): IInterface; -var - V: TInterfaceWrapper; -begin - if FObjectsMode <> omInterfaces then - EnsureObjectsMode(omInterfaces); - V := TInterfaceWrapper(inherited Objects[Index]); - if V = nil then - Result := nil - else - Result := V.FValue; -end; - -procedure TJclStringList.SetInterfaceByIndex(Index: Integer; const Value: IInterface); -var - V: TInterfaceWrapper; -begin - if FObjectsMode <> omInterfaces then - EnsureObjectsMode(omInterfaces); - V := TInterfaceWrapper(inherited Objects[Index]); - if V = nil then - begin - V := TInterfaceWrapper.Create; - inherited Objects[Index] := V; - end; - V.FValue := Value; -end; - -function TJclStringList.GetObjects(Index: Integer): TObject; -begin - if FObjectsMode <> omObjects then - EnsureObjectsMode(omObjects); - Result := inherited Objects[Index]; -end; - -procedure TJclStringList.SetObjects(Index: Integer; const Value: TObject); -begin - if FObjectsMode <> omObjects then - EnsureObjectsMode(omObjects); - inherited Objects[Index] := Value; -end; - -function TJclStringList.GetVariants(AIndex: Integer): Variant; -var - V: TVariantWrapper; -begin - if FObjectsMode <> omVariants then - EnsureObjectsMode(omVariants); - V := TVariantWrapper(inherited Objects[AIndex]); - if V = nil then - Result := Unassigned - else - Result := V.FValue; -end; - -procedure TJclStringList.SetVariants(Index: Integer; const Value: Variant); -var - V: TVariantWrapper; -begin - if FObjectsMode <> omVariants then - EnsureObjectsMode(omVariants); - V := TVariantWrapper(inherited Objects[Index]); - if V = nil then - begin - V := TVariantWrapper.Create; - inherited Objects[Index] := V; - end; - V.FValue := Value; -end; - -procedure TJclStringList.EnsureObjectsMode(AMode: TJclStringListObjectsMode); -begin - if FObjectsMode <> AMode then - begin - if FObjectsMode <> omNone then - begin - raise EJclStringListError.CreateFmt('Objects cannot be used as "%s" because it has been used as "%s".', - [GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(AMode)), - GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(FObjectsMode))]); - end; - FObjectsMode := AMode; - end; -end; - -function TJclStringList.GetKeyList(const AKey: string): IJclStringList; -begin - Result := KeyInterface[AKey] as IJclStringList; - if Result = nil then - begin - Result := JclStringList; - KeyInterface[AKey] := Result; - end; -end; - -procedure TJclStringList.SetKeyList(const AKey: string; const Value: IJclStringList); -begin - KeyInterface[AKey] := Value; -end; - -function TJclStringList.Delete(AIndex: Integer): IJclStringList; -begin - if CanFreeObjects then - inherited Objects[AIndex].Free; - inherited Delete(AIndex); - Result := FSelfAsInterface; -end; - -function TJclStringList.Delete(const AString: string): IJclStringList; -begin - Result := Delete(IndexOf(AString)); -end; - -function TJclStringList.Exchange(Index1, Index2: Integer): IJclStringList; -begin - inherited Exchange(Index1, Index2); - Result := FSelfAsInterface; -end; - -function LocalSort(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := TJclStringList(List).FCompareFunction(TJclStringList(List).FSelfAsInterface, Index1, Index2); -end; - -function TJclStringList.Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; -begin - FCompareFunction := ACompareFunction; - if not Assigned(ACompareFunction) then - inherited Sort - else - inherited CustomSort(@LocalSort); - Result := FSelfAsInterface; -end; - -function LocalSortAsInteger(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := StrToInt(List[Index1]) - StrToInt(List[Index2]); -end; - -function TJclStringList.SortAsInteger: IJclStringList; -begin - inherited CustomSort(@LocalSortAsInteger); - Result := FSelfAsInterface; -end; - -{$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} -function TJclStringList.CompareStrings(const S1, S2: string): Integer; -begin - Result := AnsiCompareText(S1, S2); -end; -{$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} - -function LocalSortByName(List: TStringList; Index1, Index2: Integer): Integer; -begin - Result := TJclStringList(List).CompareStrings(List.Names[Index1], List.Names[Index2]); -end; - -function TJclStringList.SortByName: IJclStringList; -begin - inherited CustomSort(@LocalSortByName); - Result := FSelfAsInterface; -end; - -function TJclStringList.Insert(Index: Integer; const S: string): IJclStringList; -begin - inherited Insert(Index, S); - Result := FSelfAsInterface; -end; - -function TJclStringList.InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; -begin - inherited InsertObject(Index, S, AObject); - Result := FSelfAsInterface; -end; - -function TJclStringList.GetCaseSensitive: Boolean; -begin - Result := inherited CaseSensitive; -end; - -function TJclStringList.GetDuplicates: TDuplicates; -begin - Result := inherited Duplicates; -end; - -function TJclStringList.GetOnChange: TNotifyEvent; -begin - Result := inherited OnChange; -end; - -function TJclStringList.GetOnChanging: TNotifyEvent; -begin - Result := inherited OnChanging; -end; - -function TJclStringList.GetSorted: Boolean; -begin - Result := inherited Sorted; -end; - -procedure TJclStringList.SetCaseSensitive(const Value: Boolean); -begin - inherited CaseSensitive := Value; -end; - -procedure TJclStringList.SetDuplicates(const Value: TDuplicates); -begin - inherited Duplicates := Value; -end; - -procedure TJclStringList.SetOnChange(const Value: TNotifyEvent); -begin - inherited OnChange := Value; -end; - -procedure TJclStringList.SetOnChanging(const Value: TNotifyEvent); -begin - inherited OnChanging := Value; -end; - -procedure TJclStringList.SetSorted(const Value: Boolean); -begin - inherited Sorted := Value; -end; - -function TJclStringList.LoadFromFile(const FileName: string): IJclStringList; -begin - inherited LoadFromFile(FileName); - Result := FSelfAsInterface; -end; - -function TJclStringList.LoadFromStream(Stream: TStream): IJclStringList; -begin - inherited LoadFromStream(Stream); - Result := FSelfAsInterface; -end; - -function TJclStringList.SaveToFile(const FileName: string): IJclStringList; -begin - inherited SaveToFile(FileName); - Result := FSelfAsInterface; -end; - -function TJclStringList.SaveToStream(Stream: TStream): IJclStringList; -begin - inherited SaveToStream(Stream); - Result := FSelfAsInterface; -end; - -function TJclStringList.GetCommaText: string; -begin - Result := inherited CommaText; -end; - -function TJclStringList.GetDelimitedText: string; -begin - Result := inherited DelimitedText; -end; - -function TJclStringList.GetDelimiter: Char; -begin - Result := inherited Delimiter; -end; - -function TJclStringList.GetName(Index: Integer): string; -begin - Result := inherited Names[Index]; -end; - -{$IFDEF COMPILER7_UP} - -function TJclStringList.GetNameValueSeparator: Char; -begin - Result := inherited NameValueSeparator; -end; - -function TJclStringList.GetValueFromIndex(Index: Integer): string; -begin - Result := inherited ValueFromIndex[Index]; -end; - -{$ENDIF COMPILER7_UP} - -function TJclStringList.GetQuoteChar: Char; -begin - Result := inherited QuoteChar; -end; - -procedure TJclStringList.SetCommaText(const Value: string); -begin - inherited CommaText := Value; -end; - -procedure TJclStringList.SetDelimitedText(const Value: string); -begin - inherited DelimitedText := Value; -end; - -procedure TJclStringList.SetDelimiter(const Value: Char); -begin - inherited Delimiter := Value; -end; - -{$IFDEF COMPILER7_UP} - -procedure TJclStringList.SetNameValueSeparator(const Value: Char); -begin - inherited NameValueSeparator := Value; -end; - -procedure TJclStringList.SetValueFromIndex(Index: Integer; const Value: string); -begin - inherited ValueFromIndex[Index] := Value; -end; - -{$ENDIF COMPILER7_UP} - -procedure TJclStringList.SetQuoteChar(const Value: Char); -begin - inherited QuoteChar := Value; -end; - -function TJclStringList.Delimit(const ADelimiter: string): IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Strings[I] := ADelimiter + Strings[I] + ADelimiter; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.LoadExeParams: IJclStringList; -var - I: Integer; - S: string; -begin - Result := BeginUpdate; - try - Clear; - for I := 1 to ParamCount do - begin - S := ParamStr(I); - if (S[1] = '-') or (S[1] = '/') then - System.Delete(S, 1, 1); - Add(S); - end; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Exists(const S: string): Boolean; -begin - Result := IndexOf(S) >= 0; -end; - -function TJclStringList.ExistsName(const S: string): Boolean; -begin - Result := IndexOfName(S) >= 0; -end; - -function TJclStringList.DeleteBlanks: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := LastIndex downto 0 do - if {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]) = '' then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.KeepIntegers: IJclStringList; -var - I, X: Integer; -begin - Result := BeginUpdate; - try - X := 0; - for I := LastIndex downto 0 do - if not TryStrToInt(Strings[I], X) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.DeleteIntegers: IJclStringList; -var - I, X: Integer; -begin - Result := BeginUpdate; - try - X := 0; - for I := LastIndex downto 0 do - if TryStrToInt(Strings[I], X) then - Delete(I); - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; -var - I: Integer; -begin - if AFreeAndNil then - Result := BeginUpdate; - for I := 0 to LastIndex do - begin - inherited Objects[I].Free; - if AFreeAndNil then - inherited Objects[I] := nil; - end; - if AFreeAndNil then - Result := EndUpdate - else - Result := FSelfAsInterface; -end; - -function TJclStringList.ReleaseInterfaces: IJclStringList; -var - I: Integer; -begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - Interfaces[I] := nil; - finally - Result := EndUpdate; - end; -end; - -function TJclStringList.Clone: IJclStringList; -begin - Result := JclStringList.Assign(Self); -end; - -function TJclStringList.Assign(Source: TPersistent): IJclStringList; -var - L: TJclStringList; - I: Integer; -begin - inherited Assign(Source); - Result := FSelfAsInterface; - if Source is TJclStringList then - begin - L := TJclStringList(Source); - FObjectsMode := L.FObjectsMode; - if not (FObjectsMode in [omNone, omObjects]) then - begin - Result := BeginUpdate; - try - for I := 0 to LastIndex do - begin - inherited Objects[I] := nil; - case FObjectsMode of - omVariants: - Variants[I] := L.Variants[I]; - omInterfaces: - Interfaces[I] := L.Interfaces[I]; - end; - end; - finally - Result := EndUpdate; - end; - end; - end; -end; - -function TJclStringList.CanFreeObjects: Boolean; -begin - Result := not (FObjectsMode in [omNone, omObjects]); -end; - -function TJclStringList.GetObjectsMode: TJclStringListObjectsMode; -begin - Result := FObjectsMode; -end; - -{$IFDEF UNITVERSIONING} -initialization - RegisterUnitVersion(HInstance, UnitVersioning); - -finalization - UnregisterUnitVersion(HInstance); -{$ENDIF UNITVERSIONING} - -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 NewStringListUnit.pas. } +{ } +{ The Initial Developer of the Original Code is Romullo Sousa. } +{ Portions created by Romullo Sousa are Copyright (C) Romullo Sousa. All rights reserved. } +{ } +{ Contributor(s): } +{ Romullo Sousa (romullobr) } +{ Leo Simas (Leh_U) } +{ } +{**************************************************************************************************} +{ } +{ This unit contains several improvements of the standard TStringList. } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit JclStringLists; + +{$I jcl.inc} + +interface + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Winapi.Windows, + {$ENDIF MSWINDOWS} + System.Variants, + System.Classes, System.SysUtils, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF MSWINDOWS} + Variants, + Classes, SysUtils, + {$ENDIF ~HAS_UNITSCOPE} + JclBase, + JclPCRE; + +{$DEFINE HAS_TSTRINGS_COMPARESTRINGS} +{$IFDEF FPC} + {$UNDEF HAS_TSTRINGS_COMPARESTRINGS} +{$ENDIF FPC} + +type + EJclStringListError = class(EJclError); + + IJclStringList = interface; + + TJclStringListObjectsMode = (omNone, omObjects, omVariants, omInterfaces); + + TJclStringListSortCompare = function(List: IJclStringList; Index1, Index2: Integer): Integer; + + IJclStringList = interface(IInterface) + ['{8DC5B71C-4756-404D-8636-7872CD299796}'] + { From TStrings/TStringList } + function Add(const S: string): Integer; overload; + function AddObject(const S: string; AObject: TObject): Integer; + function Get(Index: Integer): string; + function GetCapacity: Integer; + function GetCount: Integer; + function GetObjects(Index: Integer): TObject; + function GetTextStr: string; + function GetValue(const Name: string): string; + {$IFDEF FPC} + function Find(const S: string; out Index: Integer): Boolean; + {$ELSE ~FPC} + function Find(const S: string; var Index: Integer): Boolean; + {$ENDIF ~FPC} + function IndexOf(const S: string): Integer; + function GetCaseSensitive: Boolean; + function GetDuplicates: TDuplicates; + function GetOnChange: TNotifyEvent; + function GetOnChanging: TNotifyEvent; + function GetSorted: Boolean; + function Equals(Strings: TStrings): Boolean; + function IndexOfName(const Name: string): Integer; + function IndexOfObject(AObject: TObject): Integer; + function LoadFromFile(const FileName: string): IJclStringList; + function LoadFromStream(Stream: TStream): IJclStringList; + function SaveToFile(const FileName: string): IJclStringList; + function SaveToStream(Stream: TStream): IJclStringList; + function GetCommaText: string; + function GetDelimitedText: string; + function GetDelimiter: Char; + function GetName(Index: Integer): string; + {$IFDEF COMPILER7_UP} + function GetNameValueSeparator: Char; + function GetValueFromIndex(Index: Integer): string; + {$ENDIF COMPILER7_UP} + function GetQuoteChar: Char; + procedure SetCommaText(const Value: string); + procedure SetDelimitedText(const Value: string); + procedure SetDelimiter(const Value: Char); + {$IFDEF COMPILER7_UP} + procedure SetNameValueSeparator(const Value: Char); + procedure SetValueFromIndex(Index: Integer; const Value: string); + {$ENDIF COMPILER7_UP} + procedure SetQuoteChar(const Value: Char); + procedure AddStrings(Strings: TStrings); overload; + procedure SetObjects(Index: Integer; const Value: TObject); + procedure Put(Index: Integer; const S: string); + procedure SetCapacity(NewCapacity: Integer); + procedure SetTextStr(const Value: string); + procedure SetValue(const Name, Value: string); + procedure SetCaseSensitive(const Value: Boolean); + procedure SetDuplicates(const Value: TDuplicates); + procedure SetOnChange(const Value: TNotifyEvent); + procedure SetOnChanging(const Value: TNotifyEvent); + procedure SetSorted(const Value: Boolean); + property Count: Integer read GetCount; + property Strings[Index: Integer]: string read Get write Put; default; + property Text: string read GetTextStr write SetTextStr; + property Objects[Index: Integer]: TObject read GetObjects write SetObjects; + property Capacity: Integer read GetCapacity write SetCapacity; + property Values[const Name: string]: string read GetValue write SetValue; + property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; + property Sorted: Boolean read GetSorted write SetSorted; + property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read GetOnChange write SetOnChange; + property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; + property DelimitedText: string read GetDelimitedText write SetDelimitedText; + property Delimiter: Char read GetDelimiter write SetDelimiter; + property Names[Index: Integer]: string read GetName; + property QuoteChar: Char read GetQuoteChar write SetQuoteChar; + property CommaText: string read GetCommaText write SetCommaText; + {$IFDEF COMPILER7_UP} + property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; + {$ENDIF COMPILER7_UP} + { New } + function Assign(Source: TPersistent): IJclStringList; + function LoadExeParams: IJclStringList; + function Exists(const S: string): Boolean; + function ExistsName(const S: string): Boolean; + function DeleteBlanks: IJclStringList; + function KeepIntegers: IJclStringList; + function DeleteIntegers: IJclStringList; + function ReleaseInterfaces: IJclStringList; + function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; + function Clone: IJclStringList; + function Insert(Index: Integer; const S: string): IJclStringList; + function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; + function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; + function SortAsInteger: IJclStringList; + function SortByName: IJclStringList; + function Delete(AIndex: Integer): IJclStringList; overload; + function Delete(const AString: string): IJclStringList; overload; + function Exchange(Index1, Index2: Integer): IJclStringList; + function Add(const A: array of const): IJclStringList; overload; + function AddStrings(const A: array of string): IJclStringList; overload; + function BeginUpdate: IJclStringList; + function EndUpdate: IJclStringList; + function Trim: IJclStringList; + function Join(const ASeparator: string = ''): string; + function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; + function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; + function Last: string; + function First: string; + function LastIndex: Integer; + function Clear: IJclStringList; + {$IFDEF JCL_PCRE} + function DeleteRegEx(const APattern: string): IJclStringList; + function KeepRegEx(const APattern: string): IJclStringList; + function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + {$ENDIF JCL_PCRE} + function GetStringsRef: TStrings; + function ConfigAsSet: IJclStringList; + function Delimit(const ADelimiter: string): IJclStringList; + function GetInterfaceByIndex(Index: Integer): IInterface; + function GetLists(Index: Integer): IJclStringList; + function GetVariants(AIndex: Integer): Variant; + function GetKeyInterface(const AKey: string): IInterface; + function GetKeyObject(const AKey: string): TObject; + function GetKeyVariant(const AKey: string): Variant; + function GetKeyList(const AKey: string): IJclStringList; + function GetObjectsMode: TJclStringListObjectsMode; + procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); + procedure SetLists(Index: Integer; const Value: IJclStringList); + procedure SetVariants(Index: Integer; const Value: Variant); + procedure SetKeyInterface(const AKey: string; const Value: IInterface); + procedure SetKeyObject(const AKey: string; const Value: TObject); + procedure SetKeyVariant(const AKey: string; const Value: Variant); + procedure SetKeyList(const AKey: string; const Value: IJclStringList); + property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; + property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; + property Variants[Index: Integer]: Variant read GetVariants write SetVariants; + property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; + property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; + property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; + property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; + property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; + end; + +type + TJclInterfacedStringList = class(TStringList, IInterface) + private + FOwnerInterface: IInterface; + public + { IInterface } + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall; + procedure AfterConstruction; override; + end; + + + TJclStringList = class(TJclInterfacedStringList, IInterface, IJclStringList) + private + FObjectsMode: TJclStringListObjectsMode; + FSelfAsInterface: IJclStringList; + {$IFDEF JCL_PCRE} + FLastRegExPattern: string; + FRegEx: TJclRegEx; + {$ENDIF JCL_PCRE} + FCompareFunction: TJclStringListSortCompare; + function CanFreeObjects: Boolean; + {$IFDEF JCL_PCRE} + function MatchRegEx(const S, APattern: string): Boolean; + {$ENDIF JCL_PCRE} + procedure EnsureObjectsMode(AMode: TJclStringListObjectsMode); + protected + FRefCount: Integer; + {$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} + function CompareStrings(const S1, S2: string): Integer; virtual; + {$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} + public + constructor Create; + destructor Destroy; override; + { IInterface } + // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { IJclStringList } + // function Add(const S: string): Integer; overload; + // function AddObject(const S: string; AObject: TObject): Integer; + // function Get(Index: Integer): string; + // function GetCapacity: Integer; + // function GetCount: Integer; + function GetObjects(Index: Integer): TObject; + // function GetTextStr: string; + function GetValue(const Name: string): string; + // function Find(const S: string; var Index: Integer): Boolean; + // function IndexOf(const S: string): Integer; + function GetCaseSensitive: Boolean; + function GetDuplicates: TDuplicates; + function GetOnChange: TNotifyEvent; + function GetOnChanging: TNotifyEvent; + function GetSorted: Boolean; + // function Equals(Strings: TStrings): Boolean; + // function IndexOfName(const Name: string): Integer; + // function IndexOfObject(AObject: TObject): Integer; + function LoadFromFile(const FileName: string): IJclStringList; reintroduce; + function LoadFromStream(Stream: TStream): IJclStringList; reintroduce; + function SaveToFile(const FileName: string): IJclStringList; reintroduce; + function SaveToStream(Stream: TStream): IJclStringList; reintroduce; + function GetCommaText: string; + function GetDelimitedText: string; + function GetDelimiter: Char; + function GetName(Index: Integer): string; + {$IFDEF COMPILER7_UP} + function GetNameValueSeparator: Char; + function GetValueFromIndex(Index: Integer): string; + {$ENDIF COMPILER7_UP} + function GetQuoteChar: Char; + procedure SetCommaText(const Value: string); + procedure SetDelimitedText(const Value: string); + procedure SetDelimiter(const Value: Char); + {$IFDEF COMPILER7_UP} + procedure SetNameValueSeparator(const Value: Char); + procedure SetValueFromIndex(Index: Integer; const Value: string); + {$ENDIF COMPILER7_UP} + procedure SetQuoteChar(const Value: Char); + // procedure AddStrings(Strings: TStrings); overload; + procedure SetObjects(Index: Integer; const Value: TObject); + // procedure Put(Index: Integer; const S: string); + // procedure SetCapacity(NewCapacity: Integer); + // procedure SetTextStr(const Value: string); + procedure SetValue(const Name, Value: string); + procedure SetCaseSensitive(const Value: Boolean); + procedure SetDuplicates(const Value: TDuplicates); + procedure SetOnChange(const Value: TNotifyEvent); + procedure SetOnChanging(const Value: TNotifyEvent); + procedure SetSorted(const Value: Boolean); + property Count: Integer read GetCount; + property Strings[Index: Integer]: string read Get write Put; default; + property Text: string read GetTextStr write SetTextStr; + property Objects[Index: Integer]: TObject read GetObjects write SetObjects; + property Capacity: Integer read GetCapacity write SetCapacity; + property Values[const Name: string]: string read GetValue write SetValue; + property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; + property Sorted: Boolean read GetSorted write SetSorted; + property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read GetOnChange write SetOnChange; + property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging; + property DelimitedText: string read GetDelimitedText write SetDelimitedText; + property Delimiter: Char read GetDelimiter write SetDelimiter; + property Names[Index: Integer]: string read GetName; + property QuoteChar: Char read GetQuoteChar write SetQuoteChar; + property CommaText: string read GetCommaText write SetCommaText; + {$IFDEF COMPILER7_UP} + property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator; + {$ENDIF COMPILER7_UP} + { New } + function Assign(Source: TPersistent): IJclStringList; reintroduce; + function LoadExeParams: IJclStringList; + function Exists(const S: string): Boolean; + function ExistsName(const S: string): Boolean; + function DeleteBlanks: IJclStringList; + function KeepIntegers: IJclStringList; + function DeleteIntegers: IJclStringList; + function ReleaseInterfaces: IJclStringList; + function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; + function Clone: IJclStringList; + function Insert(Index: Integer; const S: string): IJclStringList; reintroduce; + function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; reintroduce; + function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; reintroduce; + function SortAsInteger: IJclStringList; + function SortByName: IJclStringList; + function Delete(AIndex: Integer): IJclStringList; reintroduce; overload; + function Delete(const AString: string): IJclStringList; reintroduce; overload; + function Exchange(Index1, Index2: Integer): IJclStringList; reintroduce; + function Add(const A: array of const): IJclStringList; reintroduce; overload; + function AddStrings(const A: array of string): IJclStringList; reintroduce; overload; + function BeginUpdate: IJclStringList; + function EndUpdate: IJclStringList; + function Trim: IJclStringList; + function Join(const ASeparator: string = ''): string; + function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList; + function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList; + function Last: string; + function First: string; + function LastIndex: Integer; + function Clear: IJclStringList; reintroduce; + {$IFDEF JCL_PCRE} + function DeleteRegEx(const APattern: string): IJclStringList; + function KeepRegEx(const APattern: string): IJclStringList; + function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + {$ENDIF JCL_PCRE} + function GetStringsRef: TStrings; + function ConfigAsSet: IJclStringList; + function Delimit(const ADelimiter: string): IJclStringList; + function GetInterfaceByIndex(Index: Integer): IInterface; + function GetLists(Index: Integer): IJclStringList; + function GetVariants(AIndex: Integer): Variant; + function GetKeyInterface(const AKey: string): IInterface; + function GetKeyObject(const AKey: string): TObject; + function GetKeyVariant(const AKey: string): Variant; + function GetKeyList(const AKey: string): IJclStringList; + function GetObjectsMode: TJclStringListObjectsMode; + procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface); + procedure SetLists(Index: Integer; const Value: IJclStringList); + procedure SetVariants(Index: Integer; const Value: Variant); + procedure SetKeyInterface(const AKey: string; const Value: IInterface); + procedure SetKeyObject(const AKey: string; const Value: TObject); + procedure SetKeyVariant(const AKey: string; const Value: Variant); + procedure SetKeyList(const AKey: string; const Value: IJclStringList); + property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex; + property Lists[Index: Integer]: IJclStringList read GetLists write SetLists; + property Variants[Index: Integer]: Variant read GetVariants write SetVariants; + property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList; + property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject; + property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface; + property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant; + property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode; + end; + +function JclStringList: IJclStringList; overload; +function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; +function JclStringListStrings(const A: array of string): IJclStringList; overload; +function JclStringList(const A: array of const): IJclStringList; overload; +function JclStringList(const AText: string): IJclStringList; overload; + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNITSCOPE} + System.TypInfo, + {$ELSE ~HAS_UNITSCOPE} + TypInfo, + {$ENDIF ~HAS_UNITSCOPE} + JclFileUtils, + JclStrings; + +type + TVariantWrapper = class(TObject) + private + FValue: Variant; + end; + + TInterfaceWrapper = class(TObject) + private + FValue: IInterface; + end; + +function JclStringList: IJclStringList; +begin + Result := TJclStringList.Create; +end; + +function JclStringList(const AText: string): IJclStringList; overload; +begin + Result := JclStringList; + Result.Text := AText; +end; + +function JclStringListStrings(AStrings: TStrings): IJclStringList; overload; +begin + Result := JclStringList; + Result.AddStrings(AStrings); +end; + +function JclStringListStrings(const A: array of string): IJclStringList; +begin + Result := JclStringList.AddStrings(A); +end; + +function JclStringList(const A: array of const): IJclStringList; +begin + Result := JclStringList.Add(A); +end; + +//=== { TJclInterfacedStringList } ============================================== + +procedure TJclInterfacedStringList.AfterConstruction; +Var + MyOwner : TPersistent; +begin + inherited; + MyOwner := GetOwner; + if Assigned(MyOwner) then + MyOwner.GetInterface(IUnknown,FOwnerInterface); +end; + + +function TJclInterfacedStringList._AddRef: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result := FOwnerInterface._AddRef + else + Result := -1; +end; + + +function TJclInterfacedStringList._Release: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result := FOwnerInterface._Release + else + Result := -1; +end; + + +function TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +//=== { TJclStringList } ===================================================== + +function TJclStringList.Add(const A: array of const): IJclStringList; +const + BoolToStr: array [Boolean] of string[5] = ('false', 'true'); +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := Low(A) to High(A) do + case A[I].VType of + vtInteger: + Add(IntToStr(A[I].VInteger)); + vtBoolean: + Add(string(BoolToStr[A[I].VBoolean])); + vtChar: + Add(string(AnsiString(A[I].VChar))); + vtExtended: + Add(FloatToStr(A[I].VExtended^)); + vtString: + Add(string(A[I].VString^)); + vtPChar: + Add(string(AnsiString(A[I].VPChar))); + vtPWideChar: + Add(string(WideString(A[I].VPWideChar))); + vtObject: + Add(A[I].VObject.ClassName); + vtClass: + Add(A[I].VClass.ClassName); + vtAnsiString: + Add(string(A[I].VAnsiString)); + vtWideString: + Add(string(A[I].VWideString)); + vtCurrency: + Add(CurrToStr(A[I].VCurrency^)); + vtVariant: + Add(string(A[I].VVariant^)); + vtInt64: + Add(IntToStr(A[I].VInt64^)); + {$IFDEF SUPPORTS_UNICODE_STRING} + vtUnicodeString: + Add(string(A[I].VUnicodeString)); + {$ENDIF SUPPORTS_UNICODE_STRING} + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.AddStrings(const A: array of string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := Low(A) to High(A) do + Add(A[I]); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.BeginUpdate: IJclStringList; +begin + inherited BeginUpdate; + Result := FSelfAsInterface; +end; + +function TJclStringList.Clear: IJclStringList; +begin + if CanFreeObjects then + FreeObjects(False); + inherited Clear; + Result := FSelfAsInterface; +end; + +function TJclStringList.EndUpdate: IJclStringList; +begin + inherited EndUpdate; + Result := FSelfAsInterface; +end; + +function TJclStringList.ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar; + AClearBeforeAdd: Boolean): IJclStringList; +var + L, I, X: Integer; +begin + Result := BeginUpdate; + try + if AClearBeforeAdd then + Clear; + I := 1; + L := Length(AText); + while I <= L do + begin + while (I <= L) and (AnsiChar(AText[I]) in ADelims) do + Inc(I); + X := I; + while (I <= L) and not (AnsiChar(AText[I]) in ADelims) do + Inc(I); + if X <> I then + Add(Copy(AText, X, I - X)); + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.First: string; +begin + Result := Strings[0]; +end; + +function TJclStringList.Join(const ASeparator: string): string; +var + I: Integer; + SB: TStringBuilder; // Implemented by JclStrings, if missed in RTL +begin + if Count <= 0 then + Result := '' + else begin + SB := TStringBuilder.Create(First); + // Warming up ? Worth it ? Capacity: Sum([Strings]) + (Count-1) * [ASeparator] ? + try + for I := 1 to LastIndex do + SB.Append(ASeparator).Append(Strings[i]); + Result := SB.ToString; + finally + SB.Free; + end; + end; +// for I := 0 to LastIndex - 1 do +// Result := Result + Strings[I] + ASeparator; +// if Count > 0 then +// Result := Result + Last; +end; + +function TJclStringList.Last: string; +begin + Result := Strings[LastIndex]; +end; + +function TJclStringList.Split(const AText, ASeparator: string; + AClearBeforeAdd: Boolean = True): IJclStringList; +var + LStartIndex, LEndIndex: Integer; + LLengthSeparator: Integer; +begin + Result := FSelfAsInterface; + if AText <> '' then + begin + Result := BeginUpdate; + try + if AClearBeforeAdd then + Clear; + LLengthSeparator := Length(ASeparator); + LStartIndex := 1; + LEndIndex := StrSearch(ASeparator, AText, LStartIndex); + while LEndIndex > 0 do + begin + Add(Copy(AText, LStartIndex, LEndIndex - LStartIndex)); + LStartIndex := LEndIndex + LLengthSeparator; + LEndIndex := StrSearch(ASeparator, AText, LStartIndex); + end; + Add(Copy(AText, LStartIndex, MaxInt)); + finally + Result := EndUpdate; + end; + end; +end; + +function TJclStringList.Trim: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Strings[I] := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TJclStringList._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 1 then + begin + // When there is only one reference, it is the internal reference, + // so we release it. The compiler will call _Release again and + // the object will be destroyed. + FSelfAsInterface := nil; + end + else + if Result = 0 then begin + pointer(FSelfAsInterface) := nil; // should work in .create / FreeAndNil scenario + Destroy; + end; +end; + +{$IFDEF JCL_PCRE} +function TJclStringList.DeleteRegEx(const APattern: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if MatchRegEx(Strings[I], APattern) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.KeepRegEx(const APattern: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if not MatchRegEx(Strings[I], APattern) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.MatchRegEx(const S, APattern: string): Boolean; +begin + if FRegEx = nil then + FRegEx := TJclRegEx.Create; + if FLastRegExPattern <> APattern then + begin + if CaseSensitive then + FRegEx.Options := FRegEx.Options - [roIgnoreCase] + else + FRegEx.Options := FRegEx.Options + [roIgnoreCase]; + FRegEx.Compile(APattern, False, True); + FLastRegExPattern := APattern; + end; + Result := FRegEx.Match(S); +end; +{$ENDIF JCL_PCRE} + +destructor TJclStringList.Destroy; +begin + if (FRefCount = 1) and (FSelfAsInterface <> nil) then begin + pointer(FSelfAsInterface) := nil; + FRefCount := 0; // should work in .Create -> FreeAndNil scenario + end; + if CanFreeObjects then + FreeObjects(False); + {$IFDEF JCL_PCRE} + FreeAndNil(FRegEx); + {$ENDIF JCL_PCRE} + inherited Destroy; +end; + +{$IFDEF JCL_PCRE} +function TJclStringList.Directories(const APattern: string = '*'; + ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + + procedure DoDirectories(const APattern: string); + var + LSearchRec: TSearchRec; + LFullName: string; + LPath: string; + begin + LPath := ExtractFilePath(APattern); + if FindFirst(APattern, faAnyFile, LSearchRec) = 0 then + try + repeat + if (LSearchRec.Attr and faDirectory = 0) or + (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then + Continue; + LFullName := LPath + LSearchRec.Name; + if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then + Add(LFullName); + if ARecursive then + DoDirectories(PathAddSeparator(LFullName) + ExtractFileName(APattern)); + until FindNext(LSearchRec) <> 0; + finally + FindClose(LSearchRec); + end; + end; + +begin + Result := BeginUpdate; + try + if DirectoryExists(APattern) then + DoDirectories(PathAddSeparator(APattern) + '*') + else + DoDirectories(APattern); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Files(const APattern: string = '*'; + ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList; + + procedure DoFiles(const APattern: string); + var + LSearchRec: TSearchRec; + LFullName: string; + LDirectories: IJclStringList; + LPath: string; + I: Integer; + begin + LPath := ExtractFilePath(APattern); + if FindFirst(APattern, faAnyFile and not faDirectory, LSearchRec) = 0 then + begin + try + repeat + if (LSearchRec.Attr and faDirectory <> 0) or + (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then + Continue; + LFullName := LPath + LSearchRec.Name; + if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then + Add(LFullName); + until FindNext(LSearchRec) <> 0; + finally + FindClose(LSearchRec); + end; + end; + if ARecursive then + begin + LDirectories := JclStringList.Directories(LPath + '*', False); + for I := 0 to LDirectories.LastIndex do + DoFiles(PathAddSeparator(LDirectories[I]) + ExtractFileName(APattern)); + end; + end; + +begin + Result := BeginUpdate; + try + if DirectoryExists(APattern) then + DoFiles(PathAddSeparator(APattern) + '*') + else + DoFiles(APattern); + finally + Result := EndUpdate; + end; +end; +{$ENDIF JCL_PCRE} + +function TJclStringList.LastIndex: Integer; +begin + { The code bellow is more optimized than "Result := Count - 1". } + Result := Count; + Dec(Result); +end; + +constructor TJclStringList.Create; +begin + inherited Create; + if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then + System.Error(reIntfCastError); + // InterlockedDecrement(FRefCount); // should work w/o dangling pointers - bug #6081 +end; + +function TJclStringList.GetLists(Index: Integer): IJclStringList; +begin + Result := Interfaces[Index] as IJclStringList; + if Result = nil then + begin + Result := JclStringList; + Interfaces[Index] := Result; + end; +end; + +procedure TJclStringList.SetLists(Index: Integer; const Value: IJclStringList); +begin + Interfaces[Index] := Value; +end; + +function TJclStringList.GetStringsRef: TStrings; +begin + Result := Self; +end; + +function TJclStringList.GetKeyInterface(const AKey: string): IInterface; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Interfaces[I] + else + Result := nil; +end; + +function TJclStringList.GetKeyObject(const AKey: string): TObject; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Objects[I] + else + Result := nil; +end; + +procedure TJclStringList.SetKeyInterface(const AKey: string; const Value: IInterface); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + I := Add(AKey); + Interfaces[I] := Value +end; + +procedure TJclStringList.SetKeyObject(const AKey: string; const Value: TObject); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + AddObject(AKey, Value) + else + Objects[I] := Value; +end; + +function TJclStringList.ConfigAsSet: IJclStringList; +begin + Sorted := True; + Duplicates := dupIgnore; + Result := FSelfAsInterface; +end; + +function TJclStringList.GetKeyVariant(const AKey: string): Variant; +var + I: Integer; +begin + I := IndexOf(AKey); + if I >= 0 then + Result := Variants[I] + else + Result := Unassigned; +end; + +procedure TJclStringList.SetKeyVariant(const AKey: string; const Value: Variant); +var + I: Integer; +begin + I := IndexOf(AKey); + if I < 0 then + I := Add(AKey); + Variants[I] := Value +end; + +function TJclStringList.GetValue(const Name: string): string; +begin + Result := inherited Values[Name]; +end; + +procedure TJclStringList.SetValue(const Name, Value: string); +begin + inherited Values[Name] := Value; +end; + +function TJclStringList.GetInterfaceByIndex(Index: Integer): IInterface; +var + V: TInterfaceWrapper; +begin + if FObjectsMode <> omInterfaces then + EnsureObjectsMode(omInterfaces); + V := TInterfaceWrapper(inherited Objects[Index]); + if V = nil then + Result := nil + else + Result := V.FValue; +end; + +procedure TJclStringList.SetInterfaceByIndex(Index: Integer; const Value: IInterface); +var + V: TInterfaceWrapper; +begin + if FObjectsMode <> omInterfaces then + EnsureObjectsMode(omInterfaces); + V := TInterfaceWrapper(inherited Objects[Index]); + if V = nil then + begin + V := TInterfaceWrapper.Create; + inherited Objects[Index] := V; + end; + V.FValue := Value; +end; + +function TJclStringList.GetObjects(Index: Integer): TObject; +begin + if FObjectsMode <> omObjects then + EnsureObjectsMode(omObjects); + Result := inherited Objects[Index]; +end; + +procedure TJclStringList.SetObjects(Index: Integer; const Value: TObject); +begin + if FObjectsMode <> omObjects then + EnsureObjectsMode(omObjects); + inherited Objects[Index] := Value; +end; + +function TJclStringList.GetVariants(AIndex: Integer): Variant; +var + V: TVariantWrapper; +begin + if FObjectsMode <> omVariants then + EnsureObjectsMode(omVariants); + V := TVariantWrapper(inherited Objects[AIndex]); + if V = nil then + Result := Unassigned + else + Result := V.FValue; +end; + +procedure TJclStringList.SetVariants(Index: Integer; const Value: Variant); +var + V: TVariantWrapper; +begin + if FObjectsMode <> omVariants then + EnsureObjectsMode(omVariants); + V := TVariantWrapper(inherited Objects[Index]); + if V = nil then + begin + V := TVariantWrapper.Create; + inherited Objects[Index] := V; + end; + V.FValue := Value; +end; + +procedure TJclStringList.EnsureObjectsMode(AMode: TJclStringListObjectsMode); +begin + if FObjectsMode <> AMode then + begin + if FObjectsMode <> omNone then + begin + raise EJclStringListError.CreateFmt('Objects cannot be used as "%s" because it has been used as "%s".', + [GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(AMode)), + GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(FObjectsMode))]); + end; + FObjectsMode := AMode; + end; +end; + +function TJclStringList.GetKeyList(const AKey: string): IJclStringList; +begin + Result := KeyInterface[AKey] as IJclStringList; + if Result = nil then + begin + Result := JclStringList; + KeyInterface[AKey] := Result; + end; +end; + +procedure TJclStringList.SetKeyList(const AKey: string; const Value: IJclStringList); +begin + KeyInterface[AKey] := Value; +end; + +function TJclStringList.Delete(AIndex: Integer): IJclStringList; +begin + if CanFreeObjects then + inherited Objects[AIndex].Free; + inherited Delete(AIndex); + Result := FSelfAsInterface; +end; + +function TJclStringList.Delete(const AString: string): IJclStringList; +begin + Result := Delete(IndexOf(AString)); +end; + +function TJclStringList.Exchange(Index1, Index2: Integer): IJclStringList; +begin + inherited Exchange(Index1, Index2); + Result := FSelfAsInterface; +end; + +function LocalSort(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := TJclStringList(List).FCompareFunction(TJclStringList(List).FSelfAsInterface, Index1, Index2); +end; + +function TJclStringList.Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; +begin + FCompareFunction := ACompareFunction; + if not Assigned(ACompareFunction) then + inherited Sort + else + inherited CustomSort(@LocalSort); + Result := FSelfAsInterface; +end; + +function LocalSortAsInteger(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := StrToInt(List[Index1]) - StrToInt(List[Index2]); +end; + +function TJclStringList.SortAsInteger: IJclStringList; +begin + inherited CustomSort(@LocalSortAsInteger); + Result := FSelfAsInterface; +end; + +{$IFNDEF HAS_TSTRINGS_COMPARESTRINGS} +function TJclStringList.CompareStrings(const S1, S2: string): Integer; +begin + Result := AnsiCompareText(S1, S2); +end; +{$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS} + +function LocalSortByName(List: TStringList; Index1, Index2: Integer): Integer; +begin + Result := TJclStringList(List).CompareStrings(List.Names[Index1], List.Names[Index2]); +end; + +function TJclStringList.SortByName: IJclStringList; +begin + inherited CustomSort(@LocalSortByName); + Result := FSelfAsInterface; +end; + +function TJclStringList.Insert(Index: Integer; const S: string): IJclStringList; +begin + inherited Insert(Index, S); + Result := FSelfAsInterface; +end; + +function TJclStringList.InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; +begin + inherited InsertObject(Index, S, AObject); + Result := FSelfAsInterface; +end; + +function TJclStringList.GetCaseSensitive: Boolean; +begin + Result := inherited CaseSensitive; +end; + +function TJclStringList.GetDuplicates: TDuplicates; +begin + Result := inherited Duplicates; +end; + +function TJclStringList.GetOnChange: TNotifyEvent; +begin + Result := inherited OnChange; +end; + +function TJclStringList.GetOnChanging: TNotifyEvent; +begin + Result := inherited OnChanging; +end; + +function TJclStringList.GetSorted: Boolean; +begin + Result := inherited Sorted; +end; + +procedure TJclStringList.SetCaseSensitive(const Value: Boolean); +begin + inherited CaseSensitive := Value; +end; + +procedure TJclStringList.SetDuplicates(const Value: TDuplicates); +begin + inherited Duplicates := Value; +end; + +procedure TJclStringList.SetOnChange(const Value: TNotifyEvent); +begin + inherited OnChange := Value; +end; + +procedure TJclStringList.SetOnChanging(const Value: TNotifyEvent); +begin + inherited OnChanging := Value; +end; + +procedure TJclStringList.SetSorted(const Value: Boolean); +begin + inherited Sorted := Value; +end; + +function TJclStringList.LoadFromFile(const FileName: string): IJclStringList; +begin + inherited LoadFromFile(FileName); + Result := FSelfAsInterface; +end; + +function TJclStringList.LoadFromStream(Stream: TStream): IJclStringList; +begin + inherited LoadFromStream(Stream); + Result := FSelfAsInterface; +end; + +function TJclStringList.SaveToFile(const FileName: string): IJclStringList; +begin + inherited SaveToFile(FileName); + Result := FSelfAsInterface; +end; + +function TJclStringList.SaveToStream(Stream: TStream): IJclStringList; +begin + inherited SaveToStream(Stream); + Result := FSelfAsInterface; +end; + +function TJclStringList.GetCommaText: string; +begin + Result := inherited CommaText; +end; + +function TJclStringList.GetDelimitedText: string; +begin + Result := inherited DelimitedText; +end; + +function TJclStringList.GetDelimiter: Char; +begin + Result := inherited Delimiter; +end; + +function TJclStringList.GetName(Index: Integer): string; +begin + Result := inherited Names[Index]; +end; + +{$IFDEF COMPILER7_UP} + +function TJclStringList.GetNameValueSeparator: Char; +begin + Result := inherited NameValueSeparator; +end; + +function TJclStringList.GetValueFromIndex(Index: Integer): string; +begin + Result := inherited ValueFromIndex[Index]; +end; + +{$ENDIF COMPILER7_UP} + +function TJclStringList.GetQuoteChar: Char; +begin + Result := inherited QuoteChar; +end; + +procedure TJclStringList.SetCommaText(const Value: string); +begin + inherited CommaText := Value; +end; + +procedure TJclStringList.SetDelimitedText(const Value: string); +begin + inherited DelimitedText := Value; +end; + +procedure TJclStringList.SetDelimiter(const Value: Char); +begin + inherited Delimiter := Value; +end; + +{$IFDEF COMPILER7_UP} + +procedure TJclStringList.SetNameValueSeparator(const Value: Char); +begin + inherited NameValueSeparator := Value; +end; + +procedure TJclStringList.SetValueFromIndex(Index: Integer; const Value: string); +begin + inherited ValueFromIndex[Index] := Value; +end; + +{$ENDIF COMPILER7_UP} + +procedure TJclStringList.SetQuoteChar(const Value: Char); +begin + inherited QuoteChar := Value; +end; + +function TJclStringList.Delimit(const ADelimiter: string): IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Strings[I] := ADelimiter + Strings[I] + ADelimiter; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.LoadExeParams: IJclStringList; +var + I: Integer; + S: string; +begin + Result := BeginUpdate; + try + Clear; + for I := 1 to ParamCount do + begin + S := ParamStr(I); + if (S[1] = '-') or (S[1] = '/') then + System.Delete(S, 1, 1); + Add(S); + end; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Exists(const S: string): Boolean; +begin + Result := IndexOf(S) >= 0; +end; + +function TJclStringList.ExistsName(const S: string): Boolean; +begin + Result := IndexOfName(S) >= 0; +end; + +function TJclStringList.DeleteBlanks: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := LastIndex downto 0 do + if {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]) = '' then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.KeepIntegers: IJclStringList; +var + I, X: Integer; +begin + Result := BeginUpdate; + try + X := 0; + for I := LastIndex downto 0 do + if not TryStrToInt(Strings[I], X) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.DeleteIntegers: IJclStringList; +var + I, X: Integer; +begin + Result := BeginUpdate; + try + X := 0; + for I := LastIndex downto 0 do + if TryStrToInt(Strings[I], X) then + Delete(I); + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.FreeObjects(AFreeAndNil: Boolean = False): IJclStringList; +var + I: Integer; +begin + if AFreeAndNil then + Result := BeginUpdate; + for I := 0 to LastIndex do + begin + inherited Objects[I].Free; + if AFreeAndNil then + inherited Objects[I] := nil; + end; + if AFreeAndNil then + Result := EndUpdate + else + Result := FSelfAsInterface; +end; + +function TJclStringList.ReleaseInterfaces: IJclStringList; +var + I: Integer; +begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + Interfaces[I] := nil; + finally + Result := EndUpdate; + end; +end; + +function TJclStringList.Clone: IJclStringList; +begin + Result := JclStringList.Assign(Self); +end; + +function TJclStringList.Assign(Source: TPersistent): IJclStringList; +var + L: TJclStringList; + I: Integer; +begin + inherited Assign(Source); + Result := FSelfAsInterface; + if Source is TJclStringList then + begin + L := TJclStringList(Source); + FObjectsMode := L.FObjectsMode; + if not (FObjectsMode in [omNone, omObjects]) then + begin + Result := BeginUpdate; + try + for I := 0 to LastIndex do + begin + inherited Objects[I] := nil; + case FObjectsMode of + omVariants: + Variants[I] := L.Variants[I]; + omInterfaces: + Interfaces[I] := L.Interfaces[I]; + end; + end; + finally + Result := EndUpdate; + end; + end; + end; +end; + +function TJclStringList.CanFreeObjects: Boolean; +begin + Result := not (FObjectsMode in [omNone, omObjects]); +end; + +function TJclStringList.GetObjectsMode: TJclStringListObjectsMode; +begin + Result := FObjectsMode; +end; + +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} + +end. diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 912fcb84c5..0a35bd473b 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -1,5519 +1,5519 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ 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 JclStrings.pas. } -{ } -{ The Initial Developer of the Original Code is Marcel van Brakel. } -{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. } -{ } -{ Contributor(s): } -{ Alexander Radchenko } -{ Andreas Hausladen (ahuser) } -{ Anthony Steele } -{ Azret Botash } -{ Barry Kelly } -{ Huanlin Tsai } -{ Jack N.A. Bakker } -{ Jean-Fabien Connault (cycocrew) } -{ John C Molyneux } -{ Kiriakos Vlahos } -{ Leonard Wennekers } -{ Marcel Bestebroer } -{ Martin Kimmings } -{ Martin Kubecka } -{ Massimo Maria Ghisalberti } -{ Matthias Thoma (mthoma) } -{ Michael Winter } -{ Nick Hodges } -{ Olivier Sannier (obones) } -{ Pelle F. S. Liljendal } -{ Petr Vones (pvones) } -{ Rik Barker (rikbarker) } -{ Robert Lee } -{ Robert Marquardt (marquardt) } -{ Robert Rossmair (rrossmair) } -{ Andreas Schmidt } -{ Sean Farrow (sfarrow) } -{ } -{**************************************************************************************************} -{ } -{ Various character and string routines (searching, testing and transforming) } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -unit JclStrings; - -{$I jcl.inc} - -interface - -uses - {$IFDEF UNITVERSIONING} - JclUnitVersioning, - {$ENDIF UNITVERSIONING} - {$IFDEF HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Winapi.Windows, - {$ENDIF MSWINDOWS} - {$IFDEF UNICODE_RTL_DATABASE} - System.Character, - {$ENDIF UNICODE_RTL_DATABASE} - System.Classes, System.SysUtils, - {$ELSE ~HAS_UNITSCOPE} - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF MSWINDOWS} - {$IFDEF UNICODE_RTL_DATABASE} - Character, - {$ENDIF UNICODE_RTL_DATABASE} - Classes, SysUtils, - {$ENDIF ~HAS_UNITSCOPE} - JclAnsiStrings, - JclWideStrings, - JclBase; - -// Exceptions -type - EJclStringError = class(EJclError); - -// Character constants and sets - -const - // Misc. often used character definitions - NativeNull = Char(#0); - NativeSoh = Char(#1); - NativeStx = Char(#2); - NativeEtx = Char(#3); - NativeEot = Char(#4); - NativeEnq = Char(#5); - NativeAck = Char(#6); - NativeBell = Char(#7); - NativeBackspace = Char(#8); - NativeTab = Char(#9); - NativeLineFeed = JclBase.NativeLineFeed; - NativeVerticalTab = Char(#11); - NativeFormFeed = Char(#12); - NativeCarriageReturn = JclBase.NativeCarriageReturn; - NativeCrLf = JclBase.NativeCrLf; - NativeSo = Char(#14); - NativeSi = Char(#15); - NativeDle = Char(#16); - NativeDc1 = Char(#17); - NativeDc2 = Char(#18); - NativeDc3 = Char(#19); - NativeDc4 = Char(#20); - NativeNak = Char(#21); - NativeSyn = Char(#22); - NativeEtb = Char(#23); - NativeCan = Char(#24); - NativeEm = Char(#25); - NativeEndOfFile = Char(#26); - NativeEscape = Char(#27); - NativeFs = Char(#28); - NativeGs = Char(#29); - NativeRs = Char(#30); - NativeUs = Char(#31); - NativeSpace = Char(' '); - NativeComma = Char(','); - NativeBackslash = Char('\'); - NativeForwardSlash = Char('/'); - - NativeDoubleQuote = Char('"'); - NativeSingleQuote = Char(''''); - - NativeLineBreak = JclBase.NativeLineBreak; - -const - // CharType return values - C1_UPPER = $0001; // Uppercase - C1_LOWER = $0002; // Lowercase - C1_DIGIT = $0004; // Decimal digits - C1_SPACE = $0008; // Space characters - C1_PUNCT = $0010; // Punctuation - C1_CNTRL = $0020; // Control characters - C1_BLANK = $0040; // Blank characters - C1_XDIGIT = $0080; // Hexadecimal digits - C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic - - {$IFDEF MSWINDOWS} - {$IFDEF SUPPORTS_EXTSYM} - {$EXTERNALSYM C1_UPPER} - {$EXTERNALSYM C1_LOWER} - {$EXTERNALSYM C1_DIGIT} - {$EXTERNALSYM C1_SPACE} - {$EXTERNALSYM C1_PUNCT} - {$EXTERNALSYM C1_CNTRL} - {$EXTERNALSYM C1_BLANK} - {$EXTERNALSYM C1_XDIGIT} - {$EXTERNALSYM C1_ALPHA} - {$ENDIF SUPPORTS_EXTSYM} - {$ENDIF MSWINDOWS} - -type - TCharValidator = function(const C: Char): Boolean; - -function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload; -function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; - -// String Test Routines -// TODO: think of some choosen N, so that: If both string length and array length > N - then pre-sort the array -// and use optimized (binary search) CharInArray, if not - then use linear search as now. -function StrIsAlpha(const S: string): Boolean; -function StrIsAlphaNum(const S: string): Boolean; -function StrIsAlphaNumUnderscore(const S: string): Boolean; -function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; -function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; -function StrConsistsOfNumberChars(const S: string): Boolean; -function StrConsistsOfDigits(const S: string): Boolean; -function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; -function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; deprecated 'Use StrConsistsOfChars'; -function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; deprecated 'Use StrConsistsOfChars'; - -function StrIsDigit(const S: string): Boolean; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfDigits'; -// mixing two very separate goals is confusing and using CharValidator can not be implemented at all -function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; -function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; - - -// String Transformation Routines -function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; -function StrCharPosLower(const S: string; CharPos: SizeInt): string; -function StrCharPosUpper(const S: string; CharPos: SizeInt): string; -function StrDoubleQuote(const S: string): string; -function StrEnsureNoPrefix(const Prefix, Text: string): string; -function StrEnsureNoSuffix(const Suffix, Text: string): string; -function StrEnsurePrefix(const Prefix, Text: string): string; -function StrEnsureSuffix(const Suffix, Text: string): string; -function StrEscapedToString(const S: string): string; -function StrLower(const S: string): string; -procedure StrLowerInPlace(var S: string); -procedure StrLowerBuff(S: PChar); -procedure StrMove(var Dest: string; const Source: string; const ToIndex, - FromIndex, Count: SizeInt); -function StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string; -function StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string; -function StrProper(const S: string): string; -procedure StrProperBuff(S: PChar); -function StrQuote(const S: string; C: Char): string; -function StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveChars(const S: string; const Chars: array of Char): string; overload; -function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload; -function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload; -function StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload; -function StrKeepChars(const S: string; const Chars: TCharValidator): string; overload; -function StrKeepChars(const S: string; const Chars: array of Char): string; overload; -procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []); -function StrReplaceChar(const S: string; const Source, Replace: Char): string; -function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; -function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; -function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; -function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; -function StrRepeat(const S: string; Count: SizeInt): string; -function StrRepeatLength(const S: string; L: SizeInt): string; -function StrReverse(const S: string): string; -procedure StrReverseInPlace(var S: string); -function StrSingleQuote(const S: string): string; -procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; -procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; -function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; -function StrStringToEscaped(const S: string): string; -function StrStripNonNumberChars(const S: string): string; -function StrToHex(const Source: string): AnsiString; -function StrTrimCharLeft(const S: string; C: Char): string; -function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload; -function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; -function StrTrimCharRight(const S: string; C: Char): string; -function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload; -function StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload; -function StrTrimQuotes(const S: string): string; -function StrUpper(const S: string): string; -procedure StrUpperInPlace(var S: string); -procedure StrUpperBuff(S: PChar); - -// String Management -procedure StrAddRef(var S: string); -procedure StrDecRef(var S: string); -function StrLength(const S: string): SizeInt; -function StrRefCount(const S: string): SizeInt; - -// String Search and Replace Routines -function StrCharCount(const S: string; C: Char): SizeInt; overload; -function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload; -function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload; -function StrStrCount(const S, SubS: string): SizeInt; -function StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt; -function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt; -function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -procedure StrFillChar(var S; Count: SizeInt; C: Char); -function StrRepeatChar(C: Char; Count: SizeInt): string; -function StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt; -function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; -function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; -function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt; -function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; -function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; -function StrILastPos(const SubStr, S: string): SizeInt; -function StrIPos(const SubStr, S: string): SizeInt; -function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -function StrIsOneOf(const S: string; const List: array of string): Boolean; -function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -function StrLastPos(const SubStr, S: string): SizeInt; -function StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt; -function StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean; -function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; -function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; -function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -function StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt; -function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; - -// String Extraction -// Returns the String before SubStr -function StrAfter(const SubStr, S: string): string; -/// Returns the string after SubStr -function StrBefore(const SubStr, S: string): string; -/// Splits a string at SubStr, returns true when SubStr is found, Left contains the -/// string before the SubStr and Rigth the string behind SubStr -function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; -/// Returns the string between Start and Stop -function StrBetween(const S: string; const Start, Stop: Char): string; -/// Returns the left N characters of the string -function StrChopRight(const S: string; N: SizeInt): string; -/// Returns the left Count characters of the string -function StrLeft(const S: string; Count: SizeInt): string; -/// Returns the string starting from position Start for the Count Characters -function StrMid(const S: string; Start, Count: SizeInt): string; -/// Returns the string starting from position N to the end -function StrRestOf(const S: string; N: SizeInt): string; -/// Returns the right Count characters of the string -function StrRight(const S: string; Count: SizeInt): string; - -// Character Test Routines -function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} -function CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} -function CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharType(const C: Char): Word; - -// Character Transformation Routines -function CharHex(const C: Char): Byte; -function CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function CharToggleCase(const C: Char): Char; - -// Character Search and Replace -function CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; -function CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; -function CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt; -function CharReplace(var S: string; const Search, Replace: Char): SizeInt; - -// PCharVector -type - PCharVector = ^PChar; - -function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; -function PCharVectorCount(Source: PCharVector): SizeInt; -procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); -procedure FreePCharVector(var Dest: PCharVector); - -// MultiSz Routines -type - PMultiSz = PChar; - PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz; - PWideMultiSz = JclWideStrings.PWideMultiSz; - - TAnsiStrings = JclAnsiStrings.TJclAnsiStrings; - TWideStrings = JclWideStrings.TJclWideStrings; - TAnsiStringList = JclAnsiStrings.TJclAnsiStringList; - TWideStringList = JclWideStrings.TJclWideStringList; - -function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; -procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); -function MultiSzLength(const Source: PMultiSz): SizeInt; -procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); -procedure FreeMultiSz(var Dest: PMultiSz); -function MultiSzDup(const Source: PMultiSz): PMultiSz; - -function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; - {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} - -function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; - {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -procedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} -function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} - -// TStrings Manipulation -procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; overload; -function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: - Boolean = True): string; overload; -procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True); -procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True); -procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True); -function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; - -// Miscellaneous -// (OF) moved to JclSysUtils -// function BooleanToStr(B: Boolean): string; - // AnsiString here because it is binary data -function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; -procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; - Append: Boolean = False); - -function StrToken(var S: string; Separator: Char): string; -procedure StrTokens(const S: string; const List: TStrings); -procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); -function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload; -function StrWord(var S: PChar; out Word: string): Boolean; overload; -function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload; -function StrIdent(var S: PChar; out Ident: string): Boolean; overload; -function StrToFloatSafe(const S: string): Float; -function StrToIntSafe(const S: string): Integer; -procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; - -function ArrayOf(List: TStrings): TDynStringArray; overload; - -type - FormatException = class(EJclError); - ArgumentException = class(EJclError); - ArgumentNullException = class(EJclError); - ArgumentOutOfRangeException = class(EJclError); - -// IFomattable in .Net: http://msdn.microsoft.com/en-us/library/system.string.format.aspx - IToString = interface - ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] - function ToString: string; - end; - - TCharDynArray = array of Char; - - // The TStringBuilder class is a Delphi implementation of the .NET - // System.Text.StringBuilder. - // It is zero based and the method that allow an TObject (Append, Insert, - // AppendFormat) are limited to IToString implementors or newer Delphi RTL. - // This class is not threadsafe. Any instance of TStringBuilder should not - // be used in different threads at the same time. - TJclStringBuilder = class(TInterfacedObject, IToString) - private - FChars: TCharDynArray; - FLength: SizeInt; - FMaxCapacity: SizeInt; - - function GetCapacity: SizeInt; - procedure SetCapacity(const Value: SizeInt); - function GetChars(Index: SizeInt): Char; - procedure SetChars(Index: SizeInt; const Value: Char); - procedure Set_Length(const Value: SizeInt); - protected - function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; - function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; - public - constructor Create(const Value: string; Capacity: SizeInt = 16); overload; - constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload; - constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload; - - function Append(const Value: string): TJclStringBuilder; overload; - function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload; - function Append(Value: Boolean): TJclStringBuilder; overload; - function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload; - function Append(const Value: array of Char): TJclStringBuilder; overload; - function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; - function Append(Value: Cardinal): TJclStringBuilder; overload; - function Append(Value: Integer): TJclStringBuilder; overload; - function Append(Value: Double): TJclStringBuilder; overload; - function Append(Value: Int64): TJclStringBuilder; overload; - function Append(Obj: TObject): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload; - function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload; - - function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload; - function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload; - function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; - overload; - function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload; - function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload; - - function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; - overload; - function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; - overload; - - function Remove(StartIndex, Length: SizeInt): TJclStringBuilder; - function EnsureCapacity(Capacity: SizeInt): SizeInt; - - { IToString } - function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} - - property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default; - property Chars: TCharDynArray read FChars; - property Length: SizeInt read FLength write Set_Length; - property Capacity: SizeInt read GetCapacity write SetCapacity; - property MaxCapacity: SizeInt read FMaxCapacity; - end; - - {$IFDEF RTL200_UP} - TStringBuilder = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.TStringBuilder; - {$ELSE ~RTL200_UP} - TStringBuilder = TJclStringBuilder; - {$ENDIF ~RTL200_UP} - -// DotNetFormat() uses the .NET format style: "{argX}" -function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; -function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; -function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; -function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; - -// TJclTabSet -type - TJclTabSet = class (TInterfacedObject, IToString) - private - FData: TObject; - function GetCount: SizeInt; - function GetStops(Index: SizeInt): SizeInt; - function GetTabWidth: SizeInt; - function GetZeroBased: Boolean; - procedure SetStops(Index, Value: SizeInt); - procedure SetTabWidth(Value: SizeInt); - procedure SetZeroBased(Value: Boolean); - protected - function FindStop(Column: SizeInt): SizeInt; - function InternalTabStops: TDynSizeIntArray; - function InternalTabWidth: SizeInt; - procedure RemoveAt(Index: SizeInt); - public - constructor Create; overload; - constructor Create(Data: TObject); overload; - constructor Create(TabWidth: SizeInt); overload; - constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload; - constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload; - destructor Destroy; override; - - // cloning and referencing - function Clone: TJclTabSet; - function NewReference: TJclTabSet; - - // Tab stops manipulation - function Add(Column: SizeInt): SizeInt; - function Delete(Column: SizeInt): SizeInt; - - // Usage - function Expand(const S: string): string; overload; - function Expand(const S: string; Column: SizeInt): string; overload; - procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); - function Optimize(const S: string): string; overload; - function Optimize(const S: string; Column: SizeInt): string; overload; - function StartColumn: SizeInt; - function TabFrom(Column: SizeInt): SizeInt; - function UpdatePosition(const S: string): SizeInt; overload; - function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload; - function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload; - - { IToString } - function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} - // Conversions - function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload; - class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC} - - // Properties - property ActualTabWidth: SizeInt read InternalTabWidth; - property Count: SizeInt read GetCount; - property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default; - property TabWidth: SizeInt read GetTabWidth write SetTabWidth; - property ZeroBased: Boolean read GetZeroBased write SetZeroBased; - end; - -// Formatting constants -const - TabSetFormatting_SurroundStopsWithBrackets = 1; - TabSetFormatting_EmptyBracketsIfNoStops = 2; - TabSetFormatting_NoTabStops = 4; - TabSetFormatting_NoTabWidth = 8; - TabSetFormatting_AutoTabWidth = 16; - // common combinations - TabSetFormatting_Default = 0; - TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or - TabSetFormatting_EmptyBracketsIfNoStops; - TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth; - // aliases - TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth; - TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops; - TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default; - -// Tab expansion routines -function StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -// Tab optimization routines -function StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; -function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; - -// move to JclBase? -type - NullReferenceException = class(EJclError) - public - constructor Create; overload; - end; - -procedure StrResetLength(var S: WideString); overload; -procedure StrResetLength(var S: AnsiString); overload; -procedure StrResetLength(S: TJclStringBuilder); overload; -{$IFDEF SUPPORTS_UNICODE_STRING} -procedure StrResetLength(var S: UnicodeString); overload; -{$ENDIF SUPPORTS_UNICODE_STRING} - -// natural comparison functions -function CompareNaturalStr(const S1, S2: string): SizeInt; -function CompareNaturalText(const S1, S2: string): SizeInt; - -{$IFNDEF UNICODE_RTL_DATABASE} -// internal structures published to make function inlining working -const - MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set - StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars - StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars - StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars - StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table - -var - StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings - StrCaseMapReady: Boolean = False; // true if case map exists - StrCharTypes: array [Char] of Word; -{$ENDIF ~UNICODE_RTL_DATABASE} - -{$IFDEF UNITVERSIONING} -const - UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL$'; - Revision: '$Revision$'; - Date: '$Date$'; - LogPath: 'JCL\source\common'; - Extra: ''; - Data: nil - ); -{$ENDIF UNITVERSIONING} - -implementation - -uses - {$IFDEF HAS_UNIT_LIBC} - Libc, - {$ENDIF HAS_UNIT_LIBC} - {$IFDEF SUPPORTS_UNICODE} - {$IFDEF HAS_UNITSCOPE} - System.StrUtils, - {$ELSE ~HAS_UNITSCOPE} - StrUtils, - {$ENDIF ~HAS_UNITSCOPE} - {$ENDIF SUPPORTS_UNICODE} - JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils; - -//=== Internal =============================================================== - -type - TStrRec = packed record - RefCount: Longint; - Length: Longint; - end; - PStrRec = ^TStrRec; - -{$IFNDEF UNICODE_RTL_DATABASE} -procedure LoadCharTypes; -var - CurrChar: Char; - CurrType: Word; -begin - for CurrChar := Low(CurrChar) to High(CurrChar) do - begin - {$IFDEF MSWINDOWS} - CurrType := 0; - GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, CurrType); - {$DEFINE CHAR_TYPES_INITIALIZED} - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - CurrType := 0; - if isupper(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_UPPER; - if islower(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_LOWER; - if isdigit(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_DIGIT; - if isspace(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_SPACE; - if ispunct(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_PUNCT; - if iscntrl(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_CNTRL; - if isblank(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_BLANK; - if isxdigit(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_XDIGIT; - if isalpha(Byte(CurrChar)) <> 0 then - CurrType := CurrType or C1_ALPHA; - {$DEFINE CHAR_TYPES_INITIALIZED} - {$ENDIF LINUX} - StrCharTypes[CurrChar] := CurrType; - {$IFNDEF CHAR_TYPES_INITIALIZED} - Implement case map initialization here - {$ENDIF ~CHAR_TYPES_INITIALIZED} - end; -end; - -procedure LoadCaseMap; -var - CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char; -begin - if not StrCaseMapReady then - begin - for CurrChar := Low(Char) to High(Char) do - begin - {$IFDEF MSWINDOWS} - LoCaseChar := CurrChar; - UpCaseChar := CurrChar; - {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuff(@LoCaseChar, 1); - {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuff(@UpCaseChar, 1); - {$DEFINE CASE_MAP_INITIALIZED} - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - LoCaseChar := Char(tolower(Byte(CurrChar))); - UpCaseChar := Char(toupper(Byte(CurrChar))); - {$DEFINE CASE_MAP_INITIALIZED} - {$ENDIF LINUX} - {$IFNDEF CASE_MAP_INITIALIZED} - Implement case map initialization here - {$ENDIF ~CASE_MAP_INITIALIZED} - if CharIsUpper(CurrChar) then - ReCaseChar := LoCaseChar - else - if CharIsLower(CurrChar) then - ReCaseChar := UpCaseChar - else - ReCaseChar := CurrChar; - StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar; - StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar; - StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar; - end; - StrCaseMapReady := True; - end; -end; - -// Uppercases or Lowercases a give string depending on the -// passed offset. (UpOffset or LoOffset) - -procedure StrCase(var Str: string; const Offset: SizeInt); -var - P: PChar; - I, L: SizeInt; -begin - L := Length(Str); - if L > 0 then - begin - UniqueString(Str); - P := PChar(Str); - for I := 1 to L do - begin - P^ := StrCaseMap[Offset + Ord(P^)]; - Inc(P); - end; - end; -end; - -// Internal utility function -// Uppercases or Lowercases a give null terminated string depending on the -// passed offset. (UpOffset or LoOffset) - -procedure StrCaseBuff(S: PChar; const Offset: SizeInt); -var - C: Char; -begin - if S <> nil then - begin - repeat - C := S^; - S^ := StrCaseMap[Offset + Ord(C)]; - Inc(S); - until C = #0; - end; -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -function StrEndW(Str: PWideChar): PWideChar; -begin - Result := Str; - while Result^ <> #0 do - Inc(Result); -end; - -function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; -var - idx: SizeInt; -begin - Result := ArrayContainsChar(Chars, C, idx); -end; - -function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; -{ optimized version for sorted arrays -var - I, L, H: SizeInt; -begin - L := Low(Chars); - H := High(Chars); - while L <= H do - begin - I := (L + H) div 2; - if C = Chars[I] then - begin - Result := True; - Exit; - end - else - if C < Chars[I] then - H := I - 1 - else - // C > Chars[I] - L := I + 1; - end; - Result := False; -end;} -begin - Index := High(Chars); - while (Index >= Low(Chars)) and (Chars[Index] <> C) do - Dec(Index); - Result := Index >= Low(Chars); -end; - -// String Test Routines -function StrIsAlpha(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsAlpha(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrIsAlphaNum(const S: string): Boolean; -var - I: SizeInt; -begin - Result := S <> ''; - for I := 1 to Length(S) do - begin - if not CharIsAlphaNum(S[I]) then - begin - Result := False; - Exit; - end; - end; -end; - -function StrIsDigit(const S: string): Boolean; -begin - Result := StrConsistsOfDigits(S) -end; - -function StrConsistsOfDigits(const S: string): Boolean; -begin - Result := StrConsistsOfChars(S, CharIsDigit, False); -end; - -function StrConsistsOfNumberChars(const S: string): Boolean; -begin - Result := StrConsistsOfChars(S, CharIsNumberChar, False ); -end; - -function StrContainsEveryChar(const S: string; const Chars: string): Boolean; -var - I: SizeInt; -begin - Result := False; - for I := 1 to Length(Chars) do - if CharPos(S, Chars[I]) <= 0 then exit; - Result := True; -end; - -function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; -var - I: SizeInt; -begin - Result := False; - for I := Low(Chars) to High(Chars) do - if CharPos(S, Chars[I]) <= 0 then exit; - Result := True; -end; - -function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; -var - I: SizeInt; -begin - for I := 1 to Length(S) do - if Chars(S[I]) then - begin - Result := True; - Exit; - end; - Result := False; -end; - -function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; -var - I: SizeInt; -begin - for I := 1 to Length(S) do - if ArrayContainsChar(Chars, S[I]) then - begin - Result := True; - Exit; - end; - Result := False; -end; - -function StrContainsSomeChar(const S: string; const Chars: string): Boolean; -var - I: SizeInt; -begin - for I := 1 to Length(S) do - if CharPos(Chars, S[I]) > 0 then - begin - Result := True; - Exit; - end; - Result := False; -end; - -function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean): Boolean; -var - I: SizeInt; -begin - If S = '' then - Result := AllowEmpty - else begin - Result := False; - for I := 1 to Length(S) do - if not Chars(S[I]) then Exit; - Result := True; - end; -end; - -function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean): Boolean; -var - I: SizeInt; -begin - If S = '' then - Result := AllowEmpty - else begin - Result := False; - for I := 1 to Length(S) do - if not ArrayContainsChar(Chars, S[I]) then Exit; - Result := True; - end; -end; - -function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean): Boolean; -var - I: SizeInt; -begin - If S = '' then - Result := AllowEmpty - else begin - Result := False; - for I := 1 to Length(S) do - if CharPos(Chars, S[I]) <= 0 then Exit; - Result := True; - end; -end; - - -function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; -var - I: SizeInt; -begin - Result := False; - if CheckAll then - begin - // this will not work with the current definition of the validator. The validator would need to check each character - // it requires against the string (which is currently not provided to the Validator). The current implementation of - // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon- - // sistent with the documentation and the array-based overload. - for I := 1 to Length(S) do - begin - Result := Chars(S[I]); - if not Result then - Break; - end; - end - else - begin - for I := 1 to Length(S) do - begin - Result := Chars(S[I]); - if Result then - Break; - end; - end; -end; - -function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; -var - I: SizeInt; -begin - if CheckAll then - begin - Result := True; - I := High(Chars); - while (I >= 0) and Result do - begin - Result := CharPos(S, Chars[I]) > 0; - Dec(I); - end; - end - else - begin - Result := False; - for I := 1 to Length(S) do - begin - Result := ArrayContainsChar(Chars, S[I]); - if Result then - Break; - end; - end; -end; - -function StrIsAlphaNumUnderscore(const S: string): Boolean; -var - I: SizeInt; - C: Char; -begin - for I := 1 to Length(S) do - begin - C := S[I]; - - if not (CharIsAlphaNum(C) or (C = '_')) then - begin - Result := False; - Exit; - end; - end; - - Result := Length(S) > 0; -end; - -function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; -//var -// I: SizeInt; -begin - Result := StrConsistsOfChars(S, ValidChars, False); -// for I := 1 to Length(S) do -// begin -// Result := ValidChars(S[I]); -// if not Result then -// Exit; -// end; -// -// Result := Length(S) > 0; -end; - -function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; -//var -// I: SizeInt; -begin - Result := StrConsistsOfChars(S, ValidChars, False); -// for I := 1 to Length(S) do -// begin -// Result := ArrayContainsChar(ValidChars, S[I]); -// if not Result then -// Exit; -// end; -// -// Result := Length(S) > 0; -end; - -function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; -begin - Result := StrCompare(S1, S2, CaseSensitive) = 0; -end; - -//=== String Transformation Routines ========================================= - -function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; -begin - if Length(S) < L then - begin - Result := StringOfChar(C, (L - Length(S)) div 2) + S; - Result := Result + StringOfChar(C, L - Length(Result)); - end - else - Result := S; -end; - -function StrCharPosLower(const S: string; CharPos: SizeInt): string; -begin - Result := S; - if (CharPos > 0) and (CharPos <= Length(S)) then - Result[CharPos] := CharLower(Result[CharPos]); -end; - -function StrCharPosUpper(const S: string; CharPos: SizeInt): string; -begin - Result := S; - if (CharPos > 0) and (CharPos <= Length(S)) then - Result[CharPos] := CharUpper(Result[CharPos]); -end; - -function StrDoubleQuote(const S: string): string; -begin - Result := NativeDoubleQuote + S + NativeDoubleQuote; -end; - -function StrEnsureNoPrefix(const Prefix, Text: string): string; -var - PrefixLen: SizeInt; -begin - PrefixLen := Length(Prefix); - if Copy(Text, 1, PrefixLen) = Prefix then - Result := Copy(Text, PrefixLen + 1, Length(Text)) - else - Result := Text; -end; - -function StrEnsureNoSuffix(const Suffix, Text: string): string; -var - SuffixLen: SizeInt; - StrLength: SizeInt; -begin - SuffixLen := Length(Suffix); - StrLength := Length(Text); - if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then - Result := Copy(Text, 1, StrLength - SuffixLen) - else - Result := Text; -end; - -function StrEnsurePrefix(const Prefix, Text: string): string; -var - PrefixLen: SizeInt; -begin - PrefixLen := Length(Prefix); - if Copy(Text, 1, PrefixLen) = Prefix then - Result := Text - else - Result := Prefix + Text; -end; - -function StrEnsureSuffix(const Suffix, Text: string): string; -var - SuffixLen: SizeInt; -begin - SuffixLen := Length(Suffix); - if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then - Result := Text - else - Result := Text + Suffix; -end; - -function StrEscapedToString(const S: string): string; - procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); - const - HexDigits = string('0123456789abcdefABCDEF'); - var - StartI, Val, N: SizeInt; - begin - StartI := I; - N := Pos(S[I + 1], HexDigits) - 1; - if N < 0 then - // '\x' without hex digit following is not escape sequence - Dest := Dest + '\x' - else - begin - Inc(I); // Jump over x - if N >= 16 then - N := N - 6; - Val := N; - // Same for second digit - if I < Len then - begin - N := Pos(S[I + 1], HexDigits) - 1; - if N >= 0 then - begin - Inc(I); // Jump over first digit - if N >= 16 then - N := N - 6; - Val := Val * 16 + N; - end; - end; - - if Val > Ord(High(Char)) then - raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); - - Dest := Dest + Char(Val); - end; - end; - - procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); - const - OctDigits = string('01234567'); - var - StartI, Val, N: SizeInt; - begin - StartI := I; - // first digit - Val := Pos(S[I], OctDigits) - 1; - if I < Len then - begin - N := Pos(S[I + 1], OctDigits) - 1; - if N >= 0 then - begin - Inc(I); - Val := Val * 8 + N; - end; - if I < Len then - begin - N := Pos(S[I + 1], OctDigits) - 1; - if N >= 0 then - begin - Inc(I); - Val := Val * 8 + N; - end; - end; - end; - - if Val > Ord(High(Char)) then - raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); - - Dest := Dest + Char(Val); - end; - -var - I, Len: SizeInt; -begin - Result := ''; - I := 1; - Len := Length(S); - while I <= Len do - begin - if not ((S[I] = '\') and (I < Len)) then - Result := Result + S[I] - else - begin - Inc(I); // Jump over escape character - case S[I] of - 'a': - Result := Result + NativeBell; - 'b': - Result := Result + NativeBackspace; - 'f': - Result := Result + NativeFormFeed; - 'n': - Result := Result + NativeLineFeed; - 'r': - Result := Result + NativeCarriageReturn; - 't': - Result := Result + NativeTab; - 'v': - Result := Result + NativeVerticalTab; - '\': - Result := Result + '\'; - '"': - Result := Result + '"'; - '''': - Result := Result + ''''; // Optionally escaped - '?': - Result := Result + '?'; // Optionally escaped - 'x': - if I < Len then - // Start of hex escape sequence - HandleHexEscapeSeq(S, I, Len, Result) - else - // '\x' at end of string is not escape sequence - Result := Result + '\x'; - '0'..'7': - // start of octal escape sequence - HandleOctEscapeSeq(S, I, Len, Result); - else - // no escape sequence - Result := Result + '\' + S[I]; - end; - end; - Inc(I); - end; -end; - -function StrLower(const S: string): string; -begin - Result := S; - StrLowerInPlace(Result); -end; - -procedure StrLowerInPlace(var S: string); -{$IFDEF UNICODE_RTL_DATABASE} -var - P: PChar; - I, L: SizeInt; -begin - L := Length(S); - if L > 0 then - begin - UniqueString(S); - P := PChar(S); - for I := 1 to L do - begin - P^ := TCharacter.ToLower(P^); - Inc(P); - end; - end; -end; -{$ELSE ~UNICODE_RTL_DATABASE} -begin - StrCase(S, StrLoOffset); -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -procedure StrLowerBuff(S: PChar); -begin - {$IFDEF UNICODE_RTL_DATABASE} - if S <> nil then - begin - repeat - S^ := TCharacter.ToLower(S^); - Inc(S); - until S^ = #0; - end; - {$ELSE ~UNICODE_RTL_DATABASE} - StrCaseBuff(S, StrLoOffset); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -procedure StrMove(var Dest: string; const Source: string; - const ToIndex, FromIndex, Count: SizeInt); -begin - // Check strings - if (Source = '') or (Length(Dest) = 0) then - Exit; - - // Check FromIndex - if (FromIndex <= 0) or (FromIndex > Length(Source)) or - (ToIndex <= 0) or (ToIndex > Length(Dest)) or - ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then - { TODO : Is failure without notice the proper thing to do here? } - Exit; - - // Move - Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char)); -end; - -function StrPadLeft(const S: string; Len: SizeInt; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - if L < Len then - Result := StringOfChar(C, Len - L) + S - else - Result := S; -end; - -function StrPadRight(const S: string; Len: SizeInt; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - if L < Len then - Result := S + StringOfChar(C, Len - L) - else - Result := S; -end; - -function StrProper(const S: string): string; -begin - Result := StrLower(S); - if Result <> '' then - Result[1] := UpCase(Result[1]); -end; - -procedure StrProperBuff(S: PChar); -begin - if (S <> nil) and (S^ <> #0) then - begin - StrLowerBuff(S); - S^ := CharUpper(S^); - end; -end; - -function StrQuote(const S: string; C: Char): string; -var - L: SizeInt; -begin - L := Length(S); - Result := S; - if L > 0 then - begin - if Result[1] <> C then - begin - Result := C + Result; - Inc(L); - end; - if Result[L] <> C then - Result := Result + C; - end; -end; - -function StrRemoveChars(const S: string; const Chars: TCharValidator): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if not Chars(Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRemoveChars(const S: string; const Chars: array of Char): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if not ArrayContainsChar(Chars, Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; -var - Len : SizeInt; - I: SizeInt; -begin - Len := Length(S); - I := 1; - while (I <= Len) and Chars(s[I]) do - Inc(I); - Result := Copy (s, I, Len-I+1); -end; - -function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; -var - Len : SizeInt; - I: SizeInt; -begin - Len := Length(S); - I := 1; - while (I <= Len) and ArrayContainsChar(Chars, s[I]) do - Inc(I); - Result := Copy (s, I, Len-I+1); -end; - -function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; -var - Len : SizeInt; -begin - Len := Length(S); - while (Len > 0) and Chars(s[Len]) do - Dec(Len); - Result := Copy (s, 1, Len); -end; - -function StrRemoveEndChars(const S: string; const Chars: array of Char): string; -var - Len : SizeInt; -begin - Len := Length(S); - while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do - Dec(Len); - Result := Copy (s, 1, Len); -end; - -function StrKeepChars(const S: string; const Chars: TCharValidator): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if Chars(Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrKeepChars(const S: string; const Chars: array of Char): string; -var - Source, Dest: PChar; - Len, Index: SizeInt; -begin - Len := Length(S); - SetLength(Result, Len); - UniqueString(Result); - Source := PChar(S); - Dest := PChar(Result); - for Index := 0 to Len - 1 do - begin - if ArrayContainsChar(Chars, Source^) then - begin - Dest^ := Source^; - Inc(Dest); - end; - Inc(Source); - end; - SetLength(Result, Dest - PChar(Result)); -end; - -function StrRepeat(const S: string; Count: SizeInt): string; -var - Len, Index: SizeInt; - Dest, Source: PChar; -begin - Len := Length(S); - SetLength(Result, Count * Len); - Dest := PChar(Result); - Source := PChar(S); - if Dest <> nil then - for Index := 0 to Count - 1 do - begin - Move(Source^, Dest^, Len * SizeOf(Char)); - Inc(Dest, Len); - end; -end; - -function StrRepeatLength(const S: string; L: SizeInt): string; -var - Len: SizeInt; - Dest: PChar; -begin - Result := ''; - Len := Length(S); - - if (Len > 0) and (S <> '') then - begin - SetLength(Result, L); - Dest := PChar(Result); - while (L > 0) do - begin - Move(S[1], Dest^, Min(L, Len) * SizeOf(Char)); - Inc(Dest, Len); - Dec(L, Len); - end; - end; -end; - -procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags); -var - SearchStr: string; - ResultStr: string; { result string } - SourcePtr: PChar; { pointer into S of character under examination } - SourceMatchPtr: PChar; { pointers into S and Search when first character has } - SearchMatchPtr: PChar; { been matched and we're probing for a complete match } - ResultPtr: PChar; { pointer into Result of character being written } - ResultIndex, - SearchLength, { length of search string } - ReplaceLength, { length of replace string } - BufferLength, { length of temporary result buffer } - ResultLength: SizeInt; { length of result string } - C: Char; { first character of search string } - IgnoreCase: Boolean; -begin - if Search = '' then - begin - if S = '' then - begin - S := Replace; - Exit; - end - else - raise EJclStringError.CreateRes(@RsBlankSearchString); - end; - - if S <> '' then - begin - IgnoreCase := rfIgnoreCase in Flags; - if IgnoreCase then - SearchStr := StrUpper(Search) - else - SearchStr := Search; - { avoid having to call Length() within the loop } - SearchLength := Length(Search); - ReplaceLength := Length(Replace); - ResultLength := Length(S); - BufferLength := ResultLength; - SetLength(ResultStr, BufferLength); - { get pointers to begin of source and result } - ResultPtr := PChar(ResultStr); - SourcePtr := PChar(S); - C := SearchStr[1]; - { while we haven't reached the end of the string } - while True do - begin - { copy characters until we find the first character of the search string } - if IgnoreCase then - while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end - else - while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - { did we find that first character or did we hit the end of the string? } - if SourcePtr^ = #0 then - Break - else - begin - { continue comparing, +1 because first character was matched already } - SourceMatchPtr := SourcePtr + 1; - SearchMatchPtr := PChar(SearchStr) + 1; - if IgnoreCase then - while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do - begin - Inc(SourceMatchPtr); - Inc(SearchMatchPtr); - end - else - while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do - begin - Inc(SourceMatchPtr); - Inc(SearchMatchPtr); - end; - { did we find a complete match? } - if SearchMatchPtr^ = #0 then - begin - // keep track of result length - Inc(ResultLength, ReplaceLength - SearchLength); - if ReplaceLength > 0 then - begin - // increase buffer size if required - if ResultLength > BufferLength then - begin - BufferLength := ResultLength * 2; - ResultIndex := ResultPtr - PChar(ResultStr) + 1; - SetLength(ResultStr, BufferLength); - ResultPtr := @ResultStr[ResultIndex]; - end; - { append replace to result and move past the search string in source } - Move((@Replace[1])^, ResultPtr^, ReplaceLength * SizeOf(Char)); - end; - Inc(SourcePtr, SearchLength); - Inc(ResultPtr, ReplaceLength); - { replace all instances or just one? } - if not (rfReplaceAll in Flags) then - begin - { just one, copy until end of source and break out of loop } - while SourcePtr^ <> #0 do - begin - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - Break; - end; - end - else - begin - { copy current character and start over with the next } - ResultPtr^ := SourcePtr^; - Inc(ResultPtr); - Inc(SourcePtr); - end; - end; - end; - { set result length and copy result into S } - SetLength(ResultStr, ResultLength); - S := ResultStr; - end; -end; - -function StrReplaceChar(const S: string; const Source, Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if Result[I] = Source then - Result[I] := Replace; -end; - -function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if Chars(Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if ArrayContainsChar(Chars, Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceButChars(const S: string; const Chars: TCharValidator; - Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if not Chars(Result[I]) then - Result[I] := Replace; -end; - -function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; -var - I: SizeInt; -begin - Result := S; - for I := 1 to Length(S) do - if not ArrayContainsChar(Chars, Result[I]) then - Result[I] := Replace; -end; - -function StrReverse(const S: string): string; -begin - Result := S; - StrReverseInplace(Result); -end; - -procedure StrReverseInPlace(var S: string); -{ TODO -oahuser : Warning: This is dangerous for unicode surrogates } -var - P1, P2: PChar; - C: Char; -begin - UniqueString(S); - P1 := PChar(S); - P2 := P1 + (Length(S) - 1); - while P1 < P2 do - begin - C := P1^; - P1^ := P2^; - P2^ := C; - Inc(P1); - Dec(P2); - end; -end; - -function StrSingleQuote(const S: string): string; -begin - Result := NativeSingleQuote + S + NativeSingleQuote; -end; - -procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); -begin - while Chars(S^) do - Inc(S); -end; - -procedure StrSkipChars(var S: PChar; const Chars: array of Char); -begin - while ArrayContainsChar(Chars, S^) do - Inc(S); -end; - -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); -begin - while Chars(S[Index]) do - Inc(Index); -end; - -procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); -begin - while ArrayContainsChar(Chars, S[Index]) do - Inc(Index); -end; - -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; -var - Source, Dest: PChar; - Index, Len: SizeInt; - InternalDelimiters: TCharValidator; -begin - Result := ''; - if Assigned(Delimiters) then - InternalDelimiters := Delimiters - else - InternalDelimiters := CharIsSpace; - - if S <> '' then - begin - Result := S; - UniqueString(Result); - - Len := Length(S); - Source := PChar(S); - Dest := PChar(Result); - Inc(Dest); - - for Index := 2 to Len do - begin - if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then - Dest^ := CharUpper(Dest^); - Inc(Dest); - Inc(Source); - end; - Result[1] := CharUpper(Result[1]); - end; -end; - -function StrSmartCase(const S: string; const Delimiters: array of Char): string; -var - Source, Dest: PChar; - Index, Len: SizeInt; -begin - Result := ''; - - if S <> '' then - begin - Result := S; - UniqueString(Result); - - Len := Length(S); - Source := PChar(S); - Dest := PChar(Result); - Inc(Dest); - - for Index := 2 to Len do - begin - if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then - Dest^ := CharUpper(Dest^); - Inc(Dest); - Inc(Source); - end; - Result[1] := CharUpper(Result[1]); - end; -end; - -function StrStringToEscaped(const S: string): string; -var - I: SizeInt; -begin - Result := ''; - for I := 1 to Length(S) do - begin - case S[I] of - NativeBackspace: - Result := Result + '\b'; - NativeBell: - Result := Result + '\a'; - NativeCarriageReturn: - Result := Result + '\r'; - NAtiveFormFeed: - Result := Result + '\f'; - NativeLineFeed: - Result := Result + '\n'; - NativeTab: - Result := Result + '\t'; - NativeVerticalTab: - Result := Result + '\v'; - NativeBackSlash: - Result := Result + '\\'; - NativeDoubleQuote: - Result := Result + '\"'; - else - // Characters < ' ' are escaped with hex sequence - if S[I] < #32 then - Result := Result + Format('\x%.2x', [SizeInt(S[I])]) - else - Result := Result + S[I]; - end; - end; -end; - -function StrStripNonNumberChars(const S: string): string; -var - I: SizeInt; - C: Char; -begin - Result := ''; - for I := 1 to Length(S) do - begin - C := S[I]; - if CharIsNumberChar(C) then - Result := Result + C; - end; -end; - -function StrToHex(const Source: string): AnsiString; -var - Index: SizeInt; - C, L, N: SizeInt; - BL, BH: Byte; - S: string; -begin - Result := ''; - if Source <> '' then - begin - S := Source; - L := Length(S); - if Odd(L) then - begin - S := '0' + S; - Inc(L); - end; - Index := 1; - SetLength(Result, L div 2); - C := 1; - N := 1; - while C <= L do - begin - BH := CharHex(S[Index]); - Inc(Index); - BL := CharHex(S[Index]); - Inc(Index); - Inc(C, 2); - if (BH = $FF) or (BL = $FF) then - begin - Result := ''; - Exit; - end; - Result[N] := AnsiChar((BH shl 4) or BL); - Inc(N); - end; - end; -end; - -function StrTrimCharLeft(const S: string; C: Char): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and (S[I] = C) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and Chars(S[I]) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; -var - I, L: SizeInt; -begin - I := 1; - L := Length(S); - while (I <= L) and ArrayContainsChar(Chars, S[I]) do - Inc(I); - Result := Copy(S, I, L - I + 1); -end; - -function StrTrimCharRight(const S: string; C: Char): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and (S[I] = C) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and Chars(S[I]) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimCharsRight(const S: string; const Chars: array of Char): string; -var - I: SizeInt; -begin - I := Length(S); - while (I >= 1) and ArrayContainsChar(Chars, S[I]) do - Dec(I); - Result := Copy(S, 1, I); -end; - -function StrTrimQuotes(const S: string): string; -var - First, Last: Char; - L: SizeInt; -begin - L := Length(S); - if L > 1 then - begin - First := S[1]; - Last := S[L]; - if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) then - Result := Copy(S, 2, L - 2) - else - Result := S; - end - else - Result := S; -end; - -function StrUpper(const S: string): string; -begin - Result := S; - StrUpperInPlace(Result); -end; - -procedure StrUpperInPlace(var S: string); -{$IFDEF UNICODE_RTL_DATABASE} -var - P: PChar; - I, L: SizeInt; -begin - L := Length(S); - if L > 0 then - begin - UniqueString(S); - P := PChar(S); - for I := 1 to L do - begin - P^ := TCharacter.ToUpper(P^); - Inc(P); - end; - end; -end; -{$ELSE ~UNICODE_RTL_DATABASE} -begin - StrCase(S, StrUpOffset); -end; -{$ENDIF ~UNICODE_RTL_DATABASE} - -procedure StrUpperBuff(S: PChar); -begin - {$IFDEF UNICODE_RTL_DATABASE} - if S <> nil then - begin - repeat - S^ := TCharacter.ToUpper(S^); - Inc(S); - until S^ = #0; - end; - {$ELSE ~UNICODE_RTL_DATABASE} - StrCaseBuff(S, StrUpOffset); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== String Management ====================================================== - -procedure StrAddRef(var S: string); -var - P: PStrRec; -begin - P := Pointer(S); - if P <> nil then - begin - Dec(P); - if P^.RefCount = -1 then - UniqueString(S) - else - LockedInc(P^.RefCount); - end; -end; - -procedure StrDecRef(var S: string); -var - P: PStrRec; -begin - P := Pointer(S); - if P <> nil then - begin - Dec(P); - case P^.RefCount of - -1, 0: { nothing } ; - 1: - begin - Finalize(S); - Pointer(S) := nil; - end; - else - LockedDec(P^.RefCount); - end; - end; -end; - -function StrLength(const S: string): SizeInt; -var - P: PStrRec; -begin - Result := 0; - P := Pointer(S); - if P <> nil then - begin - Dec(P); - Result := P^.Length and (not $80000000 shr 1); - end; -end; - -function StrRefCount(const S: string): SizeInt; -var - P: PStrRec; -begin - Result := 0; - P := Pointer(S); - if P <> nil then - begin - Dec(P); - Result := P^.RefCount; - end; -end; - -procedure StrResetLength(var S: WideString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; - -procedure StrResetLength(var S: AnsiString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; - -procedure StrResetLength(S: TJclStringBuilder); -var - I: SizeInt; -begin - if S <> nil then - for I := 0 to S.Length - 1 do - if S[I] = #0 then - begin - S.Length := I; - Exit; - end; -end; - -{$IFDEF SUPPORTS_UNICODE_STRING} -procedure StrResetLength(var S: UnicodeString); -var - I: SizeInt; -begin - for I := 0 to Length(S) - 1 do - if S[I + 1] = #0 then - begin - SetLength(S, I); - Exit; - end; -end; -{$ENDIF SUPPORTS_UNICODE_STRING} - -//=== String Search and Replace Routines ===================================== - -function StrCharCount(const S: string; C: Char): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if S[I] = C then - Inc(Result); -end; - -function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if Chars(S[I]) then - Inc(Result); -end; - -function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; -var - I: SizeInt; -begin - Result := 0; - for I := 1 to Length(S) do - if ArrayContainsChar(Chars, S[I]) then - Inc(Result); -end; - -function StrStrCount(const S, SubS: string): SizeInt; -var - I: SizeInt; -begin - Result := 0; - if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then - Exit; - if Length(SubS) = 1 then - begin - Result := StrCharCount(S, SubS[1]); - Exit; - end; - I := StrSearch(SubS, S, 1); - - if I > 0 then - Inc(Result); - - while (I > 0) and (Length(S) > I + Length(SubS)) do - begin - I := StrSearch(SubS, S, I + 1); - - if I > 0 then - Inc(Result); - end; -end; - -(* -{ 1} Test(StrCompareRange('', '', 1, 5), 0); -{ 2} Test(StrCompareRange('A', '', 1, 5), -1); -{ 3} Test(StrCompareRange('AB', '', 1, 5), -1); -{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1); -{ 5} Test(StrCompareRange('', 'A', 1, 5), -1); -{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1); -{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1); -{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2); -{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32); -{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0); -{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1); -{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1); -{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32); -{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32); -{15} Test(StrCompareRange('', '', 1, 0), 0); -{16} Test(StrCompareRange('A', 'A', 1, 0), -2); -{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2); -{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0); -{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0); -{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1); -*) -function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -var - Len1, Len2: SizeInt; - I: SizeInt; - C1, C2: Char; -begin - if Pointer(S1) = Pointer(S2) then - begin - if (Count <= 0) and (S1 <> '') then - Result := -2 // no work - else - Result := 0; - end - else - if (S1 = '') or (S2 = '') then - Result := -1 // null string - else - if Count <= 0 then - Result := -2 // no work - else - begin - Len1 := Length(S1); - Len2 := Length(S2); - - if (Index - 1) + Count > Len1 then - Result := -2 - else - begin - if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it - Count := Len2 - (Index - 1); - - if CaseSensitive then - begin - for I := 0 to Count - 1 do - begin - C1 := S1[Index + I]; - C2 := S2[Index + I]; - if C1 <> C2 then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - end; - end - else - begin - for I := 0 to Count - 1 do - begin - C1 := S1[Index + I]; - C2 := S2[Index + I]; - if C1 <> C2 then - begin - C1 := CharLower(C1); - C2 := CharLower(C2); - if C1 <> C2 then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - end; - end; - end; - Result := 0; - end; - end; -end; - -function StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt; -var - Len1, Len2: SizeInt; -begin - if Pointer(S1) = Pointer(S2) then - Result := 0 - else - begin - Len1 := Length(S1); - Len2 := Length(S2); - Result := Len1 - Len2; - if Result = 0 then - Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive); - end; -end; - -function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; -begin - Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive); -end; - -procedure StrFillChar(var S; Count: SizeInt; C: Char); -{$IFDEF SUPPORTS_UNICODE} -asm - // 32 --> EAX S - // EDX Count - // ECX C - // 64 --> RCX S - // RDX Count - // R8W C - {$IFDEF CPU32} - DEC EDX - JS @@Leave -@@Loop: - MOV [EAX], CX - ADD EAX, 2 - DEC EDX - JNS @@Loop - {$ENDIF CPU32} - {$IFDEF CPU64} - DEC RDX - JS @@Leave -@@Loop: - MOV WORD PTR [RCX], R8W - ADD RCX, 2 - DEC RDX - JNS @@Loop - {$ENDIF CPU64} -@@Leave: -end; -{$ELSE ~SUPPORTS_UNICODE} -begin - if Count > 0 then - FillChar(S, Count, C); -end; -{$ENDIF ~SUPPORTS_UNICODE} - -function StrRepeatChar(C: Char; Count: SizeInt): string; -begin - SetLength(Result, Count); - if Count > 0 then - StrFillChar(Result[1], Count, C); -end; - -function StrFind(const Substr, S: string; const Index: SizeInt): SizeInt; -var - pos: SizeInt; -begin - if (SubStr <> '') and (S <> '') then - begin - pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1)); - if pos = 0 then - Result := 0 - else - Result := Index + Pos - 1; - end - else - Result := 0; -end; - -function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; -begin - Result := StrPrefixIndex(S, Prefixes) > -1; -end; - -function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; -begin - Result := StrSuffixIndex(S, Suffixes) > -1; -end; - -function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean): SizeInt; -var - I: SizeInt; -begin - Result := -1; - for I := Low(List) to High(List) do - begin - if StrCompare(S, List[I], CaseSensitive) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; -begin - Result := StrIPrefixIndex(S, Prefixes) > -1; -end; - -function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; -begin - Result := StrISuffixIndex(S, Suffixes) > -1; -end; - -function StrILastPos(const SubStr, S: string): SizeInt; -begin - Result := StrLastPos(StrUpper(SubStr), StrUpper(S)); -end; - -function StrIPos(const SubStr, S: string): SizeInt; -begin - Result := Pos(StrUpper(SubStr), StrUpper(S)); -end; - -function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Prefixes) to High(Prefixes) do - begin - Test := StrLeft(S, Length(Prefixes[I])); - if CompareText(Test, Prefixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrIsOneOf(const S: string; const List: array of string): Boolean; -begin - Result := StrIndex(S, List) > -1; -end; - -function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Suffixes) to High(Suffixes) do - begin - Test := StrRight(S, Length(Suffixes[I])); - if CompareText(Test, Suffixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrLastPos(const SubStr, S: string): SizeInt; -var - Last, Current: PChar; -begin - Result := 0; - Last := nil; - Current := PChar(S); - - while (Current <> nil) and (Current^ <> #0) do - begin - Current := StrPos(PChar(Current), PChar(SubStr)); - if Current <> nil then - begin - Last := Current; - Inc(Current); - end; - end; - if Last <> nil then - Result := Abs(PChar(S) - Last) + 1; -end; - -// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*) -// (*) acts like (?) - -function StrMatch(const Substr, S: string; Index: SizeInt): SizeInt; -var - SI, SubI, SLen, SubLen: SizeInt; - SubC: Char; -begin - SLen := Length(S); - SubLen := Length(Substr); - Result := 0; - if (Index > SLen) or (SubLen = 0) then - Exit; - while Index <= SLen do - begin - SubI := 1; - SI := Index; - while (SI <= SLen) and (SubI <= SubLen) do - begin - SubC := Substr[SubI]; - if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then - begin - Inc(SI); - Inc(SubI); - end - else - Break; - end; - if SubI > SubLen then - begin - Result := Index; - Break; - end; - Inc(Index); - end; -end; - -// Derived from "Like" by Michael Winter -function StrMatches(const Substr, S: string; const Index: SizeInt): Boolean; -var - StringPtr: PChar; - PatternPtr: PChar; - StringRes: PChar; - PatternRes: PChar; -begin - if SubStr = '' then - raise EJclStringError.CreateRes(@RsBlankSearchString); - - Result := SubStr = '*'; - - if Result or (S = '') then - Exit; - - if (Index <= 0) or (Index > Length(S)) then - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - - StringPtr := PChar(@S[Index]); - PatternPtr := PChar(SubStr); - StringRes := nil; - PatternRes := nil; - - repeat - repeat - case PatternPtr^ of - #0: - begin - Result := StringPtr^ = #0; - if Result or (StringRes = nil) or (PatternRes = nil) then - Exit; - - StringPtr := StringRes; - PatternPtr := PatternRes; - Break; - end; - '*': - begin - Inc(PatternPtr); - PatternRes := PatternPtr; - Break; - end; - '?': - begin - if StringPtr^ = #0 then - Exit; - Inc(StringPtr); - Inc(PatternPtr); - end; - else - begin - if StringPtr^ = #0 then - Exit; - if StringPtr^ <> PatternPtr^ then - begin - if (StringRes = nil) or (PatternRes = nil) then - Exit; - StringPtr := StringRes; - PatternPtr := PatternRes; - Break; - end - else - begin - Inc(StringPtr); - Inc(PatternPtr); - end; - end; - end; - until False; - - repeat - case PatternPtr^ of - #0: - begin - Result := True; - Exit; - end; - '*': - begin - Inc(PatternPtr); - PatternRes := PatternPtr; - end; - '?': - begin - if StringPtr^ = #0 then - Exit; - Inc(StringPtr); - Inc(PatternPtr); - end; - else - begin - repeat - if StringPtr^ = #0 then - Exit; - if StringPtr^ = PatternPtr^ then - Break; - Inc(StringPtr); - until False; - Inc(StringPtr); - StringRes := StringPtr; - Inc(PatternPtr); - Break; - end; - end; - until False; - until False; -end; - -function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; -var - I, P: SizeInt; -begin - if N < 1 then - begin - Result := 0; - Exit; - end; - - Result := StrSearch(SubStr, S, 1); - I := 1; - while I < N do - begin - P := StrSearch(SubStr, S, Result + 1); - if P = 0 then - begin - Result := 0; - Break; - end - else - begin - Result := P; - Inc(I); - end; - end; -end; - -function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; -var - I, P: SizeInt; -begin - if N < 1 then - begin - Result := 0; - Exit; - end; - - Result := StrFind(SubStr, S, 1); - I := 1; - while I < N do - begin - P := StrFind(SubStr, S, Result + 1); - if P = 0 then - begin - Result := 0; - Break; - end - else - begin - Result := P; - Inc(I); - end; - end; -end; - -function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Prefixes) to High(Prefixes) do - begin - Test := StrLeft(S, Length(Prefixes[I])); - if CompareStr(Test, Prefixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -function StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt; -var - SP, SPI, SubP: PChar; - SLen: SizeInt; -begin - SLen := Length(S); - if Index <= SLen then - begin - SP := PChar(S); - SubP := PChar(Substr); - SPI := SP; - Inc(SPI, Index); - Dec(SPI); - SPI := StrPos(SPI, SubP); - if SPI <> nil then - Result := SPI - SP + 1 - else - Result := 0; - end - else - Result := 0; -end; - -function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; -var - I: SizeInt; - Test: string; -begin - Result := -1; - for I := Low(Suffixes) to High(Suffixes) do - begin - Test := StrRight(S, Length(Suffixes[I])); - if CompareStr(Test, Suffixes[I]) = 0 then - begin - Result := I; - Break; - end; - end; -end; - -//=== String Extraction ====================================================== - -function StrAfter(const SubStr, S: string): string; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos - if P <= 0 then - Result := '' // substr not found -> nothing after it - else - Result := StrRestOf(S, P + Length(SubStr)); -end; - -function StrBefore(const SubStr, S: string): string; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); - if P <= 0 then - Result := S - else - Result := StrLeft(S, P - 1); -end; - -function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; -var - P: SizeInt; -begin - P := StrFind(SubStr, S, 1); - Result:= p > 0; - if Result then - begin - Left := StrLeft(S, P - 1); - Right := StrRestOf(S, P + Length(SubStr)); - end - else - begin - Left := ''; - Right := ''; - end; -end; - -function StrBetween(const S: string; const Start, Stop: Char): string; -var - PosStart, PosEnd: SizeInt; - L: SizeInt; -begin - PosStart := Pos(Start, S); - PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart. - - if (PosStart > 0) and (PosEnd > PosStart) then - begin - L := PosEnd - PosStart; - Result := Copy(S, PosStart + 1, L - 1); - end - else - Result := ''; -end; - -function StrChopRight(const S: string; N: SizeInt): string; -begin - Result := Copy(S, 1, Length(S) - N); -end; - -function StrLeft(const S: string; Count: SizeInt): string; -begin - Result := Copy(S, 1, Count); -end; - -function StrMid(const S: string; Start, Count: SizeInt): string; -begin - Result := Copy(S, Start, Count); -end; - -function StrRestOf(const S: string; N: SizeInt): string; -begin - Result := Copy(S, N, (Length(S) - N + 1)); -end; - -function StrRight(const S: string; Count: SizeInt): string; -begin - Result := Copy(S, Length(S) - Count + 1, Count); -end; - -//=== Character (do we have it ;) ============================================ - -function CharEqualNoCase(const C1, C2: Char): Boolean; -begin - //if they are not equal chars, may be same letter different case - Result := (C1 = C2) or - (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2))); -end; - - -function CharIsAlpha(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLetter(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_ALPHA) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsAlphaNum(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLetterOrDigit(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsBlank(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx - Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_BLANK) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsControl(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsControl(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_CNTRL) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsDelete(const C: Char): Boolean; -begin - Result := (C = #8); -end; - -function CharIsDigit(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsDigit(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_DIGIT) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsFracDigit(const C: Char): Boolean; -begin - Result := (C = '.') or CharIsDigit(C); -end; - -function CharIsHexDigit(const C: Char): Boolean; -begin - case C of - 'A'..'F', - 'a'..'f': - Result := True; - else - Result := CharIsDigit(C); - end; -end; - -function CharIsLower(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsLower(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_LOWER) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsNumberChar(const C: Char): Boolean; -begin - Result := CharIsDigit(C) or (C = '+') or (C = '-') - or ((C <> #0) and (C = JclFormatSettings.DecimalSeparator)) - or ((C <> #0) and (C = JclFormatSettings.ThousandSeparator)); - // #0 is a special value to 'disable' xxxxSeparator, semantically similar to empty string -end; - -function CharIsNumber(const C: Char): Boolean; -begin - Result := CharIsDigit(C) or (C = JclFormatSettings.DecimalSeparator); -end; - -function CharIsPrintable(const C: Char): Boolean; -begin - Result := not CharIsControl(C); -end; - -function CharIsPunctuation(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsPunctuation(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := ((StrCharTypes[C] and C1_PUNCT) <> 0); - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsReturn(const C: Char): Boolean; -begin - Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); -end; - -function CharIsSpace(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsWhiteSpace(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_SPACE) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsUpper(const C: Char): Boolean; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.IsUpper(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := (StrCharTypes[C] and C1_UPPER) <> 0; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharIsValidIdentifierLetter(const C: Char): Boolean; -begin - case C of - {$IFDEF SUPPORTS_UNICODE} - // from XML specifications - #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D, - #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF, - #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs? - #$00B7, #$0300..#$036F, #$203F..#$2040, - {$ENDIF SUPPORTS_UNICODE} - '0'..'9', 'A'..'Z', 'a'..'z', '_': - Result := True; - else - Result := False; - end; -end; - -function CharIsWhiteSpace(const C: Char): Boolean; -begin - case C of - NativeTab, - NativeLineFeed, - NativeVerticalTab, - NativeFormFeed, - NativeCarriageReturn, - NativeSpace: - Result := True; - else - Result := False; - end; -end; - -function CharIsWildcard(const C: Char): Boolean; -begin - case C of - '*', '?': - Result := True; - else - Result := False; - end; -end; - -function CharType(const C: Char): Word; -begin - {$IFDEF UNICODE_RTL_DATABASE} - GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCharTypes[C]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== PCharVector ============================================================ - -function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; -var - I: SizeInt; - S: string; - List: array of PChar; -begin - Assert(Source <> nil); - Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar)); - SetLength(List, Source.Count + SizeOf(Char)); - for I := 0 to Source.Count - 1 do - begin - S := Source[I]; - List[I] := StrAlloc(Length(S) + SizeOf(Char)); - StrPCopy(List[I], S); - end; - List[Source.Count] := nil; - Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar)); - Result := Dest; -end; - -function PCharVectorCount(Source: PCharVector): SizeInt; -begin - Result := 0; - if Source <> nil then - begin - while Source^ <> nil do - begin - Inc(Source); - Inc(Result); - end; - end; -end; - -procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); -var - I, Count: SizeInt; - List: array of PChar; -begin - Assert(Dest <> nil); - if Source <> nil then - begin - Count := PCharVectorCount(Source); - SetLength(List, Count); - Move(Source^, List[0], Count * SizeOf(PChar)); - Dest.BeginUpdate; - try - Dest.Clear; - for I := 0 to Count - 1 do - Dest.Add(List[I]); - finally - Dest.EndUpdate; - end; - end; -end; - -procedure FreePCharVector(var Dest: PCharVector); -var - I, Count: SizeInt; - List: array of PChar; -begin - if Dest <> nil then - begin - Count := PCharVectorCount(Dest); - SetLength(List, Count); - Move(Dest^, List[0], Count * SizeOf(PChar)); - for I := 0 to Count - 1 do - StrDispose(List[I]); - FreeMem(Dest, (Count + 1) * SizeOf(PChar)); - Dest := nil; - end; -end; - -//=== Character Transformation Routines ====================================== - -function CharHex(const C: Char): Byte; -begin - case C of - '0'..'9': - Result := Ord(C) - Ord('0'); - 'a'..'f': - Result := Ord(C) - Ord('a') + 10; - 'A'..'F': - Result := Ord(C) - Ord('A') + 10; - else - Result := $FF; - end; -end; - -function CharLower(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.ToLower(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrLoOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharToggleCase(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - if CharIsLower(C) then - Result := CharUpper(C) - else if CharIsUpper(C) then - Result := CharLower(C) - else - Result := C; - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrReOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -function CharUpper(const C: Char): Char; -begin - {$IFDEF UNICODE_RTL_DATABASE} - Result := TCharacter.ToUpper(C); - {$ELSE ~UNICODE_RTL_DATABASE} - Result := StrCaseMap[Ord(C) + StrUpOffset]; - {$ENDIF ~UNICODE_RTL_DATABASE} -end; - -//=== Character Search and Replace =========================================== - -function CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - for Result := Length(S) downto Index do - if S[Result] = C then - Exit; - end; - Result := 0; -end; - -function CharPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - for Result := Index to Length(S) do - if S[Result] = C then - Exit; - end; - Result := 0; -end; - -function CharIPos(const S: string; C: Char; const Index: SizeInt): SizeInt; -begin - if (Index > 0) and (Index <= Length(S)) then - begin - C := CharUpper(C); - for Result := Index to Length(S) do - if CharUpper(S[Result]) = C then - Exit; - end; - Result := 0; -end; - -function CharReplace(var S: string; const Search, Replace: Char): SizeInt; -var - P: PChar; - Index, Len: SizeInt; -begin - Result := 0; - if Search <> Replace then - begin - UniqueString(S); - P := PChar(S); - Len := Length(S); - for Index := 0 to Len - 1 do - begin - if P^ = Search then - begin - P^ := Replace; - Inc(Result); - end; - Inc(P); - end; - end; -end; - -//=== MultiSz ================================================================ - -function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; -var - I, TotalLength: SizeInt; - P: PMultiSz; -begin - Assert(Source <> nil); - TotalLength := 1; - for I := 0 to Source.Count - 1 do - if Source[I] = '' then - raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem) - else - Inc(TotalLength, StrLen(PChar(Source[I])) + 1); - AllocateMultiSz(Dest, TotalLength); - P := Dest; - for I := 0 to Source.Count - 1 do - begin - P := StrECopy(P, PChar(Source[I])); - Inc(P); - end; - P^ := #0; - Result := Dest; -end; - -procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); -var - P: PMultiSz; -begin - Assert(Dest <> nil); - Dest.BeginUpdate; - try - Dest.Clear; - if Source <> nil then - begin - P := Source; - while P^ <> #0 do - begin - Dest.Add(P); - P := StrEnd(P); - Inc(P); - end; - end; - finally - Dest.EndUpdate; - end; -end; - -function MultiSzLength(const Source: PMultiSz): SizeInt; -var - P: PMultiSz; -begin - Result := 0; - if Source <> nil then - begin - P := Source; - repeat - Inc(Result, StrLen(P) + 1); - P := StrEnd(P); - Inc(P); - until P^ = #0; - Inc(Result); - end; -end; - -procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); -begin - if Len > 0 then - GetMem(Dest, Len * SizeOf(Char)) - else - Dest := nil; -end; - -procedure FreeMultiSz(var Dest: PMultiSz); -begin - if Dest <> nil then - FreeMem(Dest); - Dest := nil; -end; - -function MultiSzDup(const Source: PMultiSz): PMultiSz; -var - Len: SizeInt; -begin - if Source <> nil then - begin - Len := MultiSzLength(Source); - Result := nil; - AllocateMultiSz(Result, Len); - Move(Source^, Result^, Len * SizeOf(Char)); - end - else - Result := nil; -end; - -function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; -begin - Result := JclAnsiStrings.StringsToMultiSz(Dest, Source); -end; - -procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); -begin - JclAnsiStrings.MultiSzToStrings(Dest, Source); -end; - -function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; -begin - Result := JclAnsiStrings.MultiSzLength(Source); -end; - -procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); -begin - JclAnsiStrings.AllocateMultiSz(Dest, Len); -end; - -procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); -begin - JclAnsiStrings.FreeMultiSz(Dest); -end; - -function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; -begin - Result := JclAnsiStrings.MultiSzDup(Source); -end; - -function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; -begin - Result := JclWideStrings.StringsToMultiSz(Dest, Source); -end; - -procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); -begin - JclWideStrings.MultiSzToStrings(Dest, Source); -end; - -function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; -begin - Result := JclWideStrings.MultiSzLength(Source); -end; - -procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); -begin - JclWideStrings.AllocateMultiSz(Dest, Len); -end; - -procedure FreeWideMultiSz(var Dest: PWideMultiSz); -begin - JclWideStrings.FreeMultiSz(Dest); -end; - -function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; -begin - Result := JclWideStrings.MultiSzDup(Source); -end; - -//=== TStrings Manipulation ================================================== - -procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -var - I, L: SizeInt; - Left: string; -begin - Assert(List <> nil); - List.BeginUpdate; - try - List.Clear; - L := Length(Sep); - I := Pos(Sep, S); - while I > 0 do - begin - Left := StrLeft(S, I - 1); - if (Left <> '') or AllowEmptyString then - List.Add(Left); - Delete(S, 1, I + L - 1); - I := Pos(Sep, S); - end; - if S <> '' then - List.Add(S); // Ignore empty strings at the end. - finally - List.EndUpdate; - end; -end; - -procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); -var - I, L: SizeInt; - LowerCaseStr: string; - Left: string; -begin - Assert(List <> nil); - LowerCaseStr := StrLower(S); - Sep := StrLower(Sep); - L := Length(Sep); - I := Pos(Sep, LowerCaseStr); - List.BeginUpdate; - try - List.Clear; - while I > 0 do - begin - Left := StrLeft(S, I - 1); - if (Left <> '') or AllowEmptyString then - List.Add(Left); - Delete(S, 1, I + L - 1); - Delete(LowerCaseStr, 1, I + L - 1); - I := Pos(Sep, LowerCaseStr); - end; - if S <> '' then - List.Add(S); // Ignore empty strings at the end. - finally - List.EndUpdate; - end; -end; - -function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; -var - I, L: SizeInt; -begin - Result := ''; - for I := 0 to List.Count - 1 do - begin - if (List[I] <> '') or AllowEmptyString then - begin - // don't combine these into one addition, somehow it hurts performance - Result := Result + List[I]; - Result := Result + Sep; - end; - end; - // remove terminating separator - if List.Count > 0 then - begin - L := Length(Sep); - Delete(Result, Length(Result) - L + 1, L); - end; -end; - -function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: - Boolean = True): string; -var - I, L, N: SizeInt; -begin - Result := ''; - if List.Count > NumberOfItems then - N := NumberOfItems - else - N := List.Count; - for I := 0 to N - 1 do - begin - if (List[I] <> '') or AllowEmptyString then - begin - // don't combine these into one addition, somehow it hurts performance - Result := Result + List[I]; - Result := Result + Sep; - end; - end; - // remove terminating separator - if N > 0 then - begin - L := Length(Sep); - Delete(Result, Length(Result) - L + 1, L); - end; -end; - -procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := Trim(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := TrimRight(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean); -var - I: SizeInt; -begin - Assert(List <> nil); - List.BeginUpdate; - try - for I := List.Count - 1 downto 0 do - begin - List[I] := TrimLeft(List[I]); - if (List[I] = '') and DeleteIfEmpty then - List.Delete(I); - end; - finally - List.EndUpdate; - end; -end; - -function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; -begin - Assert(Strings <> nil); - Result := Unique and (Strings.IndexOf(S) <> -1); - if not Result then - Result := Strings.Add(S) > -1; -end; - -//=== Miscellaneous ========================================================== - -function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; -var - fs: TFileStream; - Len: SizeInt; -begin - fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - Len := fs.Size; - SetLength(Result, Len); - if Len > 0 then - fs.ReadBuffer(Result[1], Len); - finally - fs.Free; - end; -end; - -procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; - Append: Boolean); -var - FS: TFileStream; - Len: SizeInt; -begin - if Append and FileExists(filename) then - FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite) - else - FS := TFileStream.Create(FileName, fmCreate); - try - if Append then - FS.Seek(0, soEnd); // faster than .Position := .Size - Len := Length(Contents); - if Len > 0 then - FS.WriteBuffer(Contents[1], Len); - finally - FS.Free; - end; -end; - -function StrToken(var S: string; Separator: Char): string; -var - I: SizeInt; -begin - I := Pos(Separator, S); - if I <> 0 then - begin - Result := Copy(S, 1, I - 1); - Delete(S, 1, I); - end - else - begin - Result := S; - S := ''; - end; -end; - -procedure StrTokens(const S: string; const List: TStrings); -var - Start: PChar; - Token: string; - Done: Boolean; -begin - Assert(List <> nil); - if List = nil then - Exit; - - List.BeginUpdate; - try - List.Clear; - Start := Pointer(S); - repeat - Done := JclStrings.StrWord(Start, Token); - if Token <> '' then - List.Add(Token); - until Done; - finally - List.EndUpdate; - end; -end; - -function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; -var - Start: SizeInt; - C: Char; -begin - Word := ''; - if (S = '') then - begin - Result := True; - Exit; - end; - Start := Index; - Result := False; - while True do - begin - C := S[Index]; - case C of - #0: - begin - if Start <> 0 then - Word := Copy(S, Start, Index - Start); - Result := True; - Exit; - end; - NativeSpace, NativeLineFeed, NativeCarriageReturn: - begin - if Start <> 0 then - begin - Word := Copy(S, Start, Index - Start); - Exit; - end - else - begin - while CharIsWhiteSpace(C) do - begin - Inc(Index); - C := S[Index]; - end; - end; - end; - else - if Start = 0 then - Start := Index; - Inc(Index); - end; - end; -end; - -function StrWord(var S: PChar; out Word: string): Boolean; -var - Start: PChar; -begin - Word := ''; - if S = nil then - begin - Result := True; - Exit; - end; - Start := nil; - Result := False; - while True do - begin - case S^ of - #0: - begin - if Start <> nil then - SetString(Word, Start, S - Start); - Result := True; - Exit; - end; - NativeSpace, NativeLineFeed, NativeCarriageReturn: - begin - if Start <> nil then - begin - SetString(Word, Start, S - Start); - Exit; - end - else - while CharIsWhiteSpace(S^) do - Inc(S); - end; - else - if Start = nil then - Start := S; - Inc(S); - end; - end; -end; - -function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; -var - Start: SizeInt; - C: Char; -begin - Ident := ''; - if (S = '') then - begin - Result := True; - Exit; - end; - Start := Index; - Result := False; - while True do - begin - C := S[Index]; - if CharIsValidIdentifierLetter(C) then - begin - if Start = 0 then - Start := Index; - end - else - if C = #0 then - begin - if Start <> 0 then - Ident := Copy(S, Start, Index - Start); - Result := True; - Exit; - end - else - begin - if Start <> 0 then - begin - Ident := Copy(S, Start, Index - Start); - Exit; - end; - end; - Inc(Index); - end; -end; - -function StrIdent(var S: PChar; out Ident: string): Boolean; -var - Start: PChar; - C: Char; -begin - Ident := ''; - if S = nil then - begin - Result := True; - Exit; - end; - Start := nil; - Result := False; - while True do - begin - C := S^; - if CharIsValidIdentifierLetter(C) then - begin - if Start = nil then - Start := S; - end - else - if C = #0 then - begin - if Start <> nil then - SetString(Ident, Start, S - Start); - Result := True; - Exit; - end - else - begin - if Start <> nil then - begin - SetString(Ident, Start, S - Start); - Exit; - end - end; - Inc(S); - end; -end; - -procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); -var - Token: string; -begin - Assert(List <> nil); - - if List = nil then - Exit; - - List.BeginUpdate; - try - List.Clear; - while S <> '' do - begin - Token := StrToken(S, Separator); - List.Add(Token); - end; - finally - List.EndUpdate; - end; -end; - -function StrToFloatSafe(const S: string): Float; -var - Temp: string; - I, J, K: SizeInt; - SwapSeparators, IsNegative: Boolean; - DecSep, ThouSep, C: Char; -begin - DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator; - ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator; - Temp := S; - SwapSeparators := False; - - IsNegative := False; - J := 0; - for I := 1 to Length(Temp) do - begin - C := Temp[I]; - if C = '-' then - IsNegative := not IsNegative - else - if (C <> ' ') and (C <> '(') and (C <> '+') then - begin - // if it appears prior to any digit, it has to be a decimal separator - SwapSeparators := Temp[I] = ThouSep; - J := I; - Break; - end; - end; - - if not SwapSeparators then - begin - K := CharPos(Temp, DecSep); - SwapSeparators := - // if it appears prior to any digit, it has to be a decimal separator - (K > J) and - // if it appears multiple times, it has to be a thousand separator - ((StrCharCount(Temp, DecSep) > 1) or - // we assume (consistent with Windows Platform SDK documentation), - // that thousand separators appear only to the left of the decimal - (K < CharPos(Temp, ThouSep))); - end; - - if SwapSeparators then - begin - // assume a numerical string from a different locale, - // where DecimalSeparator and ThousandSeparator are exchanged - for I := 1 to Length(Temp) do - if Temp[I] = DecSep then - Temp[I] := ThouSep - else - if Temp[I] = ThouSep then - Temp[I] := DecSep; - end; - - Temp := StrKeepChars(Temp, CharIsNumber); - - if Length(Temp) > 0 then - begin - if Temp[1] = DecSep then - Temp := '0' + Temp; - if Temp[Length(Temp)] = DecSep then - Temp := Temp + '0'; - Result := StrToFloat(Temp); - if IsNegative then - Result := -Result; - end - else - Result := 0.0; -end; - -function StrToIntSafe(const S: string): Integer; -begin - Result := Trunc(StrToFloatSafe(S)); -end; - -procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; -begin - Index := Max(1, Min(Index, StrLen + 1)); - Count := Max(0, Min(Count, StrLen + 1 - Index)); -end; - -function ArrayOf(List: TStrings): TDynStringArray; -var - I: SizeInt; -begin - if List <> nil then - begin - SetLength(Result, List.Count); - for I := 0 to List.Count - 1 do - Result[I] := List[I]; - end - else - Result := nil; -end; - -const - BoolToStr: array [Boolean] of string = ('false', 'true'); - -type - TInterfacedObjectAccess = class(TInterfacedObject); - -procedure MoveChar(const Source; var Dest; Count: SizeInt); -begin - if Count > 0 then - Move(Source, Dest, Count * SizeOf(Char)); -end; - -function DotNetFormat(const Fmt: string; const Arg0: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0]); -end; - -function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0, Arg1]); -end; - -function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; -begin - Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); -end; - -function DotNetFormat(const Fmt: string; const Args: array of const): string; -var - F, P: PChar; - Len, Capacity, Count: SizeInt; - Index: SizeInt; - ErrorCode: Integer; - S: string; - - procedure Grow(Count: SizeInt); - begin - if Len + Count > Capacity then - begin - Capacity := Capacity * 5 div 3 + Count; - SetLength(Result, Capacity); - end; - end; - - function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; - begin - Result := True; - while AClass <> nil do - begin - if CompareText(AClass.ClassName, ClassName) = 0 then - Exit; - AClass := AClass.ClassParent; - end; - Result := False; - end; - - function GetStringOf(const V: TVarData; Index: SizeInt): string; overload; - begin - case V.VType of - varEmpty, varNull: - raise ArgumentNullException.CreateRes(@RsArgumentIsNull); - varSmallInt: - Result := IntToStr(V.VSmallInt); - varInteger: - Result := IntToStr(V.VInteger); - varSingle: - Result := FloatToStr(V.VSingle); - varDouble: - Result := FloatToStr(V.VDouble); - varCurrency: - Result := CurrToStr(V.VCurrency); - varDate: - Result := DateTimeToStr(V.VDate); - varOleStr: - Result := V.VOleStr; - varBoolean: - Result := BoolToStr[V.VBoolean <> False]; - varByte: - Result := IntToStr(V.VByte); - varWord: - Result := IntToStr(V.VWord); - varShortInt: - Result := IntToStr(V.VShortInt); - varLongWord: - Result := IntToStr(V.VLongWord); - varInt64: - Result := IntToStr(V.VInt64); - varString: - Result := string(V.VString); - {$IFDEF SUPPORTS_UNICODE_STRING} - varUString: - Result := string(V.VUString); - {$ENDIF SUPPORTS_UNICODE_STRING} - {varArray, - varDispatch, - varError, - varUnknown, - varAny, - varByRef:} - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - end; - end; - - function GetStringOf(Index: SizeInt): string; overload; - var - V: TVarRec; - Intf: IToString; - begin - V := Args[Index]; - if (V.VInteger = 0) and - (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, - vtInterface, vtInt64]) then - raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); - - case V.VType of - vtInteger: - Result := IntToStr(V.VInteger); - vtBoolean: - Result := BoolToStr[V.VBoolean]; - vtChar: - Result := string(AnsiString(V.VChar)); - vtExtended: - Result := FloatToStr(V.VExtended^); - vtString: - Result := string(V.VString^); - vtPointer: - Result := IntToHex(TJclAddr(V.VPointer), 8); - vtPChar: - Result := string(AnsiString(V.VPChar)); - vtObject: - if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then - begin - Result := Intf.ToString; - Pointer(Intf) := nil; // do not release the object - // undo the RefCount change - Dec(TInterfacedObjectAccess(V.VObject).FRefCount); - end - else - if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then - Result := Intf.ToString - else -{$IFDEF RTL200_UP} - Result := V.VObject.ToString; -{$Else} - raise ArgumentNullException.CreateResFmt(V.VObject.ClassName + ': ' + @RsDotNetFormatArgumentNotSupported, [Index]); -{$EndIf} - vtClass: - Result := V.VClass.ClassName; - vtWideChar: - Result := V.VWideChar; - vtPWideChar: - Result := V.VPWideChar; - vtAnsiString: - Result := string(V.VAnsiString); - vtCurrency: - Result := CurrToStr(V.VCurrency^); - vtVariant: - Result := GetStringOf(TVarData(V.VVariant^), Index); - vtInterface: - if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then - Result := IToString(Intf).ToString - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - vtWideString: - Result := WideString(V.VWideString); - vtInt64: - Result := IntToStr(V.VInt64^); - {$IFDEF SUPPORTS_UNICODE_STRING} - vtUnicodeString: - Result := UnicodeString(V.VUnicodeString); - {$ENDIF SUPPORTS_UNICODE_STRING} - else - raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); - end; - end; - -begin - if Length(Args) = 0 then - begin - Result := Fmt; - Exit; - end; - Len := 0; - Capacity := Length(Fmt); - SetLength(Result, Capacity); - if Capacity = 0 then - raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); - - P := Pointer(Fmt); - F := P; - while True do - begin - if (P[0] = #0) or (P[0] = '{') then - begin - Count := P - F; - Inc(P); - if (P[-1] <> #0) and (P[0] = '{') then - Inc(Count); // include '{' - - if Count > 0 then - begin - Grow(Count); - MoveChar(F[0], Result[Len + 1], Count); - Inc(Len, Count); - end; - - if P[-1] = #0 then - Break; - - if P[0] <> '{' then - begin - F := P; - Inc(P); - while (P[0] <> #0) and (P[0] <> '}') do - Inc(P); - SetString(S, F, P - F); - Val(S, Index, ErrorCode); - if ErrorCode <> 0 then - raise FormatException.CreateRes(@RsFormatException); - if (Index < 0) or (Index > High(Args)) then - raise FormatException.CreateRes(@RsFormatException); - S := GetStringOf(Index); - if S <> '' then - begin - Grow(Length(S)); - MoveChar(S[1], Result[Len + 1], Length(S)); - Inc(Len, Length(S)); - end; - - if P[0] = #0 then - Break; - end; - F := P + 1; - end - else - if (P[0] = '}') and (P[1] = '}') then - begin - Count := P - F + 1; - Inc(P); // skip next '}' - - Grow(Count); - MoveChar(F[0], Result[Len + 1], Count); - Inc(Len, Count); - F := P + 1; - end; - - Inc(P); - end; - - SetLength(Result, Len); -end; - -//=== { TJclStringBuilder } ===================================================== - -constructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt); -begin - inherited Create; - SetLength(FChars, Capacity); - FMaxCapacity := MaxCapacity; -end; - -constructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt); -begin - Create(Capacity); - Append(Value); -end; - -constructor TJclStringBuilder.Create(const Value: string; StartIndex, - Length, Capacity: SizeInt); -begin - Create(Capacity); - Append(Value, StartIndex + 1, Length); -end; - -function TJclStringBuilder.ToString: string; -begin - if FLength > 0 then - SetString(Result, PChar(@FChars[0]), FLength) - else - Result := ''; -end; - -function TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt; -begin - if System.Length(FChars) < Capacity then - SetCapacity(Capacity); - Result := System.Length(FChars); -end; - -procedure TJclStringBuilder.SetCapacity(const Value: SizeInt); -begin - if Value <> System.Length(FChars) then - begin - SetLength(FChars, Value); - if Value < FLength then - FLength := Value; - end; -end; - -function TJclStringBuilder.GetChars(Index: SizeInt): Char; -begin - Result := FChars[Index]; -end; - -procedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char); -begin - FChars[Index] := Value; -end; - -procedure TJclStringBuilder.Set_Length(const Value: SizeInt); -begin - FLength := Value; -end; - -function TJclStringBuilder.GetCapacity: SizeInt; -begin - Result := System.Length(FChars); -end; - -function TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder; -var - Capacity: SizeInt; -begin - if (Count > 0) and (RepeatCount > 0) then - begin - repeat - Capacity := System.Length(FChars); - if Capacity + Count > MaxCapacity then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Count then - SetLength(FChars, Capacity * 5 div 3 + Count); - if Count = 1 then - FChars[FLength] := Value[0] - else - MoveChar(Value[0], FChars[FLength], Count); - Inc(FLength, Count); - Dec(RepeatCount); - until RepeatCount <= 0; - end; - Result := Self; -end; - -function TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count, - RepeatCount: SizeInt): TJclStringBuilder; -var - Capacity: SizeInt; -begin - if (Index < 0) or (Index > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - - if Index = FLength then - AppendPChar(Value, Count, RepeatCount) - else - if (Count > 0) and (RepeatCount > 0) then - begin - repeat - Capacity := System.Length(FChars); - if Capacity + Count > MaxCapacity then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Count then - SetLength(FChars, Capacity * 5 div 3 + Count); - MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); - if Count = 1 then - FChars[Index] := Value[0] - else - MoveChar(Value[0], FChars[Index], Count); - Inc(FLength, Count); - - Dec(RepeatCount); - - Inc(Index, Count); // little optimization - until RepeatCount <= 0; - end; - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - AppendPChar(@Value[0], Len); - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - AppendPChar(PChar(@Value[0]) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; -begin - Result := AppendPChar(@Value, 1, RepeatCount); -end; - -function TJclStringBuilder.Append(const Value: string): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - AppendPChar(Pointer(Value), Len); - Result := Self; -end; - -function TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder; -begin - Result := Append(BoolToStr[Value]); -end; - -function TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Integer): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Double): TJclStringBuilder; -begin - Result := Append(FloatToStr(Value)); -end; - -function TJclStringBuilder.Append(Value: Int64): TJclStringBuilder; -begin - Result := Append(IntToStr(Value)); -end; - -function TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder; -begin - Result := Append(DotNetFormat('{0}', [Obj])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); -end; - -function TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; -begin - Result := Append(DotNetFormat(Fmt, Args)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - InsertPChar(Index, @Value[0], Len); - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if Len > 0 then - InsertPChar(Index, Pointer(Value), Len, Count); - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; -begin - Result := Insert(Index, BoolToStr[Value]); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char; - StartIndex, Length: SizeInt): TJclStringBuilder; -var - Len: SizeInt; -begin - Len := System.Length(Value); - if (Length > 0) and (StartIndex < Len) then - begin - if StartIndex + Length > Len then - Length := Len - StartIndex; - InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder; -begin - Result := Insert(Index, FloatToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; -begin - Result := Insert(Index, IntToStr(Value)); -end; - -function TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; -begin - Result := Insert(Index, DotNetFormat('{0}', [Obj])); -end; - -function TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder; -begin - if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Length > 0 then - begin - MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length)); - Dec(FLength, Length); - end; - Result := Self; -end; - -function TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, - Count: SizeInt): TJclStringBuilder; -var - I: SizeInt; -begin - if Count = -1 then - Count := FLength; - if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if (Count > 0) and (OldChar <> NewChar) then - begin - for I := StartIndex to StartIndex + Length - 1 do - if FChars[I] = OldChar then - FChars[I] := NewChar; - end; - Result := Self; -end; - -function TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder; -var - I: SizeInt; - Offset: SizeInt; - NewLen, OldLen, Capacity: SizeInt; -begin - if Count = -1 then - Count := FLength; - if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if OldValue = '' then - raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); - - if (Count > 0) and (OldValue <> NewValue) then - begin - OldLen := System.Length(OldValue); - NewLen := System.Length(NewValue); - Offset := NewLen - OldLen; - Capacity := System.Length(FChars); - for I := StartIndex to StartIndex + Length - 1 do - if FChars[I] = OldValue[1] then - begin - if OldLen > 1 then - if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then - Continue; - if Offset <> 0 then - begin - if FLength - OldLen + NewLen > MaxCurrency then - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - if Capacity < FLength + Offset then - begin - Capacity := Capacity * 5 div 3 + Offset; - SetLength(FChars, Capacity); - end; - if Offset < 0 then - MoveChar(FChars[I - Offset], FChars[I], FLength - I) - else - MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I); - Inc(FLength, Offset); - end; - if NewLen > 0 then - begin - if (OldLen = 1) and (NewLen = 1) then - FChars[I] := NewValue[1] - else - MoveChar(NewValue[1], FChars[I], NewLen); - end; - end; - end; - Result := Self; -end; - -function StrExpandTabs(S: string): string; -begin - // use an empty tab set, which will default to a tab width of 2 - Result := TJclTabSet(nil).Expand(s); -end; - -function StrExpandTabs(S: string; TabWidth: SizeInt): string; -var - TabSet: TJclTabSet; -begin - // create a tab set with no tab stops and the given tab width - TabSet := TJclTabSet.Create(TabWidth); - try - Result := TabSet.Expand(S); - finally - TabSet.Free; - end; -end; - -function StrExpandTabs(S: string; TabSet: TJclTabSet): string; -begin - // use the provided tab set to perform the expansion - Result := TabSet.Expand(S); -end; - -function StrOptimizeTabs(S: string): string; -begin - // use an empty tab set, which will default to a tab width of 2 - Result := TJclTabSet(nil).Optimize(s); -end; - -function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; -var - TabSet: TJclTabSet; -begin - // create a tab set with no tab stops and the given tab width - TabSet := TJclTabSet.Create(TabWidth); - try - Result := TabSet.Optimize(S); - finally - TabSet.Free; - end; -end; - -function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; -begin - // use the provided tab set to perform the optimization - Result := TabSet.Optimize(S); -end; - -// === { TTabSetData } =================================================== - -type - TTabSetData = class - public - FStops: TDynSizeIntArray; - FRealWidth: SizeInt; - FRefCount: SizeInt; - FWidth: SizeInt; - FZeroBased: Boolean; - constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); - - function Add(Column: SizeInt): SizeInt; - function AddRef: SizeInt; - procedure CalcRealWidth; - function FindStop(Column: SizeInt): SizeInt; - function ReleaseRef: SizeInt; - procedure RemoveAt(Index: SizeInt); - procedure SetStops(Index, Value: SizeInt); - end; - -constructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); -var - idx: SizeInt; -begin - inherited Create; - FRefCount := 1; - for idx := 0 to High(Tabstops) do - Add(Tabstops[idx]); - FWidth := TabWidth; - FZeroBased := ZeroBased; - CalcRealWidth; -end; - -function TTabSetData.Add(Column: SizeInt): SizeInt; -var - I: SizeInt; -begin - if Column < Ord(FZeroBased) then - raise ArgumentOutOfRangeException.Create('Column'); - Result := FindStop(Column); - if Result < 0 then - begin - // the column doesn't exist; invert the result of FindStop to get the correct index position - Result := not Result; - // increase the tab stop array - SetLength(FStops, Length(FStops) + 1); - // shift rooms after the insert position - for I := High(FStops) - 1 downto Result do - FStops[I + 1] := FStops[I]; - // add the tab stop at the correct location - FStops[Result] := Column; - CalcRealWidth; - end - else - begin - raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); - end; -end; - -function TTabSetData.AddRef: SizeInt; -begin - Result := LockedInc(FRefCount); -end; - -procedure TTabSetData.CalcRealWidth; -begin - if FWidth < 1 then - begin - if Length(FStops) > 1 then - FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))] - else - if Length(FStops) = 1 then - FRealWidth := FStops[0] - else - FRealWidth := 2; - end - else - FRealWidth := FWidth; -end; - -function TTabSetData.FindStop(Column: SizeInt): SizeInt; -begin - Result := High(FStops); - while (Result >= 0) and (FStops[Result] > Column) do - Dec(Result); - if (Result >= 0) and (FStops[Result] <> Column) then - Result := not Succ(Result); -end; - -function TTabSetData.ReleaseRef: SizeInt; -begin - Result := LockedDec(FRefCount); - if Result <= 0 then - Destroy; -end; - -procedure TTabSetData.RemoveAt(Index: SizeInt); -var - I: SizeInt; -begin - for I := Index to High(FStops) - 1 do - FStops[I] := FStops[I + 1]; - SetLength(FStops, High(FStops)); - CalcRealWidth; -end; - -procedure TTabSetData.SetStops(Index, Value: SizeInt); -var - temp: SizeInt; -begin - if (Index < 0) or (Index >= Length(FStops)) then - begin - raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); - end - else - begin - temp := FindStop(Value); - if temp < 0 then - begin - // remove existing tab stop... - RemoveAt(Index); - // now add the new tab stop - Add(Value); - end - else - if temp <> Index then - begin - // new tab stop already present at another index - raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); - end; - end; -end; - -//=== { TJclTabSet } ===================================================== - -constructor TJclTabSet.Create; -begin - // no tab stops, tab width set to auto - Create([], True, 0); -end; - -constructor TJclTabSet.Create(TabWidth: SizeInt); -begin - // no tab stops, specified tab width - Create([], True, TabWidth); -end; - -constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); -begin - // specified tab stops, tab width equal to distance between last two tab stops - Create(Tabstops, ZeroBased, 0); -end; - -constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); -begin - inherited Create; - FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth); -end; - -constructor TJclTabSet.Create(Data: TObject); -begin - inherited Create; - // add a reference to the data - TTabSetData(Data).AddRef; - // assign the data to this instance - FData := TTabSetData(Data); -end; - -destructor TJclTabSet.Destroy; -begin - // release the reference to the tab set data - TTabSetData(FData).ReleaseRef; - // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction - FData := nil; - // really destroy the instance - inherited Destroy; -end; - -function TJclTabSet.Add(Column: SizeInt): SizeInt; -begin - if Self = nil then - raise NullReferenceException.Create; - Result := TTabSetData(FData).Add(Column); -end; - -function TJclTabSet.Clone: TJclTabSet; -begin - if Self <> nil then - Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth) - else - Result := nil; -end; - -function TJclTabSet.Delete(Column: SizeInt): SizeInt; -begin - Result := TTabSetData(FData).FindStop(Column); - if Result >= 0 then - TTabSetData(FData).RemoveAt(Result); -end; - -function TJclTabSet.Expand(const S: string): string; -begin - Result := Expand(s, StartColumn); -end; - -function TJclTabSet.Expand(const S: string; Column: SizeInt): string; -var - sb: TJclStringBuilder; - head: PChar; - cur: PChar; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - sb := TJclStringBuilder.Create(Length(S)); - try - cur := PChar(S); - while cur^ <> #0 do - begin - head := cur; - while (cur^ <> #0) and (cur^ <> #9) do - begin - if CharIsReturn(cur^) then - Column := StartColumn - else - Inc(Column); - Inc(cur); - end; - if cur > head then - sb.Append(head, 0, cur - head); - if cur^ = #9 then - begin - sb.Append(' ', TabFrom(Column) - Column); - Column := TabFrom(Column); - Inc(cur); - end; - end; - Result := sb.ToString; - finally - sb.Free; - end; -end; - -function TJclTabSet.FindStop(Column: SizeInt): SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FindStop(Column) - else - Result := -1; -end; - -class function TJclTabSet.FromString(const S: string): TJclTabSet; -var - cur: PChar; - - function ParseNumber: Integer; - var - head: PChar; - begin - StrSkipChars(cur, CharIsWhiteSpace); - head := cur; - while CharIsDigit(cur^) do - Inc(cur); - Result := -1; - if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then - Result := -1; - end; - - procedure ParseStops; - var - openBracket, hadComma: Boolean; - num: SizeInt; - begin - StrSkipChars(cur, CharIsWhiteSpace); - openBracket := cur^ = '['; - hadComma := False; - if openBracket then - Inc(cur); - repeat - num := ParseNumber; - if (num < 0) and hadComma then - raise EJclStringError.CreateRes(@RsTabs_StopExpected) - else - if num >= 0 then - Result.Add(num); - StrSkipChars(cur, CharIsWhiteSpace); - hadComma := cur^ = ','; - if hadComma then - Inc(cur); - until (cur^ = #0) or (cur^ = '+') or (cur^ = ']'); - if hadComma then - raise EJclStringError.CreateRes(@RsTabs_StopExpected) - else - if openBracket and (cur^ <> ']') then - raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected); - end; - - procedure ParseTabWidth; - var - num: SizeInt; - begin - StrSkipChars(cur, CharIsWhiteSpace); - if cur^ = '+' then - begin - Inc(cur); - StrSkipChars(cur, CharIsWhiteSpace); - num := ParseNumber; - if (num < 0) then - raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected) - else - Result.TabWidth := num; - end; - end; - - procedure ParseZeroBasedFlag; - begin - StrSkipChars(cur, CharIsWhiteSpace); - if cur^ = '0' then - begin - Inc(cur); - if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then - begin - Result.ZeroBased := True; - StrSkipChars(cur, CharIsWhiteSpace); - end - else - Dec(cur); - end; - end; - -begin - Result := TJclTabSet.Create; - try - Result.ZeroBased := False; - cur := PChar(S); - ParseZeroBasedFlag; - ParseStops; - ParseTabWidth; - except - // clean up the partially complete instance (to avoid memory leaks)... - Result.Free; - // ... and re-raise the exception - raise; - end; -end; - -function TJclTabSet.GetCount: SizeInt; -begin - if Self <> nil then - Result := Length(TTabSetData(FData).FStops) - else - Result := 0; -end; - -function TJclTabSet.GetStops(Index: SizeInt): SizeInt; -begin - if Self <> nil then - begin - if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then - begin - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - end - else - Result := TTabSetData(FData).FStops[Index]; - end - else - begin - raise EJclStringError.CreateRes(@RsArgumentOutOfRange); - end; -end; - -function TJclTabSet.GetTabWidth: SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FWidth - else - Result := 0; -end; - -function TJclTabSet.GetZeroBased: Boolean; -begin - Result := (Self = nil) or TTabSetData(FData).FZeroBased; -end; - -procedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); -var - nextTab: SizeInt; -begin - if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state) - raise ArgumentOutOfRangeException.Create('StartColumn'); - if (TargetColumn < StartColumn) then // target lies before the starting column - raise ArgumentOutOfRangeException.Create('TargetColumn'); - TabsNeeded := 0; - repeat - nextTab := TabFrom(StartColumn); - if nextTab <= TargetColumn then - begin - Inc(TabsNeeded); - StartColumn := nextTab; - end; - until nextTab > TargetColumn; - SpacesNeeded := TargetColumn - StartColumn; -end; - -function TJclTabSet.Optimize(const S: string): string; -begin - Result := Optimize(S, StartColumn); -end; - -function TJclTabSet.Optimize(const S: string; Column: SizeInt): string; -var - sb: TJclStringBuilder; - head: PChar; - cur: PChar; - tgt: SizeInt; - - procedure AppendOptimalWhiteSpace(Target: SizeInt); - var - tabCount: SizeInt; - spaceCount: SizeInt; - begin - if cur > head then - begin - OptimalFillInfo(Column, Target, tabCount, spaceCount); - if tabCount > 0 then - sb.Append(#9, tabCount); - if spaceCount > 0 then - sb.Append(' ', spaceCount); - end; - end; - -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - sb := TJclStringBuilder.Create(Length(S)); - try - cur := PChar(s); - while cur^ <> #0 do - begin - // locate first whitespace character - head := cur; - while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do - Inc(cur); - // output non whitespace characters - if cur > head then - sb.Append(head, 0, cur - head); - // advance column - Inc(Column, cur - head); - // initialize target column indexer - tgt := Column; - // locate end of whitespace sequence - while CharIsWhiteSpace(cur^) do - begin - if CharIsReturn(cur^) then - begin - // append optimized whitespace sequence... - AppendOptimalWhiteSpace(tgt); - // ...set the column back to the start of the line... - Column := StartColumn; - // ...reset target column indexer... - tgt := Column; - // ...add the line break character... - sb.Append(cur^); - end - else - if cur^ = #9 then - tgt := TabFrom(tgt) // expand the tab - else - Inc(tgt); // a normal whitespace; taking up 1 column - Inc(cur); - end; - AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence... - Column := tgt; // ...and memorize the column for the next iteration - end; - Result := sb.ToString; // convert result to a string - finally - sb.Free; - end; -end; - -procedure TJclTabSet.RemoveAt(Index: SizeInt); -begin - if Self <> nil then - TTabSetData(FData).RemoveAt(Index) - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetStops(Index, Value: SizeInt); -begin - if Self <> nil then - TTabSetData(FData).SetStops(Index, Value) - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetTabWidth(Value: SizeInt); -begin - if Self <> nil then - begin - TTabSetData(FData).FWidth := Value; - TTabSetData(FData).CalcRealWidth; - end - else - raise NullReferenceException.Create; -end; - -procedure TJclTabSet.SetZeroBased(Value: Boolean); -var - shift: SizeInt; - idx: SizeInt; -begin - if Self <> nil then - begin - if Value <> TTabSetData(FData).FZeroBased then - begin - TTabSetData(FData).FZeroBased := Value; - if Value then - shift := -1 - else - shift := 1; - for idx := 0 to High(TTabSetData(FData).FStops) do - TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift; - end; - end - else - raise NullReferenceException.Create; -end; - -function TJclTabSet.InternalTabStops: TDynSizeIntArray; -begin - if Self <> nil then - Result := TTabSetData(FData).FStops - else - Result := nil; -end; - -function TJclTabSet.InternalTabWidth: SizeInt; -begin - if Self <> nil then - Result := TTabSetData(FData).FRealWidth - else - Result := 2; -end; - -function TJclTabSet.NewReference: TJclTabSet; -begin - if Self <> nil then - Result := TJclTabSet.Create(FData) - else - Result := nil; -end; - -function TJclTabSet.StartColumn: SizeInt; -begin - if GetZeroBased then - Result := 0 - else - Result := 1; -end; - -function TJclTabSet.TabFrom(Column: SizeInt): SizeInt; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - Result := FindStop(Column); - if Result < 0 then - Result := not Result - else - Inc(Result); - if Result >= GetCount then - begin - if GetCount > 0 then - Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)] - else - Result := StartColumn; - while Result <= Column do - Inc(Result, ActualTabWidth); - end - else - Result := TTabSetData(FData).FStops[Result]; -end; - -function TJclTabSet.ToString: string; -begin - Result := ToString(TabSetFormatting_Full); -end; - -function TJclTabSet.ToString(FormattingOptions: SizeInt): string; -var - sb: TJclStringBuilder; - idx: SizeInt; - - function WantBrackets: Boolean; - begin - Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0; - end; - - function EmptyBrackets: Boolean; - begin - Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0; - end; - - function IncludeAutoWidth: Boolean; - begin - Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0; - end; - - function IncludeTabWidth: Boolean; - begin - Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0; - end; - - function IncludeStops: Boolean; - begin - Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0; - end; - -begin - sb := TJclStringBuilder.Create; - try - // output the fixed tabulation positions if requested... - if IncludeStops then - begin - // output each individual tabulation position - for idx := 0 to GetCount - 1 do - begin - sb.Append(TabStops[idx]); - sb.Append(','); - end; - // remove the final comma if any tabulation positions where outputted - if sb.Length <> 0 then - sb.Remove(sb.Length - 1, 1); - // bracket the tabulation positions if requested - if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then - begin - sb.Insert(0, '['); - sb.Append(']'); - end; - end; - // output the tab width if requested.... - if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then - begin - // separate the tab width from any outputted tabulation positions with a whitespace - if sb.Length > 0 then - sb.Append(' '); - // flag tab width - sb.Append('+'); - // finally, output the tab width - sb.Append(ActualTabWidth); - end; - // flag zero-based tabset by outputting a 0 (zero) as the first character. - if ZeroBased then - sb.Insert(0, string('0 ')); - Result := StrTrimCharRight(sb.ToString, ' '); - finally - sb.Free; - end; -end; - -function TJclTabSet.UpdatePosition(const S: string): SizeInt; -var - Line: SizeInt; -begin - Result := StartColumn; - Line := -1; - UpdatePosition(S, Result, Line); -end; - -function TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt; -var - Line: SizeInt; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - Result := Column; - Line := -1; - UpdatePosition(S, Result, Line); -end; - -function TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; -var - prevChar: Char; - cur: PChar; -begin - if Column < StartColumn then - raise ArgumentOutOfRangeException.Create('Column'); - // initialize loop - cur := PChar(S); - // iterate until end of string (the Null-character) - while cur^ <> #0 do - begin - // check for line-breaking characters - if CharIsReturn(cur^) then - begin - // Column moves back all the way to the left - Column := StartColumn; - // If this is the first line-break character or the same line-break character, increment the Line parameter - Inc(Line); - // check if it's the first of a two-character line-break - prevChar := cur^; - Inc(cur); - // if it isn't a two-character line-break, undo the previous advancement - if (cur^ = prevChar) or not CharIsReturn(cur^) then - Dec(cur); - end - else // check for tab character and expand it - if cur^ = #9 then - Column := TabFrom(Column) - else // a normal character; increment column - Inc(Column); - // advance pointer - Inc(cur); - end; - // set the result to the newly calculated column - Result := Column; -end; - -//=== { NullReferenceException } ============================================= - -constructor NullReferenceException.Create; -begin - CreateRes(@RsArg_NullReferenceException); -end; - -function CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt; -var - Cur1, Len1, - Cur2, Len2: SizeInt; - - function IsRealNumberChar(ch: Char): Boolean; - begin - Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+'); - end; - - procedure NumberCompare; - var - IsReallyNumber: Boolean; - FirstDiffBreaks: Boolean; - Val1, Val2: SizeInt; - begin - Result := 0; - IsReallyNumber := False; - // count leading spaces in S1 - while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do - begin - Dec(Result); - Inc(Cur1); - end; - // count leading spaces in S2 (canceling them out against the ones in S1) - while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do - begin - Inc(Result); - Inc(Cur2); - end; - - // if spaces match, or both strings are actually followed by a numeric character, continue the checks - if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then - begin - // Check signed number - if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then - Result := 1 - else - if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then - Result := -1 - else - Result := 0; - - if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then - Inc(Cur1); - if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then - Inc(Cur2); - - FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0'); - while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do - begin - IsReallyNumber := True; - Val1 := StrToInt(S1[Cur1]); - Val2 := StrToInt(S2[Cur2]); - - if (Result = 0) and (Val1 < Val2) then - Result := -1 - else - if (Result = 0) and (Val1 > Val2) then - Result := 1; - if FirstDiffBreaks and (Result <> 0) then - Break; - Inc(Cur1); - Inc(Cur2); - end; - - if IsReallyNumber then - begin - if not FirstDiffBreaks then - begin - if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then - Result := 1 - else - if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then - Result := -1; - end; - end; - end; - end; - - procedure SetByCompareLength; - var - Remain1: SizeInt; - Remain2: SizeInt; - begin - // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be - // completely equal, or S2 could be longer) - Remain1 := Len1 - Cur1 + 1; - Remain2 := Len2 - Cur2 + 1; - if Remain1 < 0 then - Remain1 := 0; - if Remain2 < 0 then - Remain2 := 0; - - if Remain1 < Remain2 then - Result := -1 - else - if Remain1 > Remain2 then - Result := 1; - end; - -begin - Cur1 := 1; - Len1 := Length(S1); - Cur2 := 1; - Len2 := Length(S2); - Result := 0; - - while (Result = 0) do - begin - if (Cur1 > Len1) or (Cur2 > Len2) then - begin - SetByCompareLength; - Break; - end - else - if (Cur1 <= Len1) and (Cur2 > Len2) then - Result := 1 - else - if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then - Result := -1 - else - if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then - Result := 1 - else - if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then - NumberCompare - else - begin - if CaseInsensitive then - Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1) - else - Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1); - Inc(Cur1); - Inc(Cur2); - end; - end; -end; - -function CompareNaturalStr(const S1, S2: string): SizeInt; overload; -begin - Result := CompareNatural(S1, S2, False); -end; - -function CompareNaturalText(const S1, S2: string): SizeInt; overload; -begin - Result := CompareNatural(S1, S2, True); -end; - -initialization - {$IFNDEF UNICODE_RTL_DATABASE} - LoadCharTypes; // this table first - LoadCaseMap; // or this function does not work - {$ENDIF ~UNICODE_RTL_DATABASE} - {$IFDEF UNITVERSIONING} - RegisterUnitVersion(HInstance, UnitVersioning); - {$ENDIF UNITVERSIONING} - -{$IFDEF UNITVERSIONING} -finalization - UnregisterUnitVersion(HInstance); -{$ENDIF UNITVERSIONING} - -end. - +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ 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 JclStrings.pas. } +{ } +{ The Initial Developer of the Original Code is Marcel van Brakel. } +{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. } +{ } +{ Contributor(s): } +{ Alexander Radchenko } +{ Andreas Hausladen (ahuser) } +{ Anthony Steele } +{ Azret Botash } +{ Barry Kelly } +{ Huanlin Tsai } +{ Jack N.A. Bakker } +{ Jean-Fabien Connault (cycocrew) } +{ John C Molyneux } +{ Kiriakos Vlahos } +{ Leonard Wennekers } +{ Marcel Bestebroer } +{ Martin Kimmings } +{ Martin Kubecka } +{ Massimo Maria Ghisalberti } +{ Matthias Thoma (mthoma) } +{ Michael Winter } +{ Nick Hodges } +{ Olivier Sannier (obones) } +{ Pelle F. S. Liljendal } +{ Petr Vones (pvones) } +{ Rik Barker (rikbarker) } +{ Robert Lee } +{ Robert Marquardt (marquardt) } +{ Robert Rossmair (rrossmair) } +{ Andreas Schmidt } +{ Sean Farrow (sfarrow) } +{ } +{**************************************************************************************************} +{ } +{ Various character and string routines (searching, testing and transforming) } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit JclStrings; + +{$I jcl.inc} + +interface + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$IFDEF HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Winapi.Windows, + {$ENDIF MSWINDOWS} + {$IFDEF UNICODE_RTL_DATABASE} + System.Character, + {$ENDIF UNICODE_RTL_DATABASE} + System.Classes, System.SysUtils, + {$ELSE ~HAS_UNITSCOPE} + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF MSWINDOWS} + {$IFDEF UNICODE_RTL_DATABASE} + Character, + {$ENDIF UNICODE_RTL_DATABASE} + Classes, SysUtils, + {$ENDIF ~HAS_UNITSCOPE} + JclAnsiStrings, + JclWideStrings, + JclBase; + +// Exceptions +type + EJclStringError = class(EJclError); + +// Character constants and sets + +const + // Misc. often used character definitions + NativeNull = Char(#0); + NativeSoh = Char(#1); + NativeStx = Char(#2); + NativeEtx = Char(#3); + NativeEot = Char(#4); + NativeEnq = Char(#5); + NativeAck = Char(#6); + NativeBell = Char(#7); + NativeBackspace = Char(#8); + NativeTab = Char(#9); + NativeLineFeed = JclBase.NativeLineFeed; + NativeVerticalTab = Char(#11); + NativeFormFeed = Char(#12); + NativeCarriageReturn = JclBase.NativeCarriageReturn; + NativeCrLf = JclBase.NativeCrLf; + NativeSo = Char(#14); + NativeSi = Char(#15); + NativeDle = Char(#16); + NativeDc1 = Char(#17); + NativeDc2 = Char(#18); + NativeDc3 = Char(#19); + NativeDc4 = Char(#20); + NativeNak = Char(#21); + NativeSyn = Char(#22); + NativeEtb = Char(#23); + NativeCan = Char(#24); + NativeEm = Char(#25); + NativeEndOfFile = Char(#26); + NativeEscape = Char(#27); + NativeFs = Char(#28); + NativeGs = Char(#29); + NativeRs = Char(#30); + NativeUs = Char(#31); + NativeSpace = Char(' '); + NativeComma = Char(','); + NativeBackslash = Char('\'); + NativeForwardSlash = Char('/'); + + NativeDoubleQuote = Char('"'); + NativeSingleQuote = Char(''''); + + NativeLineBreak = JclBase.NativeLineBreak; + +const + // CharType return values + C1_UPPER = $0001; // Uppercase + C1_LOWER = $0002; // Lowercase + C1_DIGIT = $0004; // Decimal digits + C1_SPACE = $0008; // Space characters + C1_PUNCT = $0010; // Punctuation + C1_CNTRL = $0020; // Control characters + C1_BLANK = $0040; // Blank characters + C1_XDIGIT = $0080; // Hexadecimal digits + C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic + + {$IFDEF MSWINDOWS} + {$IFDEF SUPPORTS_EXTSYM} + {$EXTERNALSYM C1_UPPER} + {$EXTERNALSYM C1_LOWER} + {$EXTERNALSYM C1_DIGIT} + {$EXTERNALSYM C1_SPACE} + {$EXTERNALSYM C1_PUNCT} + {$EXTERNALSYM C1_CNTRL} + {$EXTERNALSYM C1_BLANK} + {$EXTERNALSYM C1_XDIGIT} + {$EXTERNALSYM C1_ALPHA} + {$ENDIF SUPPORTS_EXTSYM} + {$ENDIF MSWINDOWS} + +type + TCharValidator = function(const C: Char): Boolean; + +function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload; +function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; + +// String Test Routines +// TODO: think of some choosen N, so that: If both string length and array length > N - then pre-sort the array +// and use optimized (binary search) CharInArray, if not - then use linear search as now. +function StrIsAlpha(const S: string): Boolean; +function StrIsAlphaNum(const S: string): Boolean; +function StrIsAlphaNumUnderscore(const S: string): Boolean; +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfNumberChars(const S: string): Boolean; +function StrConsistsOfDigits(const S: string): Boolean; +function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; +function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; deprecated 'Use StrConsistsOfChars'; +function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; deprecated 'Use StrConsistsOfChars'; + +function StrIsDigit(const S: string): Boolean; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfDigits'; +// mixing two very separate goals is confusing and using CharValidator can not be implemented at all +function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; {$IfDef SUPPORTS_INLINE} inline;{$EndIf} deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; +function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; deprecated 'Use StrConsistsOfChars or StrContainsEveryChar or StrContainsSomeChar'; + + +// String Transformation Routines +function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; +function StrCharPosLower(const S: string; CharPos: SizeInt): string; +function StrCharPosUpper(const S: string; CharPos: SizeInt): string; +function StrDoubleQuote(const S: string): string; +function StrEnsureNoPrefix(const Prefix, Text: string): string; +function StrEnsureNoSuffix(const Suffix, Text: string): string; +function StrEnsurePrefix(const Prefix, Text: string): string; +function StrEnsureSuffix(const Suffix, Text: string): string; +function StrEscapedToString(const S: string): string; +function StrLower(const S: string): string; +procedure StrLowerInPlace(var S: string); +procedure StrLowerBuff(S: PChar); +procedure StrMove(var Dest: string; const Source: string; const ToIndex, + FromIndex, Count: SizeInt); +function StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string; +function StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string; +function StrProper(const S: string): string; +procedure StrProperBuff(S: PChar); +function StrQuote(const S: string; C: Char): string; +function StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveChars(const S: string; const Chars: array of Char): string; overload; +function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload; +function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload; +function StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload; +function StrKeepChars(const S: string; const Chars: TCharValidator): string; overload; +function StrKeepChars(const S: string; const Chars: array of Char): string; overload; +procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []); +function StrReplaceChar(const S: string; const Source, Replace: Char): string; +function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; +function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; +function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; +function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; +function StrRepeat(const S: string; Count: SizeInt): string; +function StrRepeatLength(const S: string; L: SizeInt): string; +function StrReverse(const S: string): string; +procedure StrReverseInPlace(var S: string); +function StrSingleQuote(const S: string): string; +procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; +procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; +function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; +function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; +function StrStringToEscaped(const S: string): string; +function StrStripNonNumberChars(const S: string): string; +function StrToHex(const Source: string): AnsiString; +function StrTrimCharLeft(const S: string; C: Char): string; +function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload; +function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; +function StrTrimCharRight(const S: string; C: Char): string; +function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload; +function StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload; +function StrTrimQuotes(const S: string): string; +function StrUpper(const S: string): string; +procedure StrUpperInPlace(var S: string); +procedure StrUpperBuff(S: PChar); + +// String Management +procedure StrAddRef(var S: string); +procedure StrDecRef(var S: string); +function StrLength(const S: string): SizeInt; +function StrRefCount(const S: string): SizeInt; + +// String Search and Replace Routines +function StrCharCount(const S: string; C: Char): SizeInt; overload; +function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload; +function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload; +function StrStrCount(const S, SubS: string): SizeInt; +function StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt; +function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt; +function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +procedure StrFillChar(var S; Count: SizeInt; C: Char); +function StrRepeatChar(C: Char; Count: SizeInt): string; +function StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt; +function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; +function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; +function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt; +function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; +function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; +function StrILastPos(const SubStr, S: string): SizeInt; +function StrIPos(const SubStr, S: string): SizeInt; +function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +function StrIsOneOf(const S: string; const List: array of string): Boolean; +function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +function StrLastPos(const SubStr, S: string): SizeInt; +function StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt; +function StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean; +function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; +function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; +function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +function StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt; +function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; + +// String Extraction +// Returns the String before SubStr +function StrAfter(const SubStr, S: string): string; +/// Returns the string after SubStr +function StrBefore(const SubStr, S: string): string; +/// Splits a string at SubStr, returns true when SubStr is found, Left contains the +/// string before the SubStr and Rigth the string behind SubStr +function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; +/// Returns the string between Start and Stop +function StrBetween(const S: string; const Start, Stop: Char): string; +/// Returns the left N characters of the string +function StrChopRight(const S: string; N: SizeInt): string; +/// Returns the left Count characters of the string +function StrLeft(const S: string; Count: SizeInt): string; +/// Returns the string starting from position Start for the Count Characters +function StrMid(const S: string; Start, Count: SizeInt): string; +/// Returns the string starting from position N to the end +function StrRestOf(const S: string; N: SizeInt): string; +/// Returns the right Count characters of the string +function StrRight(const S: string; Count: SizeInt): string; + +// Character Test Routines +function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} +function CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF} +function CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharType(const C: Char): Word; + +// Character Transformation Routines +function CharHex(const C: Char): Byte; +function CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function CharToggleCase(const C: Char): Char; + +// Character Search and Replace +function CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; +function CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; +function CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt; +function CharReplace(var S: string; const Search, Replace: Char): SizeInt; + +// PCharVector +type + PCharVector = ^PChar; + +function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; +function PCharVectorCount(Source: PCharVector): SizeInt; +procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); +procedure FreePCharVector(var Dest: PCharVector); + +// MultiSz Routines +type + PMultiSz = PChar; + PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz; + PWideMultiSz = JclWideStrings.PWideMultiSz; + + TAnsiStrings = JclAnsiStrings.TJclAnsiStrings; + TWideStrings = JclWideStrings.TJclWideStrings; + TAnsiStringList = JclAnsiStrings.TJclAnsiStringList; + TWideStringList = JclWideStrings.TJclWideStringList; + +function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; +procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); +function MultiSzLength(const Source: PMultiSz): SizeInt; +procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); +procedure FreeMultiSz(var Dest: PMultiSz); +function MultiSzDup(const Source: PMultiSz): PMultiSz; + +function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; + {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} + +function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; + {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +procedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} + +// TStrings Manipulation +procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; overload; +function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: + Boolean = True): string; overload; +procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True); +procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True); +procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True); +function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; + +// Miscellaneous +// (OF) moved to JclSysUtils +// function BooleanToStr(B: Boolean): string; + // AnsiString here because it is binary data +function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; +procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; + Append: Boolean = False); + +function StrToken(var S: string; Separator: Char): string; +procedure StrTokens(const S: string; const List: TStrings); +procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); +function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload; +function StrWord(var S: PChar; out Word: string): Boolean; overload; +function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload; +function StrIdent(var S: PChar; out Ident: string): Boolean; overload; +function StrToFloatSafe(const S: string): Float; +function StrToIntSafe(const S: string): Integer; +procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; + +function ArrayOf(List: TStrings): TDynStringArray; overload; + +type + FormatException = class(EJclError); + ArgumentException = class(EJclError); + ArgumentNullException = class(EJclError); + ArgumentOutOfRangeException = class(EJclError); + +// IFomattable in .Net: http://msdn.microsoft.com/en-us/library/system.string.format.aspx + IToString = interface + ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] + function ToString: string; + end; + + TCharDynArray = array of Char; + + // The TStringBuilder class is a Delphi implementation of the .NET + // System.Text.StringBuilder. + // It is zero based and the method that allow an TObject (Append, Insert, + // AppendFormat) are limited to IToString implementors or newer Delphi RTL. + // This class is not threadsafe. Any instance of TStringBuilder should not + // be used in different threads at the same time. + TJclStringBuilder = class(TInterfacedObject, IToString) + private + FChars: TCharDynArray; + FLength: SizeInt; + FMaxCapacity: SizeInt; + + function GetCapacity: SizeInt; + procedure SetCapacity(const Value: SizeInt); + function GetChars(Index: SizeInt): Char; + procedure SetChars(Index: SizeInt; const Value: Char); + procedure Set_Length(const Value: SizeInt); + protected + function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; + function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; + public + constructor Create(const Value: string; Capacity: SizeInt = 16); overload; + constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload; + constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload; + + function Append(const Value: string): TJclStringBuilder; overload; + function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload; + function Append(Value: Boolean): TJclStringBuilder; overload; + function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload; + function Append(const Value: array of Char): TJclStringBuilder; overload; + function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; + function Append(Value: Cardinal): TJclStringBuilder; overload; + function Append(Value: Integer): TJclStringBuilder; overload; + function Append(Value: Double): TJclStringBuilder; overload; + function Append(Value: Int64): TJclStringBuilder; overload; + function Append(Obj: TObject): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload; + + function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload; + function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload; + function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; + overload; + function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload; + function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload; + + function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; + overload; + function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; + overload; + + function Remove(StartIndex, Length: SizeInt): TJclStringBuilder; + function EnsureCapacity(Capacity: SizeInt): SizeInt; + + { IToString } + function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} + + property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default; + property Chars: TCharDynArray read FChars; + property Length: SizeInt read FLength write Set_Length; + property Capacity: SizeInt read GetCapacity write SetCapacity; + property MaxCapacity: SizeInt read FMaxCapacity; + end; + + {$IFDEF RTL200_UP} + TStringBuilder = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.TStringBuilder; + {$ELSE ~RTL200_UP} + TStringBuilder = TJclStringBuilder; + {$ENDIF ~RTL200_UP} + +// DotNetFormat() uses the .NET format style: "{argX}" +function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; + +// TJclTabSet +type + TJclTabSet = class (TInterfacedObject, IToString) + private + FData: TObject; + function GetCount: SizeInt; + function GetStops(Index: SizeInt): SizeInt; + function GetTabWidth: SizeInt; + function GetZeroBased: Boolean; + procedure SetStops(Index, Value: SizeInt); + procedure SetTabWidth(Value: SizeInt); + procedure SetZeroBased(Value: Boolean); + protected + function FindStop(Column: SizeInt): SizeInt; + function InternalTabStops: TDynSizeIntArray; + function InternalTabWidth: SizeInt; + procedure RemoveAt(Index: SizeInt); + public + constructor Create; overload; + constructor Create(Data: TObject); overload; + constructor Create(TabWidth: SizeInt); overload; + constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload; + constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload; + destructor Destroy; override; + + // cloning and referencing + function Clone: TJclTabSet; + function NewReference: TJclTabSet; + + // Tab stops manipulation + function Add(Column: SizeInt): SizeInt; + function Delete(Column: SizeInt): SizeInt; + + // Usage + function Expand(const S: string): string; overload; + function Expand(const S: string; Column: SizeInt): string; overload; + procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); + function Optimize(const S: string): string; overload; + function Optimize(const S: string; Column: SizeInt): string; overload; + function StartColumn: SizeInt; + function TabFrom(Column: SizeInt): SizeInt; + function UpdatePosition(const S: string): SizeInt; overload; + function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload; + function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload; + + { IToString } + function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} + // Conversions + function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload; + class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC} + + // Properties + property ActualTabWidth: SizeInt read InternalTabWidth; + property Count: SizeInt read GetCount; + property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default; + property TabWidth: SizeInt read GetTabWidth write SetTabWidth; + property ZeroBased: Boolean read GetZeroBased write SetZeroBased; + end; + +// Formatting constants +const + TabSetFormatting_SurroundStopsWithBrackets = 1; + TabSetFormatting_EmptyBracketsIfNoStops = 2; + TabSetFormatting_NoTabStops = 4; + TabSetFormatting_NoTabWidth = 8; + TabSetFormatting_AutoTabWidth = 16; + // common combinations + TabSetFormatting_Default = 0; + TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or + TabSetFormatting_EmptyBracketsIfNoStops; + TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth; + // aliases + TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth; + TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops; + TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default; + +// Tab expansion routines +function StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +// Tab optimization routines +function StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; +function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; + +// move to JclBase? +type + NullReferenceException = class(EJclError) + public + constructor Create; overload; + end; + +procedure StrResetLength(var S: WideString); overload; +procedure StrResetLength(var S: AnsiString); overload; +procedure StrResetLength(S: TJclStringBuilder); overload; +{$IFDEF SUPPORTS_UNICODE_STRING} +procedure StrResetLength(var S: UnicodeString); overload; +{$ENDIF SUPPORTS_UNICODE_STRING} + +// natural comparison functions +function CompareNaturalStr(const S1, S2: string): SizeInt; +function CompareNaturalText(const S1, S2: string): SizeInt; + +{$IFNDEF UNICODE_RTL_DATABASE} +// internal structures published to make function inlining working +const + MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set + StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars + StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars + StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars + StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table + +var + StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings + StrCaseMapReady: Boolean = False; // true if case map exists + StrCharTypes: array [Char] of Word; +{$ENDIF ~UNICODE_RTL_DATABASE} + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL$'; + Revision: '$Revision$'; + Date: '$Date$'; + LogPath: 'JCL\source\common'; + Extra: ''; + Data: nil + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + {$IFDEF HAS_UNIT_LIBC} + Libc, + {$ENDIF HAS_UNIT_LIBC} + {$IFDEF SUPPORTS_UNICODE} + {$IFDEF HAS_UNITSCOPE} + System.StrUtils, + {$ELSE ~HAS_UNITSCOPE} + StrUtils, + {$ENDIF ~HAS_UNITSCOPE} + {$ENDIF SUPPORTS_UNICODE} + JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils; + +//=== Internal =============================================================== + +type + TStrRec = packed record + RefCount: Longint; + Length: Longint; + end; + PStrRec = ^TStrRec; + +{$IFNDEF UNICODE_RTL_DATABASE} +procedure LoadCharTypes; +var + CurrChar: Char; + CurrType: Word; +begin + for CurrChar := Low(CurrChar) to High(CurrChar) do + begin + {$IFDEF MSWINDOWS} + CurrType := 0; + GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, CurrType); + {$DEFINE CHAR_TYPES_INITIALIZED} + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + CurrType := 0; + if isupper(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_UPPER; + if islower(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_LOWER; + if isdigit(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_DIGIT; + if isspace(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_SPACE; + if ispunct(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_PUNCT; + if iscntrl(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_CNTRL; + if isblank(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_BLANK; + if isxdigit(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_XDIGIT; + if isalpha(Byte(CurrChar)) <> 0 then + CurrType := CurrType or C1_ALPHA; + {$DEFINE CHAR_TYPES_INITIALIZED} + {$ENDIF LINUX} + StrCharTypes[CurrChar] := CurrType; + {$IFNDEF CHAR_TYPES_INITIALIZED} + Implement case map initialization here + {$ENDIF ~CHAR_TYPES_INITIALIZED} + end; +end; + +procedure LoadCaseMap; +var + CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char; +begin + if not StrCaseMapReady then + begin + for CurrChar := Low(Char) to High(Char) do + begin + {$IFDEF MSWINDOWS} + LoCaseChar := CurrChar; + UpCaseChar := CurrChar; + {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuff(@LoCaseChar, 1); + {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuff(@UpCaseChar, 1); + {$DEFINE CASE_MAP_INITIALIZED} + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + LoCaseChar := Char(tolower(Byte(CurrChar))); + UpCaseChar := Char(toupper(Byte(CurrChar))); + {$DEFINE CASE_MAP_INITIALIZED} + {$ENDIF LINUX} + {$IFNDEF CASE_MAP_INITIALIZED} + Implement case map initialization here + {$ENDIF ~CASE_MAP_INITIALIZED} + if CharIsUpper(CurrChar) then + ReCaseChar := LoCaseChar + else + if CharIsLower(CurrChar) then + ReCaseChar := UpCaseChar + else + ReCaseChar := CurrChar; + StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar; + StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar; + StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar; + end; + StrCaseMapReady := True; + end; +end; + +// Uppercases or Lowercases a give string depending on the +// passed offset. (UpOffset or LoOffset) + +procedure StrCase(var Str: string; const Offset: SizeInt); +var + P: PChar; + I, L: SizeInt; +begin + L := Length(Str); + if L > 0 then + begin + UniqueString(Str); + P := PChar(Str); + for I := 1 to L do + begin + P^ := StrCaseMap[Offset + Ord(P^)]; + Inc(P); + end; + end; +end; + +// Internal utility function +// Uppercases or Lowercases a give null terminated string depending on the +// passed offset. (UpOffset or LoOffset) + +procedure StrCaseBuff(S: PChar; const Offset: SizeInt); +var + C: Char; +begin + if S <> nil then + begin + repeat + C := S^; + S^ := StrCaseMap[Offset + Ord(C)]; + Inc(S); + until C = #0; + end; +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +function StrEndW(Str: PWideChar): PWideChar; +begin + Result := Str; + while Result^ <> #0 do + Inc(Result); +end; + +function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; +var + idx: SizeInt; +begin + Result := ArrayContainsChar(Chars, C, idx); +end; + +function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; +{ optimized version for sorted arrays +var + I, L, H: SizeInt; +begin + L := Low(Chars); + H := High(Chars); + while L <= H do + begin + I := (L + H) div 2; + if C = Chars[I] then + begin + Result := True; + Exit; + end + else + if C < Chars[I] then + H := I - 1 + else + // C > Chars[I] + L := I + 1; + end; + Result := False; +end;} +begin + Index := High(Chars); + while (Index >= Low(Chars)) and (Chars[Index] <> C) do + Dec(Index); + Result := Index >= Low(Chars); +end; + +// String Test Routines +function StrIsAlpha(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsAlpha(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrIsAlphaNum(const S: string): Boolean; +var + I: SizeInt; +begin + Result := S <> ''; + for I := 1 to Length(S) do + begin + if not CharIsAlphaNum(S[I]) then + begin + Result := False; + Exit; + end; + end; +end; + +function StrIsDigit(const S: string): Boolean; +begin + Result := StrConsistsOfDigits(S) +end; + +function StrConsistsOfDigits(const S: string): Boolean; +begin + Result := StrConsistsOfChars(S, CharIsDigit, False); +end; + +function StrConsistsOfNumberChars(const S: string): Boolean; +begin + Result := StrConsistsOfChars(S, CharIsNumberChar, False ); +end; + +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; +var + I: SizeInt; +begin + Result := False; + for I := 1 to Length(Chars) do + if CharPos(S, Chars[I]) <= 0 then exit; + Result := True; +end; + +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; +var + I: SizeInt; +begin + Result := False; + for I := Low(Chars) to High(Chars) do + if CharPos(S, Chars[I]) <= 0 then exit; + Result := True; +end; + +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + if Chars(S[I]) then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, S[I]) then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; +var + I: SizeInt; +begin + for I := 1 to Length(S) do + if CharPos(Chars, S[I]) > 0 then + begin + Result := True; + Exit; + end; + Result := False; +end; + +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if not Chars(S[I]) then Exit; + Result := True; + end; +end; + +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if not ArrayContainsChar(Chars, S[I]) then Exit; + Result := True; + end; +end; + +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean): Boolean; +var + I: SizeInt; +begin + If S = '' then + Result := AllowEmpty + else begin + Result := False; + for I := 1 to Length(S) do + if CharPos(Chars, S[I]) <= 0 then Exit; + Result := True; + end; +end; + + +function StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; +var + I: SizeInt; +begin + Result := False; + if CheckAll then + begin + // this will not work with the current definition of the validator. The validator would need to check each character + // it requires against the string (which is currently not provided to the Validator). The current implementation of + // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon- + // sistent with the documentation and the array-based overload. + for I := 1 to Length(S) do + begin + Result := Chars(S[I]); + if not Result then + Break; + end; + end + else + begin + for I := 1 to Length(S) do + begin + Result := Chars(S[I]); + if Result then + Break; + end; + end; +end; + +function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; +var + I: SizeInt; +begin + if CheckAll then + begin + Result := True; + I := High(Chars); + while (I >= 0) and Result do + begin + Result := CharPos(S, Chars[I]) > 0; + Dec(I); + end; + end + else + begin + Result := False; + for I := 1 to Length(S) do + begin + Result := ArrayContainsChar(Chars, S[I]); + if Result then + Break; + end; + end; +end; + +function StrIsAlphaNumUnderscore(const S: string): Boolean; +var + I: SizeInt; + C: Char; +begin + for I := 1 to Length(S) do + begin + C := S[I]; + + if not (CharIsAlphaNum(C) or (C = '_')) then + begin + Result := False; + Exit; + end; + end; + + Result := Length(S) > 0; +end; + +function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; +//var +// I: SizeInt; +begin + Result := StrConsistsOfChars(S, ValidChars, False); +// for I := 1 to Length(S) do +// begin +// Result := ValidChars(S[I]); +// if not Result then +// Exit; +// end; +// +// Result := Length(S) > 0; +end; + +function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; +//var +// I: SizeInt; +begin + Result := StrConsistsOfChars(S, ValidChars, False); +// for I := 1 to Length(S) do +// begin +// Result := ArrayContainsChar(ValidChars, S[I]); +// if not Result then +// Exit; +// end; +// +// Result := Length(S) > 0; +end; + +function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; +begin + Result := StrCompare(S1, S2, CaseSensitive) = 0; +end; + +//=== String Transformation Routines ========================================= + +function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; +begin + if Length(S) < L then + begin + Result := StringOfChar(C, (L - Length(S)) div 2) + S; + Result := Result + StringOfChar(C, L - Length(Result)); + end + else + Result := S; +end; + +function StrCharPosLower(const S: string; CharPos: SizeInt): string; +begin + Result := S; + if (CharPos > 0) and (CharPos <= Length(S)) then + Result[CharPos] := CharLower(Result[CharPos]); +end; + +function StrCharPosUpper(const S: string; CharPos: SizeInt): string; +begin + Result := S; + if (CharPos > 0) and (CharPos <= Length(S)) then + Result[CharPos] := CharUpper(Result[CharPos]); +end; + +function StrDoubleQuote(const S: string): string; +begin + Result := NativeDoubleQuote + S + NativeDoubleQuote; +end; + +function StrEnsureNoPrefix(const Prefix, Text: string): string; +var + PrefixLen: SizeInt; +begin + PrefixLen := Length(Prefix); + if Copy(Text, 1, PrefixLen) = Prefix then + Result := Copy(Text, PrefixLen + 1, Length(Text)) + else + Result := Text; +end; + +function StrEnsureNoSuffix(const Suffix, Text: string): string; +var + SuffixLen: SizeInt; + StrLength: SizeInt; +begin + SuffixLen := Length(Suffix); + StrLength := Length(Text); + if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then + Result := Copy(Text, 1, StrLength - SuffixLen) + else + Result := Text; +end; + +function StrEnsurePrefix(const Prefix, Text: string): string; +var + PrefixLen: SizeInt; +begin + PrefixLen := Length(Prefix); + if Copy(Text, 1, PrefixLen) = Prefix then + Result := Text + else + Result := Prefix + Text; +end; + +function StrEnsureSuffix(const Suffix, Text: string): string; +var + SuffixLen: SizeInt; +begin + SuffixLen := Length(Suffix); + if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then + Result := Text + else + Result := Text + Suffix; +end; + +function StrEscapedToString(const S: string): string; + procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); + const + HexDigits = string('0123456789abcdefABCDEF'); + var + StartI, Val, N: SizeInt; + begin + StartI := I; + N := Pos(S[I + 1], HexDigits) - 1; + if N < 0 then + // '\x' without hex digit following is not escape sequence + Dest := Dest + '\x' + else + begin + Inc(I); // Jump over x + if N >= 16 then + N := N - 6; + Val := N; + // Same for second digit + if I < Len then + begin + N := Pos(S[I + 1], HexDigits) - 1; + if N >= 0 then + begin + Inc(I); // Jump over first digit + if N >= 16 then + N := N - 6; + Val := Val * 16 + N; + end; + end; + + if Val > Ord(High(Char)) then + raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); + + Dest := Dest + Char(Val); + end; + end; + + procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); + const + OctDigits = string('01234567'); + var + StartI, Val, N: SizeInt; + begin + StartI := I; + // first digit + Val := Pos(S[I], OctDigits) - 1; + if I < Len then + begin + N := Pos(S[I + 1], OctDigits) - 1; + if N >= 0 then + begin + Inc(I); + Val := Val * 8 + N; + end; + if I < Len then + begin + N := Pos(S[I + 1], OctDigits) - 1; + if N >= 0 then + begin + Inc(I); + Val := Val * 8 + N; + end; + end; + end; + + if Val > Ord(High(Char)) then + raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); + + Dest := Dest + Char(Val); + end; + +var + I, Len: SizeInt; +begin + Result := ''; + I := 1; + Len := Length(S); + while I <= Len do + begin + if not ((S[I] = '\') and (I < Len)) then + Result := Result + S[I] + else + begin + Inc(I); // Jump over escape character + case S[I] of + 'a': + Result := Result + NativeBell; + 'b': + Result := Result + NativeBackspace; + 'f': + Result := Result + NativeFormFeed; + 'n': + Result := Result + NativeLineFeed; + 'r': + Result := Result + NativeCarriageReturn; + 't': + Result := Result + NativeTab; + 'v': + Result := Result + NativeVerticalTab; + '\': + Result := Result + '\'; + '"': + Result := Result + '"'; + '''': + Result := Result + ''''; // Optionally escaped + '?': + Result := Result + '?'; // Optionally escaped + 'x': + if I < Len then + // Start of hex escape sequence + HandleHexEscapeSeq(S, I, Len, Result) + else + // '\x' at end of string is not escape sequence + Result := Result + '\x'; + '0'..'7': + // start of octal escape sequence + HandleOctEscapeSeq(S, I, Len, Result); + else + // no escape sequence + Result := Result + '\' + S[I]; + end; + end; + Inc(I); + end; +end; + +function StrLower(const S: string): string; +begin + Result := S; + StrLowerInPlace(Result); +end; + +procedure StrLowerInPlace(var S: string); +{$IFDEF UNICODE_RTL_DATABASE} +var + P: PChar; + I, L: SizeInt; +begin + L := Length(S); + if L > 0 then + begin + UniqueString(S); + P := PChar(S); + for I := 1 to L do + begin + P^ := TCharacter.ToLower(P^); + Inc(P); + end; + end; +end; +{$ELSE ~UNICODE_RTL_DATABASE} +begin + StrCase(S, StrLoOffset); +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +procedure StrLowerBuff(S: PChar); +begin + {$IFDEF UNICODE_RTL_DATABASE} + if S <> nil then + begin + repeat + S^ := TCharacter.ToLower(S^); + Inc(S); + until S^ = #0; + end; + {$ELSE ~UNICODE_RTL_DATABASE} + StrCaseBuff(S, StrLoOffset); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +procedure StrMove(var Dest: string; const Source: string; + const ToIndex, FromIndex, Count: SizeInt); +begin + // Check strings + if (Source = '') or (Length(Dest) = 0) then + Exit; + + // Check FromIndex + if (FromIndex <= 0) or (FromIndex > Length(Source)) or + (ToIndex <= 0) or (ToIndex > Length(Dest)) or + ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then + { TODO : Is failure without notice the proper thing to do here? } + Exit; + + // Move + Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char)); +end; + +function StrPadLeft(const S: string; Len: SizeInt; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + if L < Len then + Result := StringOfChar(C, Len - L) + S + else + Result := S; +end; + +function StrPadRight(const S: string; Len: SizeInt; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + if L < Len then + Result := S + StringOfChar(C, Len - L) + else + Result := S; +end; + +function StrProper(const S: string): string; +begin + Result := StrLower(S); + if Result <> '' then + Result[1] := UpCase(Result[1]); +end; + +procedure StrProperBuff(S: PChar); +begin + if (S <> nil) and (S^ <> #0) then + begin + StrLowerBuff(S); + S^ := CharUpper(S^); + end; +end; + +function StrQuote(const S: string; C: Char): string; +var + L: SizeInt; +begin + L := Length(S); + Result := S; + if L > 0 then + begin + if Result[1] <> C then + begin + Result := C + Result; + Inc(L); + end; + if Result[L] <> C then + Result := Result + C; + end; +end; + +function StrRemoveChars(const S: string; const Chars: TCharValidator): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if not Chars(Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRemoveChars(const S: string; const Chars: array of Char): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if not ArrayContainsChar(Chars, Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; +var + Len : SizeInt; + I: SizeInt; +begin + Len := Length(S); + I := 1; + while (I <= Len) and Chars(s[I]) do + Inc(I); + Result := Copy (s, I, Len-I+1); +end; + +function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; +var + Len : SizeInt; + I: SizeInt; +begin + Len := Length(S); + I := 1; + while (I <= Len) and ArrayContainsChar(Chars, s[I]) do + Inc(I); + Result := Copy (s, I, Len-I+1); +end; + +function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; +var + Len : SizeInt; +begin + Len := Length(S); + while (Len > 0) and Chars(s[Len]) do + Dec(Len); + Result := Copy (s, 1, Len); +end; + +function StrRemoveEndChars(const S: string; const Chars: array of Char): string; +var + Len : SizeInt; +begin + Len := Length(S); + while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do + Dec(Len); + Result := Copy (s, 1, Len); +end; + +function StrKeepChars(const S: string; const Chars: TCharValidator): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if Chars(Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrKeepChars(const S: string; const Chars: array of Char): string; +var + Source, Dest: PChar; + Len, Index: SizeInt; +begin + Len := Length(S); + SetLength(Result, Len); + UniqueString(Result); + Source := PChar(S); + Dest := PChar(Result); + for Index := 0 to Len - 1 do + begin + if ArrayContainsChar(Chars, Source^) then + begin + Dest^ := Source^; + Inc(Dest); + end; + Inc(Source); + end; + SetLength(Result, Dest - PChar(Result)); +end; + +function StrRepeat(const S: string; Count: SizeInt): string; +var + Len, Index: SizeInt; + Dest, Source: PChar; +begin + Len := Length(S); + SetLength(Result, Count * Len); + Dest := PChar(Result); + Source := PChar(S); + if Dest <> nil then + for Index := 0 to Count - 1 do + begin + Move(Source^, Dest^, Len * SizeOf(Char)); + Inc(Dest, Len); + end; +end; + +function StrRepeatLength(const S: string; L: SizeInt): string; +var + Len: SizeInt; + Dest: PChar; +begin + Result := ''; + Len := Length(S); + + if (Len > 0) and (S <> '') then + begin + SetLength(Result, L); + Dest := PChar(Result); + while (L > 0) do + begin + Move(S[1], Dest^, Min(L, Len) * SizeOf(Char)); + Inc(Dest, Len); + Dec(L, Len); + end; + end; +end; + +procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags); +var + SearchStr: string; + ResultStr: string; { result string } + SourcePtr: PChar; { pointer into S of character under examination } + SourceMatchPtr: PChar; { pointers into S and Search when first character has } + SearchMatchPtr: PChar; { been matched and we're probing for a complete match } + ResultPtr: PChar; { pointer into Result of character being written } + ResultIndex, + SearchLength, { length of search string } + ReplaceLength, { length of replace string } + BufferLength, { length of temporary result buffer } + ResultLength: SizeInt; { length of result string } + C: Char; { first character of search string } + IgnoreCase: Boolean; +begin + if Search = '' then + begin + if S = '' then + begin + S := Replace; + Exit; + end + else + raise EJclStringError.CreateRes(@RsBlankSearchString); + end; + + if S <> '' then + begin + IgnoreCase := rfIgnoreCase in Flags; + if IgnoreCase then + SearchStr := StrUpper(Search) + else + SearchStr := Search; + { avoid having to call Length() within the loop } + SearchLength := Length(Search); + ReplaceLength := Length(Replace); + ResultLength := Length(S); + BufferLength := ResultLength; + SetLength(ResultStr, BufferLength); + { get pointers to begin of source and result } + ResultPtr := PChar(ResultStr); + SourcePtr := PChar(S); + C := SearchStr[1]; + { while we haven't reached the end of the string } + while True do + begin + { copy characters until we find the first character of the search string } + if IgnoreCase then + while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end + else + while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + { did we find that first character or did we hit the end of the string? } + if SourcePtr^ = #0 then + Break + else + begin + { continue comparing, +1 because first character was matched already } + SourceMatchPtr := SourcePtr + 1; + SearchMatchPtr := PChar(SearchStr) + 1; + if IgnoreCase then + while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do + begin + Inc(SourceMatchPtr); + Inc(SearchMatchPtr); + end + else + while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do + begin + Inc(SourceMatchPtr); + Inc(SearchMatchPtr); + end; + { did we find a complete match? } + if SearchMatchPtr^ = #0 then + begin + // keep track of result length + Inc(ResultLength, ReplaceLength - SearchLength); + if ReplaceLength > 0 then + begin + // increase buffer size if required + if ResultLength > BufferLength then + begin + BufferLength := ResultLength * 2; + ResultIndex := ResultPtr - PChar(ResultStr) + 1; + SetLength(ResultStr, BufferLength); + ResultPtr := @ResultStr[ResultIndex]; + end; + { append replace to result and move past the search string in source } + Move((@Replace[1])^, ResultPtr^, ReplaceLength * SizeOf(Char)); + end; + Inc(SourcePtr, SearchLength); + Inc(ResultPtr, ReplaceLength); + { replace all instances or just one? } + if not (rfReplaceAll in Flags) then + begin + { just one, copy until end of source and break out of loop } + while SourcePtr^ <> #0 do + begin + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + Break; + end; + end + else + begin + { copy current character and start over with the next } + ResultPtr^ := SourcePtr^; + Inc(ResultPtr); + Inc(SourcePtr); + end; + end; + end; + { set result length and copy result into S } + SetLength(ResultStr, ResultLength); + S := ResultStr; + end; +end; + +function StrReplaceChar(const S: string; const Source, Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if Result[I] = Source then + Result[I] := Replace; +end; + +function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if Chars(Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceButChars(const S: string; const Chars: TCharValidator; + Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if not Chars(Result[I]) then + Result[I] := Replace; +end; + +function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; +var + I: SizeInt; +begin + Result := S; + for I := 1 to Length(S) do + if not ArrayContainsChar(Chars, Result[I]) then + Result[I] := Replace; +end; + +function StrReverse(const S: string): string; +begin + Result := S; + StrReverseInplace(Result); +end; + +procedure StrReverseInPlace(var S: string); +{ TODO -oahuser : Warning: This is dangerous for unicode surrogates } +var + P1, P2: PChar; + C: Char; +begin + UniqueString(S); + P1 := PChar(S); + P2 := P1 + (Length(S) - 1); + while P1 < P2 do + begin + C := P1^; + P1^ := P2^; + P2^ := C; + Inc(P1); + Dec(P2); + end; +end; + +function StrSingleQuote(const S: string): string; +begin + Result := NativeSingleQuote + S + NativeSingleQuote; +end; + +procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); +begin + while Chars(S^) do + Inc(S); +end; + +procedure StrSkipChars(var S: PChar; const Chars: array of Char); +begin + while ArrayContainsChar(Chars, S^) do + Inc(S); +end; + +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); +begin + while Chars(S[Index]) do + Inc(Index); +end; + +procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); +begin + while ArrayContainsChar(Chars, S[Index]) do + Inc(Index); +end; + +function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; +var + Source, Dest: PChar; + Index, Len: SizeInt; + InternalDelimiters: TCharValidator; +begin + Result := ''; + if Assigned(Delimiters) then + InternalDelimiters := Delimiters + else + InternalDelimiters := CharIsSpace; + + if S <> '' then + begin + Result := S; + UniqueString(Result); + + Len := Length(S); + Source := PChar(S); + Dest := PChar(Result); + Inc(Dest); + + for Index := 2 to Len do + begin + if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then + Dest^ := CharUpper(Dest^); + Inc(Dest); + Inc(Source); + end; + Result[1] := CharUpper(Result[1]); + end; +end; + +function StrSmartCase(const S: string; const Delimiters: array of Char): string; +var + Source, Dest: PChar; + Index, Len: SizeInt; +begin + Result := ''; + + if S <> '' then + begin + Result := S; + UniqueString(Result); + + Len := Length(S); + Source := PChar(S); + Dest := PChar(Result); + Inc(Dest); + + for Index := 2 to Len do + begin + if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then + Dest^ := CharUpper(Dest^); + Inc(Dest); + Inc(Source); + end; + Result[1] := CharUpper(Result[1]); + end; +end; + +function StrStringToEscaped(const S: string): string; +var + I: SizeInt; +begin + Result := ''; + for I := 1 to Length(S) do + begin + case S[I] of + NativeBackspace: + Result := Result + '\b'; + NativeBell: + Result := Result + '\a'; + NativeCarriageReturn: + Result := Result + '\r'; + NAtiveFormFeed: + Result := Result + '\f'; + NativeLineFeed: + Result := Result + '\n'; + NativeTab: + Result := Result + '\t'; + NativeVerticalTab: + Result := Result + '\v'; + NativeBackSlash: + Result := Result + '\\'; + NativeDoubleQuote: + Result := Result + '\"'; + else + // Characters < ' ' are escaped with hex sequence + if S[I] < #32 then + Result := Result + Format('\x%.2x', [SizeInt(S[I])]) + else + Result := Result + S[I]; + end; + end; +end; + +function StrStripNonNumberChars(const S: string): string; +var + I: SizeInt; + C: Char; +begin + Result := ''; + for I := 1 to Length(S) do + begin + C := S[I]; + if CharIsNumberChar(C) then + Result := Result + C; + end; +end; + +function StrToHex(const Source: string): AnsiString; +var + Index: SizeInt; + C, L, N: SizeInt; + BL, BH: Byte; + S: string; +begin + Result := ''; + if Source <> '' then + begin + S := Source; + L := Length(S); + if Odd(L) then + begin + S := '0' + S; + Inc(L); + end; + Index := 1; + SetLength(Result, L div 2); + C := 1; + N := 1; + while C <= L do + begin + BH := CharHex(S[Index]); + Inc(Index); + BL := CharHex(S[Index]); + Inc(Index); + Inc(C, 2); + if (BH = $FF) or (BL = $FF) then + begin + Result := ''; + Exit; + end; + Result[N] := AnsiChar((BH shl 4) or BL); + Inc(N); + end; + end; +end; + +function StrTrimCharLeft(const S: string; C: Char): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and (S[I] = C) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and Chars(S[I]) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; +var + I, L: SizeInt; +begin + I := 1; + L := Length(S); + while (I <= L) and ArrayContainsChar(Chars, S[I]) do + Inc(I); + Result := Copy(S, I, L - I + 1); +end; + +function StrTrimCharRight(const S: string; C: Char): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and (S[I] = C) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and Chars(S[I]) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimCharsRight(const S: string; const Chars: array of Char): string; +var + I: SizeInt; +begin + I := Length(S); + while (I >= 1) and ArrayContainsChar(Chars, S[I]) do + Dec(I); + Result := Copy(S, 1, I); +end; + +function StrTrimQuotes(const S: string): string; +var + First, Last: Char; + L: SizeInt; +begin + L := Length(S); + if L > 1 then + begin + First := S[1]; + Last := S[L]; + if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) then + Result := Copy(S, 2, L - 2) + else + Result := S; + end + else + Result := S; +end; + +function StrUpper(const S: string): string; +begin + Result := S; + StrUpperInPlace(Result); +end; + +procedure StrUpperInPlace(var S: string); +{$IFDEF UNICODE_RTL_DATABASE} +var + P: PChar; + I, L: SizeInt; +begin + L := Length(S); + if L > 0 then + begin + UniqueString(S); + P := PChar(S); + for I := 1 to L do + begin + P^ := TCharacter.ToUpper(P^); + Inc(P); + end; + end; +end; +{$ELSE ~UNICODE_RTL_DATABASE} +begin + StrCase(S, StrUpOffset); +end; +{$ENDIF ~UNICODE_RTL_DATABASE} + +procedure StrUpperBuff(S: PChar); +begin + {$IFDEF UNICODE_RTL_DATABASE} + if S <> nil then + begin + repeat + S^ := TCharacter.ToUpper(S^); + Inc(S); + until S^ = #0; + end; + {$ELSE ~UNICODE_RTL_DATABASE} + StrCaseBuff(S, StrUpOffset); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== String Management ====================================================== + +procedure StrAddRef(var S: string); +var + P: PStrRec; +begin + P := Pointer(S); + if P <> nil then + begin + Dec(P); + if P^.RefCount = -1 then + UniqueString(S) + else + LockedInc(P^.RefCount); + end; +end; + +procedure StrDecRef(var S: string); +var + P: PStrRec; +begin + P := Pointer(S); + if P <> nil then + begin + Dec(P); + case P^.RefCount of + -1, 0: { nothing } ; + 1: + begin + Finalize(S); + Pointer(S) := nil; + end; + else + LockedDec(P^.RefCount); + end; + end; +end; + +function StrLength(const S: string): SizeInt; +var + P: PStrRec; +begin + Result := 0; + P := Pointer(S); + if P <> nil then + begin + Dec(P); + Result := P^.Length and (not $80000000 shr 1); + end; +end; + +function StrRefCount(const S: string): SizeInt; +var + P: PStrRec; +begin + Result := 0; + P := Pointer(S); + if P <> nil then + begin + Dec(P); + Result := P^.RefCount; + end; +end; + +procedure StrResetLength(var S: WideString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; + +procedure StrResetLength(var S: AnsiString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; + +procedure StrResetLength(S: TJclStringBuilder); +var + I: SizeInt; +begin + if S <> nil then + for I := 0 to S.Length - 1 do + if S[I] = #0 then + begin + S.Length := I; + Exit; + end; +end; + +{$IFDEF SUPPORTS_UNICODE_STRING} +procedure StrResetLength(var S: UnicodeString); +var + I: SizeInt; +begin + for I := 0 to Length(S) - 1 do + if S[I + 1] = #0 then + begin + SetLength(S, I); + Exit; + end; +end; +{$ENDIF SUPPORTS_UNICODE_STRING} + +//=== String Search and Replace Routines ===================================== + +function StrCharCount(const S: string; C: Char): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if S[I] = C then + Inc(Result); +end; + +function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if Chars(S[I]) then + Inc(Result); +end; + +function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; +var + I: SizeInt; +begin + Result := 0; + for I := 1 to Length(S) do + if ArrayContainsChar(Chars, S[I]) then + Inc(Result); +end; + +function StrStrCount(const S, SubS: string): SizeInt; +var + I: SizeInt; +begin + Result := 0; + if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then + Exit; + if Length(SubS) = 1 then + begin + Result := StrCharCount(S, SubS[1]); + Exit; + end; + I := StrSearch(SubS, S, 1); + + if I > 0 then + Inc(Result); + + while (I > 0) and (Length(S) > I + Length(SubS)) do + begin + I := StrSearch(SubS, S, I + 1); + + if I > 0 then + Inc(Result); + end; +end; + +(* +{ 1} Test(StrCompareRange('', '', 1, 5), 0); +{ 2} Test(StrCompareRange('A', '', 1, 5), -1); +{ 3} Test(StrCompareRange('AB', '', 1, 5), -1); +{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1); +{ 5} Test(StrCompareRange('', 'A', 1, 5), -1); +{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1); +{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1); +{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2); +{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32); +{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0); +{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1); +{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1); +{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32); +{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32); +{15} Test(StrCompareRange('', '', 1, 0), 0); +{16} Test(StrCompareRange('A', 'A', 1, 0), -2); +{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2); +{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0); +{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0); +{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1); +*) +function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +var + Len1, Len2: SizeInt; + I: SizeInt; + C1, C2: Char; +begin + if Pointer(S1) = Pointer(S2) then + begin + if (Count <= 0) and (S1 <> '') then + Result := -2 // no work + else + Result := 0; + end + else + if (S1 = '') or (S2 = '') then + Result := -1 // null string + else + if Count <= 0 then + Result := -2 // no work + else + begin + Len1 := Length(S1); + Len2 := Length(S2); + + if (Index - 1) + Count > Len1 then + Result := -2 + else + begin + if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it + Count := Len2 - (Index - 1); + + if CaseSensitive then + begin + for I := 0 to Count - 1 do + begin + C1 := S1[Index + I]; + C2 := S2[Index + I]; + if C1 <> C2 then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + end; + end + else + begin + for I := 0 to Count - 1 do + begin + C1 := S1[Index + I]; + C2 := S2[Index + I]; + if C1 <> C2 then + begin + C1 := CharLower(C1); + C2 := CharLower(C2); + if C1 <> C2 then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + end; + end; + end; + Result := 0; + end; + end; +end; + +function StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt; +var + Len1, Len2: SizeInt; +begin + if Pointer(S1) = Pointer(S2) then + Result := 0 + else + begin + Len1 := Length(S1); + Len2 := Length(S2); + Result := Len1 - Len2; + if Result = 0 then + Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive); + end; +end; + +function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; +begin + Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive); +end; + +procedure StrFillChar(var S; Count: SizeInt; C: Char); +{$IFDEF SUPPORTS_UNICODE} +asm + // 32 --> EAX S + // EDX Count + // ECX C + // 64 --> RCX S + // RDX Count + // R8W C + {$IFDEF CPU32} + DEC EDX + JS @@Leave +@@Loop: + MOV [EAX], CX + ADD EAX, 2 + DEC EDX + JNS @@Loop + {$ENDIF CPU32} + {$IFDEF CPU64} + DEC RDX + JS @@Leave +@@Loop: + MOV WORD PTR [RCX], R8W + ADD RCX, 2 + DEC RDX + JNS @@Loop + {$ENDIF CPU64} +@@Leave: +end; +{$ELSE ~SUPPORTS_UNICODE} +begin + if Count > 0 then + FillChar(S, Count, C); +end; +{$ENDIF ~SUPPORTS_UNICODE} + +function StrRepeatChar(C: Char; Count: SizeInt): string; +begin + SetLength(Result, Count); + if Count > 0 then + StrFillChar(Result[1], Count, C); +end; + +function StrFind(const Substr, S: string; const Index: SizeInt): SizeInt; +var + pos: SizeInt; +begin + if (SubStr <> '') and (S <> '') then + begin + pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1)); + if pos = 0 then + Result := 0 + else + Result := Index + Pos - 1; + end + else + Result := 0; +end; + +function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; +begin + Result := StrPrefixIndex(S, Prefixes) > -1; +end; + +function StrHasSuffix(const S: string; const Suffixes: array of string): Boolean; +begin + Result := StrSuffixIndex(S, Suffixes) > -1; +end; + +function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean): SizeInt; +var + I: SizeInt; +begin + Result := -1; + for I := Low(List) to High(List) do + begin + if StrCompare(S, List[I], CaseSensitive) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; +begin + Result := StrIPrefixIndex(S, Prefixes) > -1; +end; + +function StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean; +begin + Result := StrISuffixIndex(S, Suffixes) > -1; +end; + +function StrILastPos(const SubStr, S: string): SizeInt; +begin + Result := StrLastPos(StrUpper(SubStr), StrUpper(S)); +end; + +function StrIPos(const SubStr, S: string): SizeInt; +begin + Result := Pos(StrUpper(SubStr), StrUpper(S)); +end; + +function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Prefixes) to High(Prefixes) do + begin + Test := StrLeft(S, Length(Prefixes[I])); + if CompareText(Test, Prefixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrIsOneOf(const S: string; const List: array of string): Boolean; +begin + Result := StrIndex(S, List) > -1; +end; + +function StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Suffixes) to High(Suffixes) do + begin + Test := StrRight(S, Length(Suffixes[I])); + if CompareText(Test, Suffixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrLastPos(const SubStr, S: string): SizeInt; +var + Last, Current: PChar; +begin + Result := 0; + Last := nil; + Current := PChar(S); + + while (Current <> nil) and (Current^ <> #0) do + begin + Current := StrPos(PChar(Current), PChar(SubStr)); + if Current <> nil then + begin + Last := Current; + Inc(Current); + end; + end; + if Last <> nil then + Result := Abs(PChar(S) - Last) + 1; +end; + +// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*) +// (*) acts like (?) + +function StrMatch(const Substr, S: string; Index: SizeInt): SizeInt; +var + SI, SubI, SLen, SubLen: SizeInt; + SubC: Char; +begin + SLen := Length(S); + SubLen := Length(Substr); + Result := 0; + if (Index > SLen) or (SubLen = 0) then + Exit; + while Index <= SLen do + begin + SubI := 1; + SI := Index; + while (SI <= SLen) and (SubI <= SubLen) do + begin + SubC := Substr[SubI]; + if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then + begin + Inc(SI); + Inc(SubI); + end + else + Break; + end; + if SubI > SubLen then + begin + Result := Index; + Break; + end; + Inc(Index); + end; +end; + +// Derived from "Like" by Michael Winter +function StrMatches(const Substr, S: string; const Index: SizeInt): Boolean; +var + StringPtr: PChar; + PatternPtr: PChar; + StringRes: PChar; + PatternRes: PChar; +begin + if SubStr = '' then + raise EJclStringError.CreateRes(@RsBlankSearchString); + + Result := SubStr = '*'; + + if Result or (S = '') then + Exit; + + if (Index <= 0) or (Index > Length(S)) then + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + + StringPtr := PChar(@S[Index]); + PatternPtr := PChar(SubStr); + StringRes := nil; + PatternRes := nil; + + repeat + repeat + case PatternPtr^ of + #0: + begin + Result := StringPtr^ = #0; + if Result or (StringRes = nil) or (PatternRes = nil) then + Exit; + + StringPtr := StringRes; + PatternPtr := PatternRes; + Break; + end; + '*': + begin + Inc(PatternPtr); + PatternRes := PatternPtr; + Break; + end; + '?': + begin + if StringPtr^ = #0 then + Exit; + Inc(StringPtr); + Inc(PatternPtr); + end; + else + begin + if StringPtr^ = #0 then + Exit; + if StringPtr^ <> PatternPtr^ then + begin + if (StringRes = nil) or (PatternRes = nil) then + Exit; + StringPtr := StringRes; + PatternPtr := PatternRes; + Break; + end + else + begin + Inc(StringPtr); + Inc(PatternPtr); + end; + end; + end; + until False; + + repeat + case PatternPtr^ of + #0: + begin + Result := True; + Exit; + end; + '*': + begin + Inc(PatternPtr); + PatternRes := PatternPtr; + end; + '?': + begin + if StringPtr^ = #0 then + Exit; + Inc(StringPtr); + Inc(PatternPtr); + end; + else + begin + repeat + if StringPtr^ = #0 then + Exit; + if StringPtr^ = PatternPtr^ then + Break; + Inc(StringPtr); + until False; + Inc(StringPtr); + StringRes := StringPtr; + Inc(PatternPtr); + Break; + end; + end; + until False; + until False; +end; + +function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; +var + I, P: SizeInt; +begin + if N < 1 then + begin + Result := 0; + Exit; + end; + + Result := StrSearch(SubStr, S, 1); + I := 1; + while I < N do + begin + P := StrSearch(SubStr, S, Result + 1); + if P = 0 then + begin + Result := 0; + Break; + end + else + begin + Result := P; + Inc(I); + end; + end; +end; + +function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; +var + I, P: SizeInt; +begin + if N < 1 then + begin + Result := 0; + Exit; + end; + + Result := StrFind(SubStr, S, 1); + I := 1; + while I < N do + begin + P := StrFind(SubStr, S, Result + 1); + if P = 0 then + begin + Result := 0; + Break; + end + else + begin + Result := P; + Inc(I); + end; + end; +end; + +function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Prefixes) to High(Prefixes) do + begin + Test := StrLeft(S, Length(Prefixes[I])); + if CompareStr(Test, Prefixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +function StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt; +var + SP, SPI, SubP: PChar; + SLen: SizeInt; +begin + SLen := Length(S); + if Index <= SLen then + begin + SP := PChar(S); + SubP := PChar(Substr); + SPI := SP; + Inc(SPI, Index); + Dec(SPI); + SPI := StrPos(SPI, SubP); + if SPI <> nil then + Result := SPI - SP + 1 + else + Result := 0; + end + else + Result := 0; +end; + +function StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt; +var + I: SizeInt; + Test: string; +begin + Result := -1; + for I := Low(Suffixes) to High(Suffixes) do + begin + Test := StrRight(S, Length(Suffixes[I])); + if CompareStr(Test, Suffixes[I]) = 0 then + begin + Result := I; + Break; + end; + end; +end; + +//=== String Extraction ====================================================== + +function StrAfter(const SubStr, S: string): string; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos + if P <= 0 then + Result := '' // substr not found -> nothing after it + else + Result := StrRestOf(S, P + Length(SubStr)); +end; + +function StrBefore(const SubStr, S: string): string; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); + if P <= 0 then + Result := S + else + Result := StrLeft(S, P - 1); +end; + +function StrSplit(const SubStr, S: string;var Left, Right : string): boolean; +var + P: SizeInt; +begin + P := StrFind(SubStr, S, 1); + Result:= p > 0; + if Result then + begin + Left := StrLeft(S, P - 1); + Right := StrRestOf(S, P + Length(SubStr)); + end + else + begin + Left := ''; + Right := ''; + end; +end; + +function StrBetween(const S: string; const Start, Stop: Char): string; +var + PosStart, PosEnd: SizeInt; + L: SizeInt; +begin + PosStart := Pos(Start, S); + PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart. + + if (PosStart > 0) and (PosEnd > PosStart) then + begin + L := PosEnd - PosStart; + Result := Copy(S, PosStart + 1, L - 1); + end + else + Result := ''; +end; + +function StrChopRight(const S: string; N: SizeInt): string; +begin + Result := Copy(S, 1, Length(S) - N); +end; + +function StrLeft(const S: string; Count: SizeInt): string; +begin + Result := Copy(S, 1, Count); +end; + +function StrMid(const S: string; Start, Count: SizeInt): string; +begin + Result := Copy(S, Start, Count); +end; + +function StrRestOf(const S: string; N: SizeInt): string; +begin + Result := Copy(S, N, (Length(S) - N + 1)); +end; + +function StrRight(const S: string; Count: SizeInt): string; +begin + Result := Copy(S, Length(S) - Count + 1, Count); +end; + +//=== Character (do we have it ;) ============================================ + +function CharEqualNoCase(const C1, C2: Char): Boolean; +begin + //if they are not equal chars, may be same letter different case + Result := (C1 = C2) or + (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2))); +end; + + +function CharIsAlpha(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLetter(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_ALPHA) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsAlphaNum(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLetterOrDigit(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsBlank(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx + Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_BLANK) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsControl(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsControl(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_CNTRL) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsDelete(const C: Char): Boolean; +begin + Result := (C = #8); +end; + +function CharIsDigit(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsDigit(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_DIGIT) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsFracDigit(const C: Char): Boolean; +begin + Result := (C = '.') or CharIsDigit(C); +end; + +function CharIsHexDigit(const C: Char): Boolean; +begin + case C of + 'A'..'F', + 'a'..'f': + Result := True; + else + Result := CharIsDigit(C); + end; +end; + +function CharIsLower(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsLower(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_LOWER) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsNumberChar(const C: Char): Boolean; +begin + Result := CharIsDigit(C) or (C = '+') or (C = '-') + or ((C <> #0) and (C = JclFormatSettings.DecimalSeparator)) + or ((C <> #0) and (C = JclFormatSettings.ThousandSeparator)); + // #0 is a special value to 'disable' xxxxSeparator, semantically similar to empty string +end; + +function CharIsNumber(const C: Char): Boolean; +begin + Result := CharIsDigit(C) or (C = JclFormatSettings.DecimalSeparator); +end; + +function CharIsPrintable(const C: Char): Boolean; +begin + Result := not CharIsControl(C); +end; + +function CharIsPunctuation(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsPunctuation(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := ((StrCharTypes[C] and C1_PUNCT) <> 0); + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsReturn(const C: Char): Boolean; +begin + Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); +end; + +function CharIsSpace(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsWhiteSpace(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_SPACE) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsUpper(const C: Char): Boolean; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.IsUpper(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := (StrCharTypes[C] and C1_UPPER) <> 0; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharIsValidIdentifierLetter(const C: Char): Boolean; +begin + case C of + {$IFDEF SUPPORTS_UNICODE} + // from XML specifications + #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D, + #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF, + #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs? + #$00B7, #$0300..#$036F, #$203F..#$2040, + {$ENDIF SUPPORTS_UNICODE} + '0'..'9', 'A'..'Z', 'a'..'z', '_': + Result := True; + else + Result := False; + end; +end; + +function CharIsWhiteSpace(const C: Char): Boolean; +begin + case C of + NativeTab, + NativeLineFeed, + NativeVerticalTab, + NativeFormFeed, + NativeCarriageReturn, + NativeSpace: + Result := True; + else + Result := False; + end; +end; + +function CharIsWildcard(const C: Char): Boolean; +begin + case C of + '*', '?': + Result := True; + else + Result := False; + end; +end; + +function CharType(const C: Char): Word; +begin + {$IFDEF UNICODE_RTL_DATABASE} + GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCharTypes[C]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== PCharVector ============================================================ + +function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; +var + I: SizeInt; + S: string; + List: array of PChar; +begin + Assert(Source <> nil); + Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar)); + SetLength(List, Source.Count + SizeOf(Char)); + for I := 0 to Source.Count - 1 do + begin + S := Source[I]; + List[I] := StrAlloc(Length(S) + SizeOf(Char)); + StrPCopy(List[I], S); + end; + List[Source.Count] := nil; + Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar)); + Result := Dest; +end; + +function PCharVectorCount(Source: PCharVector): SizeInt; +begin + Result := 0; + if Source <> nil then + begin + while Source^ <> nil do + begin + Inc(Source); + Inc(Result); + end; + end; +end; + +procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); +var + I, Count: SizeInt; + List: array of PChar; +begin + Assert(Dest <> nil); + if Source <> nil then + begin + Count := PCharVectorCount(Source); + SetLength(List, Count); + Move(Source^, List[0], Count * SizeOf(PChar)); + Dest.BeginUpdate; + try + Dest.Clear; + for I := 0 to Count - 1 do + Dest.Add(List[I]); + finally + Dest.EndUpdate; + end; + end; +end; + +procedure FreePCharVector(var Dest: PCharVector); +var + I, Count: SizeInt; + List: array of PChar; +begin + if Dest <> nil then + begin + Count := PCharVectorCount(Dest); + SetLength(List, Count); + Move(Dest^, List[0], Count * SizeOf(PChar)); + for I := 0 to Count - 1 do + StrDispose(List[I]); + FreeMem(Dest, (Count + 1) * SizeOf(PChar)); + Dest := nil; + end; +end; + +//=== Character Transformation Routines ====================================== + +function CharHex(const C: Char): Byte; +begin + case C of + '0'..'9': + Result := Ord(C) - Ord('0'); + 'a'..'f': + Result := Ord(C) - Ord('a') + 10; + 'A'..'F': + Result := Ord(C) - Ord('A') + 10; + else + Result := $FF; + end; +end; + +function CharLower(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.ToLower(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrLoOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharToggleCase(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + if CharIsLower(C) then + Result := CharUpper(C) + else if CharIsUpper(C) then + Result := CharLower(C) + else + Result := C; + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrReOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +function CharUpper(const C: Char): Char; +begin + {$IFDEF UNICODE_RTL_DATABASE} + Result := TCharacter.ToUpper(C); + {$ELSE ~UNICODE_RTL_DATABASE} + Result := StrCaseMap[Ord(C) + StrUpOffset]; + {$ENDIF ~UNICODE_RTL_DATABASE} +end; + +//=== Character Search and Replace =========================================== + +function CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + for Result := Length(S) downto Index do + if S[Result] = C then + Exit; + end; + Result := 0; +end; + +function CharPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + for Result := Index to Length(S) do + if S[Result] = C then + Exit; + end; + Result := 0; +end; + +function CharIPos(const S: string; C: Char; const Index: SizeInt): SizeInt; +begin + if (Index > 0) and (Index <= Length(S)) then + begin + C := CharUpper(C); + for Result := Index to Length(S) do + if CharUpper(S[Result]) = C then + Exit; + end; + Result := 0; +end; + +function CharReplace(var S: string; const Search, Replace: Char): SizeInt; +var + P: PChar; + Index, Len: SizeInt; +begin + Result := 0; + if Search <> Replace then + begin + UniqueString(S); + P := PChar(S); + Len := Length(S); + for Index := 0 to Len - 1 do + begin + if P^ = Search then + begin + P^ := Replace; + Inc(Result); + end; + Inc(P); + end; + end; +end; + +//=== MultiSz ================================================================ + +function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; +var + I, TotalLength: SizeInt; + P: PMultiSz; +begin + Assert(Source <> nil); + TotalLength := 1; + for I := 0 to Source.Count - 1 do + if Source[I] = '' then + raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem) + else + Inc(TotalLength, StrLen(PChar(Source[I])) + 1); + AllocateMultiSz(Dest, TotalLength); + P := Dest; + for I := 0 to Source.Count - 1 do + begin + P := StrECopy(P, PChar(Source[I])); + Inc(P); + end; + P^ := #0; + Result := Dest; +end; + +procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); +var + P: PMultiSz; +begin + Assert(Dest <> nil); + Dest.BeginUpdate; + try + Dest.Clear; + if Source <> nil then + begin + P := Source; + while P^ <> #0 do + begin + Dest.Add(P); + P := StrEnd(P); + Inc(P); + end; + end; + finally + Dest.EndUpdate; + end; +end; + +function MultiSzLength(const Source: PMultiSz): SizeInt; +var + P: PMultiSz; +begin + Result := 0; + if Source <> nil then + begin + P := Source; + repeat + Inc(Result, StrLen(P) + 1); + P := StrEnd(P); + Inc(P); + until P^ = #0; + Inc(Result); + end; +end; + +procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); +begin + if Len > 0 then + GetMem(Dest, Len * SizeOf(Char)) + else + Dest := nil; +end; + +procedure FreeMultiSz(var Dest: PMultiSz); +begin + if Dest <> nil then + FreeMem(Dest); + Dest := nil; +end; + +function MultiSzDup(const Source: PMultiSz): PMultiSz; +var + Len: SizeInt; +begin + if Source <> nil then + begin + Len := MultiSzLength(Source); + Result := nil; + AllocateMultiSz(Result, Len); + Move(Source^, Result^, Len * SizeOf(Char)); + end + else + Result := nil; +end; + +function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; +begin + Result := JclAnsiStrings.StringsToMultiSz(Dest, Source); +end; + +procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); +begin + JclAnsiStrings.MultiSzToStrings(Dest, Source); +end; + +function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; +begin + Result := JclAnsiStrings.MultiSzLength(Source); +end; + +procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); +begin + JclAnsiStrings.AllocateMultiSz(Dest, Len); +end; + +procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); +begin + JclAnsiStrings.FreeMultiSz(Dest); +end; + +function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; +begin + Result := JclAnsiStrings.MultiSzDup(Source); +end; + +function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; +begin + Result := JclWideStrings.StringsToMultiSz(Dest, Source); +end; + +procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); +begin + JclWideStrings.MultiSzToStrings(Dest, Source); +end; + +function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; +begin + Result := JclWideStrings.MultiSzLength(Source); +end; + +procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); +begin + JclWideStrings.AllocateMultiSz(Dest, Len); +end; + +procedure FreeWideMultiSz(var Dest: PWideMultiSz); +begin + JclWideStrings.FreeMultiSz(Dest); +end; + +function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; +begin + Result := JclWideStrings.MultiSzDup(Source); +end; + +//=== TStrings Manipulation ================================================== + +procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +var + I, L: SizeInt; + Left: string; +begin + Assert(List <> nil); + List.BeginUpdate; + try + List.Clear; + L := Length(Sep); + I := Pos(Sep, S); + while I > 0 do + begin + Left := StrLeft(S, I - 1); + if (Left <> '') or AllowEmptyString then + List.Add(Left); + Delete(S, 1, I + L - 1); + I := Pos(Sep, S); + end; + if S <> '' then + List.Add(S); // Ignore empty strings at the end. + finally + List.EndUpdate; + end; +end; + +procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); +var + I, L: SizeInt; + LowerCaseStr: string; + Left: string; +begin + Assert(List <> nil); + LowerCaseStr := StrLower(S); + Sep := StrLower(Sep); + L := Length(Sep); + I := Pos(Sep, LowerCaseStr); + List.BeginUpdate; + try + List.Clear; + while I > 0 do + begin + Left := StrLeft(S, I - 1); + if (Left <> '') or AllowEmptyString then + List.Add(Left); + Delete(S, 1, I + L - 1); + Delete(LowerCaseStr, 1, I + L - 1); + I := Pos(Sep, LowerCaseStr); + end; + if S <> '' then + List.Add(S); // Ignore empty strings at the end. + finally + List.EndUpdate; + end; +end; + +function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; +var + I, L: SizeInt; +begin + Result := ''; + for I := 0 to List.Count - 1 do + begin + if (List[I] <> '') or AllowEmptyString then + begin + // don't combine these into one addition, somehow it hurts performance + Result := Result + List[I]; + Result := Result + Sep; + end; + end; + // remove terminating separator + if List.Count > 0 then + begin + L := Length(Sep); + Delete(Result, Length(Result) - L + 1, L); + end; +end; + +function StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString: + Boolean = True): string; +var + I, L, N: SizeInt; +begin + Result := ''; + if List.Count > NumberOfItems then + N := NumberOfItems + else + N := List.Count; + for I := 0 to N - 1 do + begin + if (List[I] <> '') or AllowEmptyString then + begin + // don't combine these into one addition, somehow it hurts performance + Result := Result + List[I]; + Result := Result + Sep; + end; + end; + // remove terminating separator + if N > 0 then + begin + L := Length(Sep); + Delete(Result, Length(Result) - L + 1, L); + end; +end; + +procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := Trim(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := TrimRight(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean); +var + I: SizeInt; +begin + Assert(List <> nil); + List.BeginUpdate; + try + for I := List.Count - 1 downto 0 do + begin + List[I] := TrimLeft(List[I]); + if (List[I] = '') and DeleteIfEmpty then + List.Delete(I); + end; + finally + List.EndUpdate; + end; +end; + +function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; +begin + Assert(Strings <> nil); + Result := Unique and (Strings.IndexOf(S) <> -1); + if not Result then + Result := Strings.Add(S) > -1; +end; + +//=== Miscellaneous ========================================================== + +function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; +var + fs: TFileStream; + Len: SizeInt; +begin + fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + Len := fs.Size; + SetLength(Result, Len); + if Len > 0 then + fs.ReadBuffer(Result[1], Len); + finally + fs.Free; + end; +end; + +procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; + Append: Boolean); +var + FS: TFileStream; + Len: SizeInt; +begin + if Append and FileExists(filename) then + FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite) + else + FS := TFileStream.Create(FileName, fmCreate); + try + if Append then + FS.Seek(0, soEnd); // faster than .Position := .Size + Len := Length(Contents); + if Len > 0 then + FS.WriteBuffer(Contents[1], Len); + finally + FS.Free; + end; +end; + +function StrToken(var S: string; Separator: Char): string; +var + I: SizeInt; +begin + I := Pos(Separator, S); + if I <> 0 then + begin + Result := Copy(S, 1, I - 1); + Delete(S, 1, I); + end + else + begin + Result := S; + S := ''; + end; +end; + +procedure StrTokens(const S: string; const List: TStrings); +var + Start: PChar; + Token: string; + Done: Boolean; +begin + Assert(List <> nil); + if List = nil then + Exit; + + List.BeginUpdate; + try + List.Clear; + Start := Pointer(S); + repeat + Done := JclStrings.StrWord(Start, Token); + if Token <> '' then + List.Add(Token); + until Done; + finally + List.EndUpdate; + end; +end; + +function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; +var + Start: SizeInt; + C: Char; +begin + Word := ''; + if (S = '') then + begin + Result := True; + Exit; + end; + Start := Index; + Result := False; + while True do + begin + C := S[Index]; + case C of + #0: + begin + if Start <> 0 then + Word := Copy(S, Start, Index - Start); + Result := True; + Exit; + end; + NativeSpace, NativeLineFeed, NativeCarriageReturn: + begin + if Start <> 0 then + begin + Word := Copy(S, Start, Index - Start); + Exit; + end + else + begin + while CharIsWhiteSpace(C) do + begin + Inc(Index); + C := S[Index]; + end; + end; + end; + else + if Start = 0 then + Start := Index; + Inc(Index); + end; + end; +end; + +function StrWord(var S: PChar; out Word: string): Boolean; +var + Start: PChar; +begin + Word := ''; + if S = nil then + begin + Result := True; + Exit; + end; + Start := nil; + Result := False; + while True do + begin + case S^ of + #0: + begin + if Start <> nil then + SetString(Word, Start, S - Start); + Result := True; + Exit; + end; + NativeSpace, NativeLineFeed, NativeCarriageReturn: + begin + if Start <> nil then + begin + SetString(Word, Start, S - Start); + Exit; + end + else + while CharIsWhiteSpace(S^) do + Inc(S); + end; + else + if Start = nil then + Start := S; + Inc(S); + end; + end; +end; + +function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; +var + Start: SizeInt; + C: Char; +begin + Ident := ''; + if (S = '') then + begin + Result := True; + Exit; + end; + Start := Index; + Result := False; + while True do + begin + C := S[Index]; + if CharIsValidIdentifierLetter(C) then + begin + if Start = 0 then + Start := Index; + end + else + if C = #0 then + begin + if Start <> 0 then + Ident := Copy(S, Start, Index - Start); + Result := True; + Exit; + end + else + begin + if Start <> 0 then + begin + Ident := Copy(S, Start, Index - Start); + Exit; + end; + end; + Inc(Index); + end; +end; + +function StrIdent(var S: PChar; out Ident: string): Boolean; +var + Start: PChar; + C: Char; +begin + Ident := ''; + if S = nil then + begin + Result := True; + Exit; + end; + Start := nil; + Result := False; + while True do + begin + C := S^; + if CharIsValidIdentifierLetter(C) then + begin + if Start = nil then + Start := S; + end + else + if C = #0 then + begin + if Start <> nil then + SetString(Ident, Start, S - Start); + Result := True; + Exit; + end + else + begin + if Start <> nil then + begin + SetString(Ident, Start, S - Start); + Exit; + end + end; + Inc(S); + end; +end; + +procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings); +var + Token: string; +begin + Assert(List <> nil); + + if List = nil then + Exit; + + List.BeginUpdate; + try + List.Clear; + while S <> '' do + begin + Token := StrToken(S, Separator); + List.Add(Token); + end; + finally + List.EndUpdate; + end; +end; + +function StrToFloatSafe(const S: string): Float; +var + Temp: string; + I, J, K: SizeInt; + SwapSeparators, IsNegative: Boolean; + DecSep, ThouSep, C: Char; +begin + DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator; + ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator; + Temp := S; + SwapSeparators := False; + + IsNegative := False; + J := 0; + for I := 1 to Length(Temp) do + begin + C := Temp[I]; + if C = '-' then + IsNegative := not IsNegative + else + if (C <> ' ') and (C <> '(') and (C <> '+') then + begin + // if it appears prior to any digit, it has to be a decimal separator + SwapSeparators := Temp[I] = ThouSep; + J := I; + Break; + end; + end; + + if not SwapSeparators then + begin + K := CharPos(Temp, DecSep); + SwapSeparators := + // if it appears prior to any digit, it has to be a decimal separator + (K > J) and + // if it appears multiple times, it has to be a thousand separator + ((StrCharCount(Temp, DecSep) > 1) or + // we assume (consistent with Windows Platform SDK documentation), + // that thousand separators appear only to the left of the decimal + (K < CharPos(Temp, ThouSep))); + end; + + if SwapSeparators then + begin + // assume a numerical string from a different locale, + // where DecimalSeparator and ThousandSeparator are exchanged + for I := 1 to Length(Temp) do + if Temp[I] = DecSep then + Temp[I] := ThouSep + else + if Temp[I] = ThouSep then + Temp[I] := DecSep; + end; + + Temp := StrKeepChars(Temp, CharIsNumber); + + if Length(Temp) > 0 then + begin + if Temp[1] = DecSep then + Temp := '0' + Temp; + if Temp[Length(Temp)] = DecSep then + Temp := Temp + '0'; + Result := StrToFloat(Temp); + if IsNegative then + Result := -Result; + end + else + Result := 0.0; +end; + +function StrToIntSafe(const S: string): Integer; +begin + Result := Trunc(StrToFloatSafe(S)); +end; + +procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; +begin + Index := Max(1, Min(Index, StrLen + 1)); + Count := Max(0, Min(Count, StrLen + 1 - Index)); +end; + +function ArrayOf(List: TStrings): TDynStringArray; +var + I: SizeInt; +begin + if List <> nil then + begin + SetLength(Result, List.Count); + for I := 0 to List.Count - 1 do + Result[I] := List[I]; + end + else + Result := nil; +end; + +const + BoolToStr: array [Boolean] of string = ('false', 'true'); + +type + TInterfacedObjectAccess = class(TInterfacedObject); + +procedure MoveChar(const Source; var Dest; Count: SizeInt); +begin + if Count > 0 then + Move(Source, Dest, Count * SizeOf(Char)); +end; + +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); +end; + +function DotNetFormat(const Fmt: string; const Args: array of const): string; +var + F, P: PChar; + Len, Capacity, Count: SizeInt; + Index: SizeInt; + ErrorCode: Integer; + S: string; + + procedure Grow(Count: SizeInt); + begin + if Len + Count > Capacity then + begin + Capacity := Capacity * 5 div 3 + Count; + SetLength(Result, Capacity); + end; + end; + + function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; + begin + Result := True; + while AClass <> nil do + begin + if CompareText(AClass.ClassName, ClassName) = 0 then + Exit; + AClass := AClass.ClassParent; + end; + Result := False; + end; + + function GetStringOf(const V: TVarData; Index: SizeInt): string; overload; + begin + case V.VType of + varEmpty, varNull: + raise ArgumentNullException.CreateRes(@RsArgumentIsNull); + varSmallInt: + Result := IntToStr(V.VSmallInt); + varInteger: + Result := IntToStr(V.VInteger); + varSingle: + Result := FloatToStr(V.VSingle); + varDouble: + Result := FloatToStr(V.VDouble); + varCurrency: + Result := CurrToStr(V.VCurrency); + varDate: + Result := DateTimeToStr(V.VDate); + varOleStr: + Result := V.VOleStr; + varBoolean: + Result := BoolToStr[V.VBoolean <> False]; + varByte: + Result := IntToStr(V.VByte); + varWord: + Result := IntToStr(V.VWord); + varShortInt: + Result := IntToStr(V.VShortInt); + varLongWord: + Result := IntToStr(V.VLongWord); + varInt64: + Result := IntToStr(V.VInt64); + varString: + Result := string(V.VString); + {$IFDEF SUPPORTS_UNICODE_STRING} + varUString: + Result := string(V.VUString); + {$ENDIF SUPPORTS_UNICODE_STRING} + {varArray, + varDispatch, + varError, + varUnknown, + varAny, + varByRef:} + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + + function GetStringOf(Index: SizeInt): string; overload; + var + V: TVarRec; + Intf: IToString; + begin + V := Args[Index]; + if (V.VInteger = 0) and + (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, + vtInterface, vtInt64]) then + raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); + + case V.VType of + vtInteger: + Result := IntToStr(V.VInteger); + vtBoolean: + Result := BoolToStr[V.VBoolean]; + vtChar: + Result := string(AnsiString(V.VChar)); + vtExtended: + Result := FloatToStr(V.VExtended^); + vtString: + Result := string(V.VString^); + vtPointer: + Result := IntToHex(TJclAddr(V.VPointer), 8); + vtPChar: + Result := string(AnsiString(V.VPChar)); + vtObject: + if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then + begin + Result := Intf.ToString; + Pointer(Intf) := nil; // do not release the object + // undo the RefCount change + Dec(TInterfacedObjectAccess(V.VObject).FRefCount); + end + else + if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then + Result := Intf.ToString + else +{$IFDEF RTL200_UP} + Result := V.VObject.ToString; +{$Else} + raise ArgumentNullException.CreateResFmt(V.VObject.ClassName + ': ' + @RsDotNetFormatArgumentNotSupported, [Index]); +{$EndIf} + vtClass: + Result := V.VClass.ClassName; + vtWideChar: + Result := V.VWideChar; + vtPWideChar: + Result := V.VPWideChar; + vtAnsiString: + Result := string(V.VAnsiString); + vtCurrency: + Result := CurrToStr(V.VCurrency^); + vtVariant: + Result := GetStringOf(TVarData(V.VVariant^), Index); + vtInterface: + if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then + Result := IToString(Intf).ToString + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + vtWideString: + Result := WideString(V.VWideString); + vtInt64: + Result := IntToStr(V.VInt64^); + {$IFDEF SUPPORTS_UNICODE_STRING} + vtUnicodeString: + Result := UnicodeString(V.VUnicodeString); + {$ENDIF SUPPORTS_UNICODE_STRING} + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + +begin + if Length(Args) = 0 then + begin + Result := Fmt; + Exit; + end; + Len := 0; + Capacity := Length(Fmt); + SetLength(Result, Capacity); + if Capacity = 0 then + raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); + + P := Pointer(Fmt); + F := P; + while True do + begin + if (P[0] = #0) or (P[0] = '{') then + begin + Count := P - F; + Inc(P); + if (P[-1] <> #0) and (P[0] = '{') then + Inc(Count); // include '{' + + if Count > 0 then + begin + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + end; + + if P[-1] = #0 then + Break; + + if P[0] <> '{' then + begin + F := P; + Inc(P); + while (P[0] <> #0) and (P[0] <> '}') do + Inc(P); + SetString(S, F, P - F); + Val(S, Index, ErrorCode); + if ErrorCode <> 0 then + raise FormatException.CreateRes(@RsFormatException); + if (Index < 0) or (Index > High(Args)) then + raise FormatException.CreateRes(@RsFormatException); + S := GetStringOf(Index); + if S <> '' then + begin + Grow(Length(S)); + MoveChar(S[1], Result[Len + 1], Length(S)); + Inc(Len, Length(S)); + end; + + if P[0] = #0 then + Break; + end; + F := P + 1; + end + else + if (P[0] = '}') and (P[1] = '}') then + begin + Count := P - F + 1; + Inc(P); // skip next '}' + + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + F := P + 1; + end; + + Inc(P); + end; + + SetLength(Result, Len); +end; + +//=== { TJclStringBuilder } ===================================================== + +constructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt); +begin + inherited Create; + SetLength(FChars, Capacity); + FMaxCapacity := MaxCapacity; +end; + +constructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt); +begin + Create(Capacity); + Append(Value); +end; + +constructor TJclStringBuilder.Create(const Value: string; StartIndex, + Length, Capacity: SizeInt); +begin + Create(Capacity); + Append(Value, StartIndex + 1, Length); +end; + +function TJclStringBuilder.ToString: string; +begin + if FLength > 0 then + SetString(Result, PChar(@FChars[0]), FLength) + else + Result := ''; +end; + +function TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt; +begin + if System.Length(FChars) < Capacity then + SetCapacity(Capacity); + Result := System.Length(FChars); +end; + +procedure TJclStringBuilder.SetCapacity(const Value: SizeInt); +begin + if Value <> System.Length(FChars) then + begin + SetLength(FChars, Value); + if Value < FLength then + FLength := Value; + end; +end; + +function TJclStringBuilder.GetChars(Index: SizeInt): Char; +begin + Result := FChars[Index]; +end; + +procedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char); +begin + FChars[Index] := Value; +end; + +procedure TJclStringBuilder.Set_Length(const Value: SizeInt); +begin + FLength := Value; +end; + +function TJclStringBuilder.GetCapacity: SizeInt; +begin + Result := System.Length(FChars); +end; + +function TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder; +var + Capacity: SizeInt; +begin + if (Count > 0) and (RepeatCount > 0) then + begin + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + if Count = 1 then + FChars[FLength] := Value[0] + else + MoveChar(Value[0], FChars[FLength], Count); + Inc(FLength, Count); + Dec(RepeatCount); + until RepeatCount <= 0; + end; + Result := Self; +end; + +function TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count, + RepeatCount: SizeInt): TJclStringBuilder; +var + Capacity: SizeInt; +begin + if (Index < 0) or (Index > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + + if Index = FLength then + AppendPChar(Value, Count, RepeatCount) + else + if (Count > 0) and (RepeatCount > 0) then + begin + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); + if Count = 1 then + FChars[Index] := Value[0] + else + MoveChar(Value[0], FChars[Index], Count); + Inc(FLength, Count); + + Dec(RepeatCount); + + Inc(Index, Count); // little optimization + until RepeatCount <= 0; + end; + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(@Value[0], Len); + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; +begin + Result := AppendPChar(@Value, 1, RepeatCount); +end; + +function TJclStringBuilder.Append(const Value: string): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(Pointer(Value), Len); + Result := Self; +end; + +function TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder; +begin + Result := Append(BoolToStr[Value]); +end; + +function TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Integer): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Double): TJclStringBuilder; +begin + Result := Append(FloatToStr(Value)); +end; + +function TJclStringBuilder.Append(Value: Int64): TJclStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder; +begin + Result := Append(DotNetFormat('{0}', [Obj])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); +end; + +function TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, Args)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, @Value[0], Len); + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, Pointer(Value), Len, Count); + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; +begin + Result := Insert(Index, BoolToStr[Value]); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char; + StartIndex, Length: SizeInt): TJclStringBuilder; +var + Len: SizeInt; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder; +begin + Result := Insert(Index, FloatToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; +begin + Result := Insert(Index, DotNetFormat('{0}', [Obj])); +end; + +function TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder; +begin + if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Length > 0 then + begin + MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length)); + Dec(FLength, Length); + end; + Result := Self; +end; + +function TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, + Count: SizeInt): TJclStringBuilder; +var + I: SizeInt; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if (Count > 0) and (OldChar <> NewChar) then + begin + for I := StartIndex to StartIndex + Length - 1 do + if FChars[I] = OldChar then + FChars[I] := NewChar; + end; + Result := Self; +end; + +function TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder; +var + I: SizeInt; + Offset: SizeInt; + NewLen, OldLen, Capacity: SizeInt; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if OldValue = '' then + raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); + + if (Count > 0) and (OldValue <> NewValue) then + begin + OldLen := System.Length(OldValue); + NewLen := System.Length(NewValue); + Offset := NewLen - OldLen; + Capacity := System.Length(FChars); + for I := StartIndex to StartIndex + Length - 1 do + if FChars[I] = OldValue[1] then + begin + if OldLen > 1 then + if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then + Continue; + if Offset <> 0 then + begin + if FLength - OldLen + NewLen > MaxCurrency then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Offset then + begin + Capacity := Capacity * 5 div 3 + Offset; + SetLength(FChars, Capacity); + end; + if Offset < 0 then + MoveChar(FChars[I - Offset], FChars[I], FLength - I) + else + MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I); + Inc(FLength, Offset); + end; + if NewLen > 0 then + begin + if (OldLen = 1) and (NewLen = 1) then + FChars[I] := NewValue[1] + else + MoveChar(NewValue[1], FChars[I], NewLen); + end; + end; + end; + Result := Self; +end; + +function StrExpandTabs(S: string): string; +begin + // use an empty tab set, which will default to a tab width of 2 + Result := TJclTabSet(nil).Expand(s); +end; + +function StrExpandTabs(S: string; TabWidth: SizeInt): string; +var + TabSet: TJclTabSet; +begin + // create a tab set with no tab stops and the given tab width + TabSet := TJclTabSet.Create(TabWidth); + try + Result := TabSet.Expand(S); + finally + TabSet.Free; + end; +end; + +function StrExpandTabs(S: string; TabSet: TJclTabSet): string; +begin + // use the provided tab set to perform the expansion + Result := TabSet.Expand(S); +end; + +function StrOptimizeTabs(S: string): string; +begin + // use an empty tab set, which will default to a tab width of 2 + Result := TJclTabSet(nil).Optimize(s); +end; + +function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; +var + TabSet: TJclTabSet; +begin + // create a tab set with no tab stops and the given tab width + TabSet := TJclTabSet.Create(TabWidth); + try + Result := TabSet.Optimize(S); + finally + TabSet.Free; + end; +end; + +function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; +begin + // use the provided tab set to perform the optimization + Result := TabSet.Optimize(S); +end; + +// === { TTabSetData } =================================================== + +type + TTabSetData = class + public + FStops: TDynSizeIntArray; + FRealWidth: SizeInt; + FRefCount: SizeInt; + FWidth: SizeInt; + FZeroBased: Boolean; + constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); + + function Add(Column: SizeInt): SizeInt; + function AddRef: SizeInt; + procedure CalcRealWidth; + function FindStop(Column: SizeInt): SizeInt; + function ReleaseRef: SizeInt; + procedure RemoveAt(Index: SizeInt); + procedure SetStops(Index, Value: SizeInt); + end; + +constructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); +var + idx: SizeInt; +begin + inherited Create; + FRefCount := 1; + for idx := 0 to High(Tabstops) do + Add(Tabstops[idx]); + FWidth := TabWidth; + FZeroBased := ZeroBased; + CalcRealWidth; +end; + +function TTabSetData.Add(Column: SizeInt): SizeInt; +var + I: SizeInt; +begin + if Column < Ord(FZeroBased) then + raise ArgumentOutOfRangeException.Create('Column'); + Result := FindStop(Column); + if Result < 0 then + begin + // the column doesn't exist; invert the result of FindStop to get the correct index position + Result := not Result; + // increase the tab stop array + SetLength(FStops, Length(FStops) + 1); + // shift rooms after the insert position + for I := High(FStops) - 1 downto Result do + FStops[I + 1] := FStops[I]; + // add the tab stop at the correct location + FStops[Result] := Column; + CalcRealWidth; + end + else + begin + raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); + end; +end; + +function TTabSetData.AddRef: SizeInt; +begin + Result := LockedInc(FRefCount); +end; + +procedure TTabSetData.CalcRealWidth; +begin + if FWidth < 1 then + begin + if Length(FStops) > 1 then + FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))] + else + if Length(FStops) = 1 then + FRealWidth := FStops[0] + else + FRealWidth := 2; + end + else + FRealWidth := FWidth; +end; + +function TTabSetData.FindStop(Column: SizeInt): SizeInt; +begin + Result := High(FStops); + while (Result >= 0) and (FStops[Result] > Column) do + Dec(Result); + if (Result >= 0) and (FStops[Result] <> Column) then + Result := not Succ(Result); +end; + +function TTabSetData.ReleaseRef: SizeInt; +begin + Result := LockedDec(FRefCount); + if Result <= 0 then + Destroy; +end; + +procedure TTabSetData.RemoveAt(Index: SizeInt); +var + I: SizeInt; +begin + for I := Index to High(FStops) - 1 do + FStops[I] := FStops[I + 1]; + SetLength(FStops, High(FStops)); + CalcRealWidth; +end; + +procedure TTabSetData.SetStops(Index, Value: SizeInt); +var + temp: SizeInt; +begin + if (Index < 0) or (Index >= Length(FStops)) then + begin + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + end + else + begin + temp := FindStop(Value); + if temp < 0 then + begin + // remove existing tab stop... + RemoveAt(Index); + // now add the new tab stop + Add(Value); + end + else + if temp <> Index then + begin + // new tab stop already present at another index + raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); + end; + end; +end; + +//=== { TJclTabSet } ===================================================== + +constructor TJclTabSet.Create; +begin + // no tab stops, tab width set to auto + Create([], True, 0); +end; + +constructor TJclTabSet.Create(TabWidth: SizeInt); +begin + // no tab stops, specified tab width + Create([], True, TabWidth); +end; + +constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); +begin + // specified tab stops, tab width equal to distance between last two tab stops + Create(Tabstops, ZeroBased, 0); +end; + +constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); +begin + inherited Create; + FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth); +end; + +constructor TJclTabSet.Create(Data: TObject); +begin + inherited Create; + // add a reference to the data + TTabSetData(Data).AddRef; + // assign the data to this instance + FData := TTabSetData(Data); +end; + +destructor TJclTabSet.Destroy; +begin + // release the reference to the tab set data + TTabSetData(FData).ReleaseRef; + // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction + FData := nil; + // really destroy the instance + inherited Destroy; +end; + +function TJclTabSet.Add(Column: SizeInt): SizeInt; +begin + if Self = nil then + raise NullReferenceException.Create; + Result := TTabSetData(FData).Add(Column); +end; + +function TJclTabSet.Clone: TJclTabSet; +begin + if Self <> nil then + Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth) + else + Result := nil; +end; + +function TJclTabSet.Delete(Column: SizeInt): SizeInt; +begin + Result := TTabSetData(FData).FindStop(Column); + if Result >= 0 then + TTabSetData(FData).RemoveAt(Result); +end; + +function TJclTabSet.Expand(const S: string): string; +begin + Result := Expand(s, StartColumn); +end; + +function TJclTabSet.Expand(const S: string; Column: SizeInt): string; +var + sb: TJclStringBuilder; + head: PChar; + cur: PChar; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + sb := TJclStringBuilder.Create(Length(S)); + try + cur := PChar(S); + while cur^ <> #0 do + begin + head := cur; + while (cur^ <> #0) and (cur^ <> #9) do + begin + if CharIsReturn(cur^) then + Column := StartColumn + else + Inc(Column); + Inc(cur); + end; + if cur > head then + sb.Append(head, 0, cur - head); + if cur^ = #9 then + begin + sb.Append(' ', TabFrom(Column) - Column); + Column := TabFrom(Column); + Inc(cur); + end; + end; + Result := sb.ToString; + finally + sb.Free; + end; +end; + +function TJclTabSet.FindStop(Column: SizeInt): SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FindStop(Column) + else + Result := -1; +end; + +class function TJclTabSet.FromString(const S: string): TJclTabSet; +var + cur: PChar; + + function ParseNumber: Integer; + var + head: PChar; + begin + StrSkipChars(cur, CharIsWhiteSpace); + head := cur; + while CharIsDigit(cur^) do + Inc(cur); + Result := -1; + if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then + Result := -1; + end; + + procedure ParseStops; + var + openBracket, hadComma: Boolean; + num: SizeInt; + begin + StrSkipChars(cur, CharIsWhiteSpace); + openBracket := cur^ = '['; + hadComma := False; + if openBracket then + Inc(cur); + repeat + num := ParseNumber; + if (num < 0) and hadComma then + raise EJclStringError.CreateRes(@RsTabs_StopExpected) + else + if num >= 0 then + Result.Add(num); + StrSkipChars(cur, CharIsWhiteSpace); + hadComma := cur^ = ','; + if hadComma then + Inc(cur); + until (cur^ = #0) or (cur^ = '+') or (cur^ = ']'); + if hadComma then + raise EJclStringError.CreateRes(@RsTabs_StopExpected) + else + if openBracket and (cur^ <> ']') then + raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected); + end; + + procedure ParseTabWidth; + var + num: SizeInt; + begin + StrSkipChars(cur, CharIsWhiteSpace); + if cur^ = '+' then + begin + Inc(cur); + StrSkipChars(cur, CharIsWhiteSpace); + num := ParseNumber; + if (num < 0) then + raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected) + else + Result.TabWidth := num; + end; + end; + + procedure ParseZeroBasedFlag; + begin + StrSkipChars(cur, CharIsWhiteSpace); + if cur^ = '0' then + begin + Inc(cur); + if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then + begin + Result.ZeroBased := True; + StrSkipChars(cur, CharIsWhiteSpace); + end + else + Dec(cur); + end; + end; + +begin + Result := TJclTabSet.Create; + try + Result.ZeroBased := False; + cur := PChar(S); + ParseZeroBasedFlag; + ParseStops; + ParseTabWidth; + except + // clean up the partially complete instance (to avoid memory leaks)... + Result.Free; + // ... and re-raise the exception + raise; + end; +end; + +function TJclTabSet.GetCount: SizeInt; +begin + if Self <> nil then + Result := Length(TTabSetData(FData).FStops) + else + Result := 0; +end; + +function TJclTabSet.GetStops(Index: SizeInt): SizeInt; +begin + if Self <> nil then + begin + if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then + begin + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + end + else + Result := TTabSetData(FData).FStops[Index]; + end + else + begin + raise EJclStringError.CreateRes(@RsArgumentOutOfRange); + end; +end; + +function TJclTabSet.GetTabWidth: SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FWidth + else + Result := 0; +end; + +function TJclTabSet.GetZeroBased: Boolean; +begin + Result := (Self = nil) or TTabSetData(FData).FZeroBased; +end; + +procedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); +var + nextTab: SizeInt; +begin + if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state) + raise ArgumentOutOfRangeException.Create('StartColumn'); + if (TargetColumn < StartColumn) then // target lies before the starting column + raise ArgumentOutOfRangeException.Create('TargetColumn'); + TabsNeeded := 0; + repeat + nextTab := TabFrom(StartColumn); + if nextTab <= TargetColumn then + begin + Inc(TabsNeeded); + StartColumn := nextTab; + end; + until nextTab > TargetColumn; + SpacesNeeded := TargetColumn - StartColumn; +end; + +function TJclTabSet.Optimize(const S: string): string; +begin + Result := Optimize(S, StartColumn); +end; + +function TJclTabSet.Optimize(const S: string; Column: SizeInt): string; +var + sb: TJclStringBuilder; + head: PChar; + cur: PChar; + tgt: SizeInt; + + procedure AppendOptimalWhiteSpace(Target: SizeInt); + var + tabCount: SizeInt; + spaceCount: SizeInt; + begin + if cur > head then + begin + OptimalFillInfo(Column, Target, tabCount, spaceCount); + if tabCount > 0 then + sb.Append(#9, tabCount); + if spaceCount > 0 then + sb.Append(' ', spaceCount); + end; + end; + +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + sb := TJclStringBuilder.Create(Length(S)); + try + cur := PChar(s); + while cur^ <> #0 do + begin + // locate first whitespace character + head := cur; + while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do + Inc(cur); + // output non whitespace characters + if cur > head then + sb.Append(head, 0, cur - head); + // advance column + Inc(Column, cur - head); + // initialize target column indexer + tgt := Column; + // locate end of whitespace sequence + while CharIsWhiteSpace(cur^) do + begin + if CharIsReturn(cur^) then + begin + // append optimized whitespace sequence... + AppendOptimalWhiteSpace(tgt); + // ...set the column back to the start of the line... + Column := StartColumn; + // ...reset target column indexer... + tgt := Column; + // ...add the line break character... + sb.Append(cur^); + end + else + if cur^ = #9 then + tgt := TabFrom(tgt) // expand the tab + else + Inc(tgt); // a normal whitespace; taking up 1 column + Inc(cur); + end; + AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence... + Column := tgt; // ...and memorize the column for the next iteration + end; + Result := sb.ToString; // convert result to a string + finally + sb.Free; + end; +end; + +procedure TJclTabSet.RemoveAt(Index: SizeInt); +begin + if Self <> nil then + TTabSetData(FData).RemoveAt(Index) + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetStops(Index, Value: SizeInt); +begin + if Self <> nil then + TTabSetData(FData).SetStops(Index, Value) + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetTabWidth(Value: SizeInt); +begin + if Self <> nil then + begin + TTabSetData(FData).FWidth := Value; + TTabSetData(FData).CalcRealWidth; + end + else + raise NullReferenceException.Create; +end; + +procedure TJclTabSet.SetZeroBased(Value: Boolean); +var + shift: SizeInt; + idx: SizeInt; +begin + if Self <> nil then + begin + if Value <> TTabSetData(FData).FZeroBased then + begin + TTabSetData(FData).FZeroBased := Value; + if Value then + shift := -1 + else + shift := 1; + for idx := 0 to High(TTabSetData(FData).FStops) do + TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift; + end; + end + else + raise NullReferenceException.Create; +end; + +function TJclTabSet.InternalTabStops: TDynSizeIntArray; +begin + if Self <> nil then + Result := TTabSetData(FData).FStops + else + Result := nil; +end; + +function TJclTabSet.InternalTabWidth: SizeInt; +begin + if Self <> nil then + Result := TTabSetData(FData).FRealWidth + else + Result := 2; +end; + +function TJclTabSet.NewReference: TJclTabSet; +begin + if Self <> nil then + Result := TJclTabSet.Create(FData) + else + Result := nil; +end; + +function TJclTabSet.StartColumn: SizeInt; +begin + if GetZeroBased then + Result := 0 + else + Result := 1; +end; + +function TJclTabSet.TabFrom(Column: SizeInt): SizeInt; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + Result := FindStop(Column); + if Result < 0 then + Result := not Result + else + Inc(Result); + if Result >= GetCount then + begin + if GetCount > 0 then + Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)] + else + Result := StartColumn; + while Result <= Column do + Inc(Result, ActualTabWidth); + end + else + Result := TTabSetData(FData).FStops[Result]; +end; + +function TJclTabSet.ToString: string; +begin + Result := ToString(TabSetFormatting_Full); +end; + +function TJclTabSet.ToString(FormattingOptions: SizeInt): string; +var + sb: TJclStringBuilder; + idx: SizeInt; + + function WantBrackets: Boolean; + begin + Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0; + end; + + function EmptyBrackets: Boolean; + begin + Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0; + end; + + function IncludeAutoWidth: Boolean; + begin + Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0; + end; + + function IncludeTabWidth: Boolean; + begin + Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0; + end; + + function IncludeStops: Boolean; + begin + Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0; + end; + +begin + sb := TJclStringBuilder.Create; + try + // output the fixed tabulation positions if requested... + if IncludeStops then + begin + // output each individual tabulation position + for idx := 0 to GetCount - 1 do + begin + sb.Append(TabStops[idx]); + sb.Append(','); + end; + // remove the final comma if any tabulation positions where outputted + if sb.Length <> 0 then + sb.Remove(sb.Length - 1, 1); + // bracket the tabulation positions if requested + if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then + begin + sb.Insert(0, '['); + sb.Append(']'); + end; + end; + // output the tab width if requested.... + if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then + begin + // separate the tab width from any outputted tabulation positions with a whitespace + if sb.Length > 0 then + sb.Append(' '); + // flag tab width + sb.Append('+'); + // finally, output the tab width + sb.Append(ActualTabWidth); + end; + // flag zero-based tabset by outputting a 0 (zero) as the first character. + if ZeroBased then + sb.Insert(0, string('0 ')); + Result := StrTrimCharRight(sb.ToString, ' '); + finally + sb.Free; + end; +end; + +function TJclTabSet.UpdatePosition(const S: string): SizeInt; +var + Line: SizeInt; +begin + Result := StartColumn; + Line := -1; + UpdatePosition(S, Result, Line); +end; + +function TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt; +var + Line: SizeInt; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + Result := Column; + Line := -1; + UpdatePosition(S, Result, Line); +end; + +function TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; +var + prevChar: Char; + cur: PChar; +begin + if Column < StartColumn then + raise ArgumentOutOfRangeException.Create('Column'); + // initialize loop + cur := PChar(S); + // iterate until end of string (the Null-character) + while cur^ <> #0 do + begin + // check for line-breaking characters + if CharIsReturn(cur^) then + begin + // Column moves back all the way to the left + Column := StartColumn; + // If this is the first line-break character or the same line-break character, increment the Line parameter + Inc(Line); + // check if it's the first of a two-character line-break + prevChar := cur^; + Inc(cur); + // if it isn't a two-character line-break, undo the previous advancement + if (cur^ = prevChar) or not CharIsReturn(cur^) then + Dec(cur); + end + else // check for tab character and expand it + if cur^ = #9 then + Column := TabFrom(Column) + else // a normal character; increment column + Inc(Column); + // advance pointer + Inc(cur); + end; + // set the result to the newly calculated column + Result := Column; +end; + +//=== { NullReferenceException } ============================================= + +constructor NullReferenceException.Create; +begin + CreateRes(@RsArg_NullReferenceException); +end; + +function CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt; +var + Cur1, Len1, + Cur2, Len2: SizeInt; + + function IsRealNumberChar(ch: Char): Boolean; + begin + Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+'); + end; + + procedure NumberCompare; + var + IsReallyNumber: Boolean; + FirstDiffBreaks: Boolean; + Val1, Val2: SizeInt; + begin + Result := 0; + IsReallyNumber := False; + // count leading spaces in S1 + while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do + begin + Dec(Result); + Inc(Cur1); + end; + // count leading spaces in S2 (canceling them out against the ones in S1) + while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do + begin + Inc(Result); + Inc(Cur2); + end; + + // if spaces match, or both strings are actually followed by a numeric character, continue the checks + if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then + begin + // Check signed number + if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then + Result := 1 + else + if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then + Result := -1 + else + Result := 0; + + if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then + Inc(Cur1); + if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then + Inc(Cur2); + + FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0'); + while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do + begin + IsReallyNumber := True; + Val1 := StrToInt(S1[Cur1]); + Val2 := StrToInt(S2[Cur2]); + + if (Result = 0) and (Val1 < Val2) then + Result := -1 + else + if (Result = 0) and (Val1 > Val2) then + Result := 1; + if FirstDiffBreaks and (Result <> 0) then + Break; + Inc(Cur1); + Inc(Cur2); + end; + + if IsReallyNumber then + begin + if not FirstDiffBreaks then + begin + if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then + Result := 1 + else + if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then + Result := -1; + end; + end; + end; + end; + + procedure SetByCompareLength; + var + Remain1: SizeInt; + Remain2: SizeInt; + begin + // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be + // completely equal, or S2 could be longer) + Remain1 := Len1 - Cur1 + 1; + Remain2 := Len2 - Cur2 + 1; + if Remain1 < 0 then + Remain1 := 0; + if Remain2 < 0 then + Remain2 := 0; + + if Remain1 < Remain2 then + Result := -1 + else + if Remain1 > Remain2 then + Result := 1; + end; + +begin + Cur1 := 1; + Len1 := Length(S1); + Cur2 := 1; + Len2 := Length(S2); + Result := 0; + + while (Result = 0) do + begin + if (Cur1 > Len1) or (Cur2 > Len2) then + begin + SetByCompareLength; + Break; + end + else + if (Cur1 <= Len1) and (Cur2 > Len2) then + Result := 1 + else + if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then + Result := -1 + else + if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then + Result := 1 + else + if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then + NumberCompare + else + begin + if CaseInsensitive then + Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1) + else + Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1); + Inc(Cur1); + Inc(Cur2); + end; + end; +end; + +function CompareNaturalStr(const S1, S2: string): SizeInt; overload; +begin + Result := CompareNatural(S1, S2, False); +end; + +function CompareNaturalText(const S1, S2: string): SizeInt; overload; +begin + Result := CompareNatural(S1, S2, True); +end; + +initialization + {$IFNDEF UNICODE_RTL_DATABASE} + LoadCharTypes; // this table first + LoadCaseMap; // or this function does not work + {$ENDIF ~UNICODE_RTL_DATABASE} + {$IFDEF UNITVERSIONING} + RegisterUnitVersion(HInstance, UnitVersioning); + {$ENDIF UNITVERSIONING} + +{$IFDEF UNITVERSIONING} +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} + +end. + diff --git a/qa/automated/dunit/JclTests.dpr b/qa/automated/dunit/JclTests.dpr index dfd9c3c007..830736c544 100644 --- a/qa/automated/dunit/JclTests.dpr +++ b/qa/automated/dunit/JclTests.dpr @@ -1,41 +1,41 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ DUnit Test } -{ } -{ Last Update: $Date$ } -{ } -{ 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. } -{ } -{**************************************************************************************************} - -program JclTests; - -uses - Forms, - GUITestRunner, - TestJcl8087 in 'units\TestJcl8087.pas', - TestJclMath in 'units\TestJclMath.pas', - TestJclStrings in 'units\TestJclStrings.pas', - TestJclDateTime in 'units\TestJclDateTime.pas', - TestJclContainer in 'units\TestJclContainer.pas', - TestJclNotify in 'units\TestJclNotify.pas', - TestJclDebug in 'units\TestJclDebug.pas', - JclMath in '..\..\..\jcl\source\common\JclMath.pas', - JclStringLists in '..\..\..\jcl\source\common\JclStringLists.pas', - JclStrings in '..\..\..\jcl\source\common\JclStrings.pas', - JclFileUtils in '..\..\..\jcl\source\common\JclFileUtils.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.Run; - GUITestRunner.RunRegisteredTests; +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test } +{ } +{ Last Update: $Date$ } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +program JclTests; + +uses + Forms, + GUITestRunner, + TestJcl8087 in 'units\TestJcl8087.pas', + TestJclMath in 'units\TestJclMath.pas', + TestJclStrings in 'units\TestJclStrings.pas', + TestJclDateTime in 'units\TestJclDateTime.pas', + TestJclContainer in 'units\TestJclContainer.pas', + TestJclNotify in 'units\TestJclNotify.pas', + TestJclDebug in 'units\TestJclDebug.pas', + JclMath in '..\..\..\jcl\source\common\JclMath.pas', + JclStringLists in '..\..\..\jcl\source\common\JclStringLists.pas', + JclStrings in '..\..\..\jcl\source\common\JclStrings.pas', + JclFileUtils in '..\..\..\jcl\source\common\JclFileUtils.pas'; + +{$R *.res} + +begin + Application.Initialize; + Application.Run; + GUITestRunner.RunRegisteredTests; end. \ No newline at end of file diff --git a/qa/automated/dunit/units/TestJclMath.pas b/qa/automated/dunit/units/TestJclMath.pas index 787363e390..8d422d44bf 100644 --- a/qa/automated/dunit/units/TestJclMath.pas +++ b/qa/automated/dunit/units/TestJclMath.pas @@ -1,1226 +1,1226 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ DUnit Test } -{ } -{ Last Update: 19-Jan-2002 } -{ } -{ 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. } -{ } -{**************************************************************************************************} - -unit TestJclMath; - -interface -uses - TestFramework, -{$IFDEF MSWINDOWS} - Windows, -{$ENDIF MSWINDOWS} -{$IFDEF VCL} - Dialogs, -{$ENDIF VCL} - Classes, - SysUtils, - Math, - JclMath; - -{ TMathLogarithmicTest } - -type - TMathLogarithmicTest = class (TTestCase) - published - procedure _LogBase10; - procedure _LogBase2; - procedure _LogBaseN; - end; - -type - TMathTranscendentalTest = class (TTestCase) - published - procedure _ArcCos; - procedure _ArcCot; - procedure _ArcCsc; - procedure _ArcSec; - procedure _ArcSin; - procedure _ArcTan; - procedure _ArcTan2; - procedure _Cos; - procedure _Cot; - procedure _Csc; - procedure _Sec; - procedure _Sin; - procedure _SinCos; - procedure _Tan; - end; - -type - TMathMiscTest = class (TTestCase) - published - procedure _Ackermann; - procedure _Ceiling; - procedure _Factorial; - procedure _Fibonacci; - procedure _Floor; - procedure _GCD; - procedure _ISqrt; - procedure _LCM; - procedure _NormalizeA; - procedure _Pythagoras; - procedure _Sgn; - procedure _Signe; - end; - -type - TMathRationalTest = class(TTestCase) - private - RN1: TJclRational; - RN2: TJclRational; - RN3: TJclRational; - protected - procedure SetUp; override; - procedure TearDown; override; - - published - procedure _Assign; - procedure _Add; - procedure _IsEqual; - procedure _IsZero; - procedure _IsOne; - procedure _Subtract; - procedure _Multiply; - procedure _Divide; - procedure _Power; - procedure _AsFloat; - procedure _AsString; - procedure _Sqr; - procedure _Sqrt; - end; - -type - TMathExponentialTest = class(TTestCase) - published - procedure _Exp; - procedure _Power; - procedure _PowerInt; - procedure _TenToY; - procedure _TwoToY; - end; - -type - TMathPrimeTest = class(TTestCase) - published - procedure _IsPrime; - procedure _IsRelativePrime; - end; - -type - TMathInfNanSupportTest = class(TTestCase) - private - s: single; - d: Double; - e: Extended; - - published - procedure _IsInfinite; - procedure _IsNaN; - procedure _IsSpecialValue; - procedure _MakeQuietNaN; - procedure _GetNaNTag; - end; - -type - TSetCrack = class(TJclASet); - -type - TMathASetTest = class(TTestCase) - protected - ASet: TJclASet; - procedure TearDown; override; - - published - procedure _Invert; - procedure _SetGet; - procedure _SetGetRange; - end; - - TMathFlatSetTest = class(TMathASetTest) - protected - procedure SetUp; override; - end; - -implementation - -//================================================================================================== -// Logarithmic -//================================================================================================== - -procedure TMathLogarithmicTest._LogBase10; -var - x: Extended; - -begin - x := 0.1; - while x < 100 do - begin - CheckEquals(Log10(x), LogBase10(x), PrecisionTolerance); - x := x + 0.5; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathLogarithmicTest._LogBase2; -var - x: Extended; - -begin - x := 0.1; - while x < 100 do - begin - CheckEquals(Math.Log2(x), LogBase2(x), PrecisionTolerance); - x := x + 0.5; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathLogarithmicTest._LogBaseN; -var - x: Extended; - Base: Integer; - -begin - x := 0.1; - for Base := 2 to 60 do - while x < 100 do - begin - CheckEquals(Math.LogN(Base, x), LogBaseN(Base, x), PrecisionTolerance); - x := x + 0.5; - end; -end; - -//================================================================================================== -// Transcendental -//================================================================================================== - -procedure TMathTranscendentalTest._ArcCos; -var - x: Extended; - -begin - x := -0.98; - - while x < 1 do - begin - CheckEquals(Math.ArcCos(X), JclMath.ArcCos(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcCot; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcCsc; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcSec; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcSin; -var - x: Extended; - -begin - x := -0.98; - - while x < 1 do - begin - CheckEquals(Math.ArcSin(X), JclMath.ArcSin(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcTan; -var - x: Extended; - -begin - x := -Pi; - - while x < Pi do - begin - if x <> 0 then - CheckEquals(System.ArcTan(X), JclMath.ArcTan(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._ArcTan2; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Cos; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(System.Cos(X), JclMath.Cos(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Cot; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Csc; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Sec; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Sin; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(System.Sin(X), JclMath.Sin(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._SinCos; -var - x, s, c: Extended; - -begin -// x := -Pi; -// -// while x <= Pi do -// begin -// SinCos(x, s, c); -// -// CheckEquals(System.Sin(X), s, PrecisionTolerance); -// CheckEquals(System.Cos(X), c, PrecisionTolerance); -// x := x + 0.1; -// end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathTranscendentalTest._Tan; -var - x: Extended; - -begin - x := -Pi; - - while x <= Pi do - begin - CheckEquals(Math.Tan(X), JclMath.Tan(X), PrecisionTolerance); - x := x + 0.1; - end; -end; - - -//================================================================================================== -// Hyperbolic -//================================================================================================== - - -//================================================================================================== -// Miscellaneous -//================================================================================================== - -procedure TMathMiscTest._Ackermann; -begin - CheckEquals(1, Ackermann(0,0)); - CheckEquals(7, Ackermann(2,2)); - CheckEquals(5, Ackermann(3,0)); - CheckEquals(61, Ackermann(3,3)); - CheckEquals(125, Ackermann(3,4)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Ceiling; -var - i: Integer; - e: Extended; - -begin - RandSeed := 12321; - for i := 1 to 2000 do - begin - e := random(100000) / (random(230000)+1); - CheckEquals(Math.Ceil(e), JclMath.Ceiling(e), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Factorial; -begin -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Fibonacci; -begin - CheckEquals(0, Fibonacci(0)); - CheckEquals(1, Fibonacci(1)); - CheckEquals(1, Fibonacci(2)); - CheckEquals(2, Fibonacci(3)); - CheckEquals(3, Fibonacci(4)); - CheckEquals(5, Fibonacci(5)); - CheckEquals(8, Fibonacci(6)); - CheckEquals(13, Fibonacci(7)); - CheckEquals(21, Fibonacci(8)); - CheckEquals(34, Fibonacci(9)); - CheckEquals(55, Fibonacci(10)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Floor; -var - i: Integer; - e: Extended; - -begin - RandSeed := 12321; - for i := 1 to 2000 do - begin - e := random(100000) / random(230000); - CheckEquals(Math.Floor(e), JclMath.Floor(e)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._GCD; -begin - CheckEquals(1, GCD(2,5), PrecisionTolerance); - CheckEquals(4, GCD(8,4), PrecisionTolerance); - CheckEquals(3, GCD(801,48), PrecisionTolerance); - CheckEquals(2 , GCD(80,98), PrecisionTolerance); - CheckEquals(0 , GCD(0,0), PrecisionTolerance); - CheckEquals(5 , GCD(100,5), PrecisionTolerance); - CheckEquals(50 , GCD(100,50), PrecisionTolerance); - CheckEquals(100, GCD(18700,700), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._ISqrt; -var - i,v : Integer; - -begin - for i := 1 to 10000 do - begin - v := ISqrt(i); - CheckEquals(integer(trunc(sqrt(i))),v); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._LCM; -begin - CheckEquals(0, LCM(0,0), PrecisionTolerance); - CheckEquals(300, LCM(100,150), PrecisionTolerance); - CheckEquals(600, LCM(200,150), PrecisionTolerance); - CheckEquals(400, LCM(400,50), PrecisionTolerance); - CheckEquals(10, LCM(10,10), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._NormalizeA; -begin - -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Pythagoras; -var - i: Integer; - a,b,c : Extended; - -begin - RandSeed := 86543; - - for i := 1 to 10000 do - begin - a := random(100000) / (random(20000)+1); - b := random(200000) / (random(24000)+1); - c := sqrt(a*a + b*b); - CheckEquals(c, Pythagoras(a,b), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Sgn; -var - i: Integer; - v: Integer; - -begin - RandSeed := 86543; - - for i := 1 to 10000 do - begin - v := random(MaxInt-1)+1; - CheckEquals(1, Sgn(v)); - CheckEquals(-1, Sgn(-v)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathMiscTest._Signe; -begin -end; - - -//================================================================================================== -// Rational -//================================================================================================== - -procedure TMathRationalTest._Assign; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := 1; - - RN1.Assign(n, d); - CheckEquals(n, RN1.Numerator); - CheckEquals(d, RN1.Denominator); - - RN2.Assign(RN1); - CheckEquals(n, RN2.Numerator); - CheckEquals(d, RN2.Denominator); - end; - - RN1.AssignOne; - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.AssignZero; - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Add; -begin - RN2.AssignOne; - RN1.Assign(5,5); - RN1.Add(RN2); - - CheckEquals(2, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(-5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); - CheckEquals(-5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(-3,7); RN2.Add(RN1); - CheckEquals(-23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(6,9); RN2.Add(3); - CheckEquals(11, RN2.Numerator); - CheckEquals(3, RN2.Denominator); - - RN2.Assign(2,2); RN2.Add(0.25); - CheckEquals(5, RN2.Numerator); - CheckEquals(4, RN2.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsEqual; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - RN2.Assign(RN1); - CheckEquals(True, RN2.IsEqual(RN1)); - CheckEquals(True, RN2.IsEqual(n, d)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsOne; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - CheckEquals(False, RN1.IsOne); - end; - - RN1.Assign(1); - CheckEquals(True, RN1.IsOne); - - RN1.AssignOne; - CheckEquals(True, RN1.IsOne); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._IsZero; -var - i, n, d: Integer; - -begin - RandSeed := 12345; - - for i := 1 to 1000 do - begin - n := random(100000)+1; - d := random(100000)+1; - - RN1.Assign(n, d); - CheckEquals(False, RN1.IsZero); - end; - - RN1.Assign(0); - CheckEquals(True, RN1.IsZero); - - RN1.Assignzero; - CheckEquals(True, RN1.IsZero); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Subtract; -begin - RN2.AssignOne; - RN1.Assign(5,5); - RN1.Subtract(RN2); - - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(6,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(5, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(-23, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Subtract(RN1); - CheckEquals(11, RN2.Numerator); - CheckEquals(7, RN2.Denominator); - - RN2.Assign(18,9); RN2.Subtract(19); - CheckEquals(-17, RN2.Numerator); - CheckEquals(1, RN2.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Multiply; -begin - RN2.AssignOne; RN1.Assign(5,5); RN1.Multiply(RN2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Multiply(RN1); - CheckEquals(6, RN2.Numerator); - CheckEquals(7, RN2.Denominator); - - RN2.Assign(1,9); RN1.Assign(3,7); RN2.Multiply(RN1); - CheckEquals(1, RN2.Numerator); - CheckEquals(21, RN2.Denominator); - - RN2.AssignZero; RN1.Assign(5,5); RN1.Multiply(RN2); - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Divide; -begin - RN2.AssignOne; RN1.Assign(5,5); RN1.Divide(RN2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN2.Assign(18,9); RN1.Assign(3,7); RN2.Divide(RN1); - CheckEquals(14, RN2.Numerator); - CheckEquals(3, RN2.Denominator); - - RN2.Assign(1,9); RN1.Assign(3,7); RN2.Divide(RN1); - CheckEquals(7, RN2.Numerator); - CheckEquals(27, RN2.Denominator); - - RN1.Assign(5,5); RN1.Divide(2); - CheckEquals(1, RN1.Numerator); - CheckEquals(2, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Power; -begin - RN2.Assign(18,9); RN1.Assign(18,9); RN2.Power(RN1); - CheckEquals(4, RN2.Numerator); - CheckEquals(1, RN2.Denominator); - - RN1.Assign(5,5); RN1.Power(2); - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(7,5); RN1.Power(2); - CheckEquals(49, RN1.Numerator); - CheckEquals(25, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._AsFloat; -var - e: extended; - i: Integer; - -begin - RandSeed := 123; - for i := 1 to 2000 do - begin - e := random(10000) / (random(1000)+1); - RN1.AsFloat := e; CheckEquals(e, RN1.AsFloat, 0.05); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._AsString; -var - i, i1, i2: Integer; - -begin - RandSeed := 123; - for i := 1 to 2000 do - begin - i1 := random(10000)+1; - i2 := random(1000)+1; - Rn1.AsString := inttostr(i1) + ' / ' + inttostr(i2); - RN2.Assign(i1,i2); - CheckEquals(True, RN2.IsEqual(RN1)); - end; - - Rn1.AsString := '6 / 2';; - CheckEquals(3, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Sqr; -begin - RN1.Assign(5,5); RN1.Sqr; - CheckEquals(1, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(18,9); RN1.Sqr; - CheckEquals(4, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(1,5); RN1.Sqr; - CheckEquals(1, RN1.Numerator); - CheckEquals(25, RN1.Denominator); - - RN1.Assign(3,5); RN1.Sqr; - CheckEquals(9, RN1.Numerator); - CheckEquals(25, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest._Sqrt; -begin - RN1.Assign(0,1); RN1.Sqrt; - CheckEquals(0, RN1.Numerator); - CheckEquals(1, RN1.Denominator); - - RN1.Assign(144,9); RN1.Sqrt; - CheckEquals(4, RN1.Numerator); - CheckEquals(1, RN1.Denominator); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest.SetUp; -begin - RN1 := TJclRational.Create; - RN2 := TJclRational.Create; - RN3 := TJclRational.Create; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathRationalTest.TearDown; -begin - FreeAndNil(RN1); - FreeAndNil(RN2); - FreeAndNil(RN3); -end; - -//================================================================================================== -// Exponential -//================================================================================================== - -procedure TMathExponentialTest._Exp; -var - i: Integer; - e: extended; - -begin - RandSeed := 73162; - - for i := 1 to 100 do - begin - e := Random(1000) / (Random(1000) + 1); - CheckEquals(System.exp(e),JclMath.exp(e), PrecisionTolerance); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._Power; -var - Base, Exponent: extended; - i: Integer; - -begin - RandSeed := 73162; - - for i := 1 to 100 do - begin - Base := Random(10); - Exponent := Random(10); - - CheckEquals(Math.Power(Base, Exponent),JclMath.Power(Base, Exponent), PrecisionTolerance); - end; - -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._PowerInt; -begin - CheckEquals(1, PowerInt(0,0), PrecisionTolerance); - CheckEquals(4, PowerInt(2,2), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._TenToY; -begin - CheckEquals(1,JclMath.TenToY(0), PrecisionTolerance); - CheckEquals(10,JclMath.TenToY(1), PrecisionTolerance); - CheckEquals(100,JclMath.TenToY(2), PrecisionTolerance); - CheckEquals(1000,JclMath.TenToY(3), PrecisionTolerance); - CheckEquals(0.1,JclMath.TenToY(-1), PrecisionTolerance); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathExponentialTest._TwoToY; -begin - CheckEquals(1,JclMath.TwoToY(0), PrecisionTolerance); - CheckEquals(2,JclMath.TwoToY(1), PrecisionTolerance); - CheckEquals(4,JclMath.TwoToY(2), PrecisionTolerance); - CheckEquals(8,JclMath.TwoToY(3), PrecisionTolerance); -end; - -//================================================================================================== -// FlatSet -//================================================================================================== - -procedure TMathASetTest._Invert; -begin - TSetCrack(ASet).SetBit(1, True); - TSetCrack(ASet).SetBit(2, False); - TSetCrack(ASet).Invert; - CheckEquals(False, TSetCrack(ASet).GetBit(1)); - CheckEquals(True, TSetCrack(ASet).GetBit(2)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest._SetGet; -var - i,t : Integer; - -begin - for i := 0 to 1000 do - begin - TSetCrack(ASet).SetBit(i, True); - CheckEquals(True, TSetCrack(ASet).GetBit(i)); - TSetCrack(ASet).SetBit(i, False); - CheckEquals(False, TSetCrack(ASet).GetBit(i)); - end; - - for i := 0 to 20 do - begin - TSetCrack(ASet).SetBit(i, True); - - for t := 0 to i do - CheckEquals(True, TSetCrack(ASet).GetBit(t)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest._SetGetRange; -var - i: Integer; - b: Boolean; - -begin - TSetCrack(ASet).SetRange(0, 100, True); - - for i := 0 to 100 do - CheckEquals(True, TSetCrack(ASet).GetBit(i)); - - B := TSetCrack(ASet).GetRange(0, 100, True); - CheckEquals(True, B); - - TSetCrack(ASet).SetRange(50, 101, False); - - for i := 50 to 101 do - CheckEquals(False, TSetCrack(ASet).GetBit(i)); - - B := TSetCrack(ASet).GetRange(50, 101, False); - CheckEquals(True, B); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathFlatSetTest.SetUp; -begin - ASet := TJclFlatSet.Create; - TSetCrack(ASet).SetBit(1, True); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathASetTest.TearDown; -begin - ASet.Free; -end; - -//================================================================================================== -// Prime numbers -//================================================================================================== - -procedure TMathPrimeTest._IsPrime; - - function GetFactor(N: Longint): Longint; { from a usenet post - completely tested } - var - I,M,Act: Word; - begin - if N<=0 then - RunError(215); { Arithmetic Overflow if zero or below } - if Lo(N) and 1=0 then begin { can be divided by 2? } - GetFactor:=2; - Exit; - end; - if N mod 3=0 then begin { can be divided by 3? } - GetFactor:=3; - Exit; - end; - Act:=5; { next number to be tested } - I:=2; { next increment of the test number } - M:=Trunc(Sqrt(N)); - while (Act<=M) and (N mod Act>0) do begin { test for division } - Inc(Act,I); - I:=6-I; { alternate I between 2 and 4 } - end; - if Act > M then { factor found? } - GetFactor := N { no } - else - GetFactor:=Act; { yes } - end; - - function IsPrimeAlternative(N: Longint): Boolean; - begin - Result :=(N>1) and (GetFactor(N)=N); - end; - -var - i: Integer; - tm: TPrimalityTestMethod; - -begin - for tm := Low(TPrimalityTestMethod) to High(TPrimalityTestMethod) do - begin - SetPrimalityTest(TPrimalityTestMethod(tm)); - - CheckEquals(False, IsPrime(0)); - CheckEquals(False, IsPrime(1)); - CheckEquals(True, IsPrime(2)); - - for i := 1 to 4000 do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - - for i := MaxInt - 4000 to MaxInt do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - - for i := (MaxInt div 2) - 2000 to (MaxInt div 2) + 2000 do - CheckEquals(IsPrimeAlternative(i), IsPrime(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathPrimeTest._IsRelativePrime; -begin - CheckEquals(True, IsRelativePrime(1,4)); - CheckEquals(True, IsRelativePrime(3,4)); - CheckEquals(True, IsRelativePrime(13,19)); - CheckEquals(True, IsRelativePrime(17,99)); - CheckEquals(False, IsRelativePrime(0,4)); - CheckEquals(False, IsRelativePrime(2,4)); -end; - -//================================================================================================== -// NaN and Inf support -//================================================================================================== - -procedure TMathInfNanSupportTest._IsInfinite; -begin -// s := Infinity; -// d := JclMath.Infinity; -// e := Infinity; -// CheckEquals(True, IsInfinite(s)); -// CheckEquals(True, IsInfinite(d)); -// CheckEquals(True, IsInfinite(e)); -// -// s := 0; -// d := 0; -// e := 0; -// CheckEquals(False, IsInfinite(s)); -// CheckEquals(False, IsInfinite(d)); -// CheckEquals(False, IsInfinite(e)); -// -// s := NaN; -// d := NaN; -// e := NaN; -// CheckEquals(False, IsInfinite(s)); -// CheckEquals(False, IsInfinite(d)); -// CheckEquals(False, IsInfinite(e)); -// -// s := NegInfinity; -// d := NegInfinity; -// e := NegInfinity; -// CheckEquals(True, IsInfinite(s)); -// CheckEquals(True, IsInfinite(d)); -// CheckEquals(True, IsInfinite(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._IsNaN; -begin - s := Infinity; - d := JclMath.Infinity; - e := Infinity; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); - - s := 0; - d := 0; - e := 0; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); - - s := NaN; - d := NaN; - e := NaN; - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - CheckEquals(False, JclMath.IsNan(s)); - CheckEquals(False, JclMath.IsNan(d)); - CheckEquals(False, JclMath.IsNan(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._IsSpecialValue; -begin - s := Infinity; - d := JclMath.Infinity; - e := Infinity; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); - - s := 0; - d := 0; - e := 0; - CheckEquals(False, IsSpecialValue(s)); - CheckEquals(False, IsSpecialValue(d)); - CheckEquals(False, IsSpecialValue(e)); - - s := NaN; - d := NaN; - e := NaN; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); - - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - CheckEquals(True, IsSpecialValue(s)); - CheckEquals(True, IsSpecialValue(d)); - CheckEquals(True, IsSpecialValue(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._MakeQuietNaN; -begin - s := NegInfinity; - d := NegInfinity; - e := NegInfinity; - - MakeQuietNaN(s, 0); - MakeQuietNaN(d, 0); - MakeQuietNaN(e, 0); - - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - MakeQuietNaN(s, 1); - MakeQuietNaN(d, 2); - MakeQuietNaN(e, 3); - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TMathInfNanSupportTest._GetNaNTag; -var - i: Integer; - -begin - for i := 1 to 8000 do - begin - MakeQuietNaN(s, i); - MakeQuietNaN(d, i); - MakeQuietNaN(e, i); - CheckEquals(True, JclMath.IsNan(s)); - CheckEquals(True, JclMath.IsNan(d)); - CheckEquals(True, JclMath.IsNan(e)); - - CheckEquals(i, GetNaNTag(s)); - CheckEquals(i, GetNaNTag(d)); - CheckEquals(i, GetNaNTag(e)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -initialization - RegisterTest('JCLMath', TMathLogarithmicTest.Suite); - RegisterTest('JCLMath', TMathTranscendentalTest.Suite); - RegisterTest('JCLMath', TMathMiscTest.Suite); - RegisterTest('JCLMath', TMathRationalTest.Suite); - RegisterTest('JCLMath', TMathExponentialTest.Suite); - RegisterTest('JCLMath', TMathFlatSetTest.Suite); - RegisterTest('JCLMath', TMathPrimeTest.Suite); - RegisterTest('JCLMath', TMathInfNanSupportTest.Suite); -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test } +{ } +{ Last Update: 19-Jan-2002 } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +unit TestJclMath; + +interface +uses + TestFramework, +{$IFDEF MSWINDOWS} + Windows, +{$ENDIF MSWINDOWS} +{$IFDEF VCL} + Dialogs, +{$ENDIF VCL} + Classes, + SysUtils, + Math, + JclMath; + +{ TMathLogarithmicTest } + +type + TMathLogarithmicTest = class (TTestCase) + published + procedure _LogBase10; + procedure _LogBase2; + procedure _LogBaseN; + end; + +type + TMathTranscendentalTest = class (TTestCase) + published + procedure _ArcCos; + procedure _ArcCot; + procedure _ArcCsc; + procedure _ArcSec; + procedure _ArcSin; + procedure _ArcTan; + procedure _ArcTan2; + procedure _Cos; + procedure _Cot; + procedure _Csc; + procedure _Sec; + procedure _Sin; + procedure _SinCos; + procedure _Tan; + end; + +type + TMathMiscTest = class (TTestCase) + published + procedure _Ackermann; + procedure _Ceiling; + procedure _Factorial; + procedure _Fibonacci; + procedure _Floor; + procedure _GCD; + procedure _ISqrt; + procedure _LCM; + procedure _NormalizeA; + procedure _Pythagoras; + procedure _Sgn; + procedure _Signe; + end; + +type + TMathRationalTest = class(TTestCase) + private + RN1: TJclRational; + RN2: TJclRational; + RN3: TJclRational; + protected + procedure SetUp; override; + procedure TearDown; override; + + published + procedure _Assign; + procedure _Add; + procedure _IsEqual; + procedure _IsZero; + procedure _IsOne; + procedure _Subtract; + procedure _Multiply; + procedure _Divide; + procedure _Power; + procedure _AsFloat; + procedure _AsString; + procedure _Sqr; + procedure _Sqrt; + end; + +type + TMathExponentialTest = class(TTestCase) + published + procedure _Exp; + procedure _Power; + procedure _PowerInt; + procedure _TenToY; + procedure _TwoToY; + end; + +type + TMathPrimeTest = class(TTestCase) + published + procedure _IsPrime; + procedure _IsRelativePrime; + end; + +type + TMathInfNanSupportTest = class(TTestCase) + private + s: single; + d: Double; + e: Extended; + + published + procedure _IsInfinite; + procedure _IsNaN; + procedure _IsSpecialValue; + procedure _MakeQuietNaN; + procedure _GetNaNTag; + end; + +type + TSetCrack = class(TJclASet); + +type + TMathASetTest = class(TTestCase) + protected + ASet: TJclASet; + procedure TearDown; override; + + published + procedure _Invert; + procedure _SetGet; + procedure _SetGetRange; + end; + + TMathFlatSetTest = class(TMathASetTest) + protected + procedure SetUp; override; + end; + +implementation + +//================================================================================================== +// Logarithmic +//================================================================================================== + +procedure TMathLogarithmicTest._LogBase10; +var + x: Extended; + +begin + x := 0.1; + while x < 100 do + begin + CheckEquals(Log10(x), LogBase10(x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathLogarithmicTest._LogBase2; +var + x: Extended; + +begin + x := 0.1; + while x < 100 do + begin + CheckEquals(Math.Log2(x), LogBase2(x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathLogarithmicTest._LogBaseN; +var + x: Extended; + Base: Integer; + +begin + x := 0.1; + for Base := 2 to 60 do + while x < 100 do + begin + CheckEquals(Math.LogN(Base, x), LogBaseN(Base, x), PrecisionTolerance); + x := x + 0.5; + end; +end; + +//================================================================================================== +// Transcendental +//================================================================================================== + +procedure TMathTranscendentalTest._ArcCos; +var + x: Extended; + +begin + x := -0.98; + + while x < 1 do + begin + CheckEquals(Math.ArcCos(X), JclMath.ArcCos(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcCot; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcCsc; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcSec; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcSin; +var + x: Extended; + +begin + x := -0.98; + + while x < 1 do + begin + CheckEquals(Math.ArcSin(X), JclMath.ArcSin(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcTan; +var + x: Extended; + +begin + x := -Pi; + + while x < Pi do + begin + if x <> 0 then + CheckEquals(System.ArcTan(X), JclMath.ArcTan(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._ArcTan2; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Cos; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(System.Cos(X), JclMath.Cos(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Cot; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Csc; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Sec; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Sin; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(System.Sin(X), JclMath.Sin(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._SinCos; +var + x, s, c: Extended; + +begin +// x := -Pi; +// +// while x <= Pi do +// begin +// SinCos(x, s, c); +// +// CheckEquals(System.Sin(X), s, PrecisionTolerance); +// CheckEquals(System.Cos(X), c, PrecisionTolerance); +// x := x + 0.1; +// end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathTranscendentalTest._Tan; +var + x: Extended; + +begin + x := -Pi; + + while x <= Pi do + begin + CheckEquals(Math.Tan(X), JclMath.Tan(X), PrecisionTolerance); + x := x + 0.1; + end; +end; + + +//================================================================================================== +// Hyperbolic +//================================================================================================== + + +//================================================================================================== +// Miscellaneous +//================================================================================================== + +procedure TMathMiscTest._Ackermann; +begin + CheckEquals(1, Ackermann(0,0)); + CheckEquals(7, Ackermann(2,2)); + CheckEquals(5, Ackermann(3,0)); + CheckEquals(61, Ackermann(3,3)); + CheckEquals(125, Ackermann(3,4)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Ceiling; +var + i: Integer; + e: Extended; + +begin + RandSeed := 12321; + for i := 1 to 2000 do + begin + e := random(100000) / (random(230000)+1); + CheckEquals(Math.Ceil(e), JclMath.Ceiling(e), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Factorial; +begin +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Fibonacci; +begin + CheckEquals(0, Fibonacci(0)); + CheckEquals(1, Fibonacci(1)); + CheckEquals(1, Fibonacci(2)); + CheckEquals(2, Fibonacci(3)); + CheckEquals(3, Fibonacci(4)); + CheckEquals(5, Fibonacci(5)); + CheckEquals(8, Fibonacci(6)); + CheckEquals(13, Fibonacci(7)); + CheckEquals(21, Fibonacci(8)); + CheckEquals(34, Fibonacci(9)); + CheckEquals(55, Fibonacci(10)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Floor; +var + i: Integer; + e: Extended; + +begin + RandSeed := 12321; + for i := 1 to 2000 do + begin + e := random(100000) / random(230000); + CheckEquals(Math.Floor(e), JclMath.Floor(e)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._GCD; +begin + CheckEquals(1, GCD(2,5), PrecisionTolerance); + CheckEquals(4, GCD(8,4), PrecisionTolerance); + CheckEquals(3, GCD(801,48), PrecisionTolerance); + CheckEquals(2 , GCD(80,98), PrecisionTolerance); + CheckEquals(0 , GCD(0,0), PrecisionTolerance); + CheckEquals(5 , GCD(100,5), PrecisionTolerance); + CheckEquals(50 , GCD(100,50), PrecisionTolerance); + CheckEquals(100, GCD(18700,700), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._ISqrt; +var + i,v : Integer; + +begin + for i := 1 to 10000 do + begin + v := ISqrt(i); + CheckEquals(integer(trunc(sqrt(i))),v); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._LCM; +begin + CheckEquals(0, LCM(0,0), PrecisionTolerance); + CheckEquals(300, LCM(100,150), PrecisionTolerance); + CheckEquals(600, LCM(200,150), PrecisionTolerance); + CheckEquals(400, LCM(400,50), PrecisionTolerance); + CheckEquals(10, LCM(10,10), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._NormalizeA; +begin + +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Pythagoras; +var + i: Integer; + a,b,c : Extended; + +begin + RandSeed := 86543; + + for i := 1 to 10000 do + begin + a := random(100000) / (random(20000)+1); + b := random(200000) / (random(24000)+1); + c := sqrt(a*a + b*b); + CheckEquals(c, Pythagoras(a,b), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Sgn; +var + i: Integer; + v: Integer; + +begin + RandSeed := 86543; + + for i := 1 to 10000 do + begin + v := random(MaxInt-1)+1; + CheckEquals(1, Sgn(v)); + CheckEquals(-1, Sgn(-v)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathMiscTest._Signe; +begin +end; + + +//================================================================================================== +// Rational +//================================================================================================== + +procedure TMathRationalTest._Assign; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := 1; + + RN1.Assign(n, d); + CheckEquals(n, RN1.Numerator); + CheckEquals(d, RN1.Denominator); + + RN2.Assign(RN1); + CheckEquals(n, RN2.Numerator); + CheckEquals(d, RN2.Denominator); + end; + + RN1.AssignOne; + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.AssignZero; + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Add; +begin + RN2.AssignOne; + RN1.Assign(5,5); + RN1.Add(RN2); + + CheckEquals(2, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(-5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Add(RN1); + CheckEquals(-5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(-3,7); RN2.Add(RN1); + CheckEquals(-23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(6,9); RN2.Add(3); + CheckEquals(11, RN2.Numerator); + CheckEquals(3, RN2.Denominator); + + RN2.Assign(2,2); RN2.Add(0.25); + CheckEquals(5, RN2.Numerator); + CheckEquals(4, RN2.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsEqual; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + RN2.Assign(RN1); + CheckEquals(True, RN2.IsEqual(RN1)); + CheckEquals(True, RN2.IsEqual(n, d)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsOne; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + CheckEquals(False, RN1.IsOne); + end; + + RN1.Assign(1); + CheckEquals(True, RN1.IsOne); + + RN1.AssignOne; + CheckEquals(True, RN1.IsOne); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._IsZero; +var + i, n, d: Integer; + +begin + RandSeed := 12345; + + for i := 1 to 1000 do + begin + n := random(100000)+1; + d := random(100000)+1; + + RN1.Assign(n, d); + CheckEquals(False, RN1.IsZero); + end; + + RN1.Assign(0); + CheckEquals(True, RN1.IsZero); + + RN1.Assignzero; + CheckEquals(True, RN1.IsZero); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Subtract; +begin + RN2.AssignOne; + RN1.Assign(5,5); + RN1.Subtract(RN2); + + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(6,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(5, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(-6,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(-23, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Subtract(RN1); + CheckEquals(11, RN2.Numerator); + CheckEquals(7, RN2.Denominator); + + RN2.Assign(18,9); RN2.Subtract(19); + CheckEquals(-17, RN2.Numerator); + CheckEquals(1, RN2.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Multiply; +begin + RN2.AssignOne; RN1.Assign(5,5); RN1.Multiply(RN2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Multiply(RN1); + CheckEquals(6, RN2.Numerator); + CheckEquals(7, RN2.Denominator); + + RN2.Assign(1,9); RN1.Assign(3,7); RN2.Multiply(RN1); + CheckEquals(1, RN2.Numerator); + CheckEquals(21, RN2.Denominator); + + RN2.AssignZero; RN1.Assign(5,5); RN1.Multiply(RN2); + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Divide; +begin + RN2.AssignOne; RN1.Assign(5,5); RN1.Divide(RN2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN2.Assign(18,9); RN1.Assign(3,7); RN2.Divide(RN1); + CheckEquals(14, RN2.Numerator); + CheckEquals(3, RN2.Denominator); + + RN2.Assign(1,9); RN1.Assign(3,7); RN2.Divide(RN1); + CheckEquals(7, RN2.Numerator); + CheckEquals(27, RN2.Denominator); + + RN1.Assign(5,5); RN1.Divide(2); + CheckEquals(1, RN1.Numerator); + CheckEquals(2, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Power; +begin + RN2.Assign(18,9); RN1.Assign(18,9); RN2.Power(RN1); + CheckEquals(4, RN2.Numerator); + CheckEquals(1, RN2.Denominator); + + RN1.Assign(5,5); RN1.Power(2); + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(7,5); RN1.Power(2); + CheckEquals(49, RN1.Numerator); + CheckEquals(25, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._AsFloat; +var + e: extended; + i: Integer; + +begin + RandSeed := 123; + for i := 1 to 2000 do + begin + e := random(10000) / (random(1000)+1); + RN1.AsFloat := e; CheckEquals(e, RN1.AsFloat, 0.05); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._AsString; +var + i, i1, i2: Integer; + +begin + RandSeed := 123; + for i := 1 to 2000 do + begin + i1 := random(10000)+1; + i2 := random(1000)+1; + Rn1.AsString := inttostr(i1) + ' / ' + inttostr(i2); + RN2.Assign(i1,i2); + CheckEquals(True, RN2.IsEqual(RN1)); + end; + + Rn1.AsString := '6 / 2';; + CheckEquals(3, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Sqr; +begin + RN1.Assign(5,5); RN1.Sqr; + CheckEquals(1, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(18,9); RN1.Sqr; + CheckEquals(4, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(1,5); RN1.Sqr; + CheckEquals(1, RN1.Numerator); + CheckEquals(25, RN1.Denominator); + + RN1.Assign(3,5); RN1.Sqr; + CheckEquals(9, RN1.Numerator); + CheckEquals(25, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest._Sqrt; +begin + RN1.Assign(0,1); RN1.Sqrt; + CheckEquals(0, RN1.Numerator); + CheckEquals(1, RN1.Denominator); + + RN1.Assign(144,9); RN1.Sqrt; + CheckEquals(4, RN1.Numerator); + CheckEquals(1, RN1.Denominator); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest.SetUp; +begin + RN1 := TJclRational.Create; + RN2 := TJclRational.Create; + RN3 := TJclRational.Create; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathRationalTest.TearDown; +begin + FreeAndNil(RN1); + FreeAndNil(RN2); + FreeAndNil(RN3); +end; + +//================================================================================================== +// Exponential +//================================================================================================== + +procedure TMathExponentialTest._Exp; +var + i: Integer; + e: extended; + +begin + RandSeed := 73162; + + for i := 1 to 100 do + begin + e := Random(1000) / (Random(1000) + 1); + CheckEquals(System.exp(e),JclMath.exp(e), PrecisionTolerance); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._Power; +var + Base, Exponent: extended; + i: Integer; + +begin + RandSeed := 73162; + + for i := 1 to 100 do + begin + Base := Random(10); + Exponent := Random(10); + + CheckEquals(Math.Power(Base, Exponent),JclMath.Power(Base, Exponent), PrecisionTolerance); + end; + +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._PowerInt; +begin + CheckEquals(1, PowerInt(0,0), PrecisionTolerance); + CheckEquals(4, PowerInt(2,2), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._TenToY; +begin + CheckEquals(1,JclMath.TenToY(0), PrecisionTolerance); + CheckEquals(10,JclMath.TenToY(1), PrecisionTolerance); + CheckEquals(100,JclMath.TenToY(2), PrecisionTolerance); + CheckEquals(1000,JclMath.TenToY(3), PrecisionTolerance); + CheckEquals(0.1,JclMath.TenToY(-1), PrecisionTolerance); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathExponentialTest._TwoToY; +begin + CheckEquals(1,JclMath.TwoToY(0), PrecisionTolerance); + CheckEquals(2,JclMath.TwoToY(1), PrecisionTolerance); + CheckEquals(4,JclMath.TwoToY(2), PrecisionTolerance); + CheckEquals(8,JclMath.TwoToY(3), PrecisionTolerance); +end; + +//================================================================================================== +// FlatSet +//================================================================================================== + +procedure TMathASetTest._Invert; +begin + TSetCrack(ASet).SetBit(1, True); + TSetCrack(ASet).SetBit(2, False); + TSetCrack(ASet).Invert; + CheckEquals(False, TSetCrack(ASet).GetBit(1)); + CheckEquals(True, TSetCrack(ASet).GetBit(2)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest._SetGet; +var + i,t : Integer; + +begin + for i := 0 to 1000 do + begin + TSetCrack(ASet).SetBit(i, True); + CheckEquals(True, TSetCrack(ASet).GetBit(i)); + TSetCrack(ASet).SetBit(i, False); + CheckEquals(False, TSetCrack(ASet).GetBit(i)); + end; + + for i := 0 to 20 do + begin + TSetCrack(ASet).SetBit(i, True); + + for t := 0 to i do + CheckEquals(True, TSetCrack(ASet).GetBit(t)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest._SetGetRange; +var + i: Integer; + b: Boolean; + +begin + TSetCrack(ASet).SetRange(0, 100, True); + + for i := 0 to 100 do + CheckEquals(True, TSetCrack(ASet).GetBit(i)); + + B := TSetCrack(ASet).GetRange(0, 100, True); + CheckEquals(True, B); + + TSetCrack(ASet).SetRange(50, 101, False); + + for i := 50 to 101 do + CheckEquals(False, TSetCrack(ASet).GetBit(i)); + + B := TSetCrack(ASet).GetRange(50, 101, False); + CheckEquals(True, B); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathFlatSetTest.SetUp; +begin + ASet := TJclFlatSet.Create; + TSetCrack(ASet).SetBit(1, True); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathASetTest.TearDown; +begin + ASet.Free; +end; + +//================================================================================================== +// Prime numbers +//================================================================================================== + +procedure TMathPrimeTest._IsPrime; + + function GetFactor(N: Longint): Longint; { from a usenet post - completely tested } + var + I,M,Act: Word; + begin + if N<=0 then + RunError(215); { Arithmetic Overflow if zero or below } + if Lo(N) and 1=0 then begin { can be divided by 2? } + GetFactor:=2; + Exit; + end; + if N mod 3=0 then begin { can be divided by 3? } + GetFactor:=3; + Exit; + end; + Act:=5; { next number to be tested } + I:=2; { next increment of the test number } + M:=Trunc(Sqrt(N)); + while (Act<=M) and (N mod Act>0) do begin { test for division } + Inc(Act,I); + I:=6-I; { alternate I between 2 and 4 } + end; + if Act > M then { factor found? } + GetFactor := N { no } + else + GetFactor:=Act; { yes } + end; + + function IsPrimeAlternative(N: Longint): Boolean; + begin + Result :=(N>1) and (GetFactor(N)=N); + end; + +var + i: Integer; + tm: TPrimalityTestMethod; + +begin + for tm := Low(TPrimalityTestMethod) to High(TPrimalityTestMethod) do + begin + SetPrimalityTest(TPrimalityTestMethod(tm)); + + CheckEquals(False, IsPrime(0)); + CheckEquals(False, IsPrime(1)); + CheckEquals(True, IsPrime(2)); + + for i := 1 to 4000 do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + + for i := MaxInt - 4000 to MaxInt do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + + for i := (MaxInt div 2) - 2000 to (MaxInt div 2) + 2000 do + CheckEquals(IsPrimeAlternative(i), IsPrime(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathPrimeTest._IsRelativePrime; +begin + CheckEquals(True, IsRelativePrime(1,4)); + CheckEquals(True, IsRelativePrime(3,4)); + CheckEquals(True, IsRelativePrime(13,19)); + CheckEquals(True, IsRelativePrime(17,99)); + CheckEquals(False, IsRelativePrime(0,4)); + CheckEquals(False, IsRelativePrime(2,4)); +end; + +//================================================================================================== +// NaN and Inf support +//================================================================================================== + +procedure TMathInfNanSupportTest._IsInfinite; +begin +// s := Infinity; +// d := JclMath.Infinity; +// e := Infinity; +// CheckEquals(True, IsInfinite(s)); +// CheckEquals(True, IsInfinite(d)); +// CheckEquals(True, IsInfinite(e)); +// +// s := 0; +// d := 0; +// e := 0; +// CheckEquals(False, IsInfinite(s)); +// CheckEquals(False, IsInfinite(d)); +// CheckEquals(False, IsInfinite(e)); +// +// s := NaN; +// d := NaN; +// e := NaN; +// CheckEquals(False, IsInfinite(s)); +// CheckEquals(False, IsInfinite(d)); +// CheckEquals(False, IsInfinite(e)); +// +// s := NegInfinity; +// d := NegInfinity; +// e := NegInfinity; +// CheckEquals(True, IsInfinite(s)); +// CheckEquals(True, IsInfinite(d)); +// CheckEquals(True, IsInfinite(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._IsNaN; +begin + s := Infinity; + d := JclMath.Infinity; + e := Infinity; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); + + s := 0; + d := 0; + e := 0; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); + + s := NaN; + d := NaN; + e := NaN; + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + CheckEquals(False, JclMath.IsNan(s)); + CheckEquals(False, JclMath.IsNan(d)); + CheckEquals(False, JclMath.IsNan(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._IsSpecialValue; +begin + s := Infinity; + d := JclMath.Infinity; + e := Infinity; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); + + s := 0; + d := 0; + e := 0; + CheckEquals(False, IsSpecialValue(s)); + CheckEquals(False, IsSpecialValue(d)); + CheckEquals(False, IsSpecialValue(e)); + + s := NaN; + d := NaN; + e := NaN; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); + + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + CheckEquals(True, IsSpecialValue(s)); + CheckEquals(True, IsSpecialValue(d)); + CheckEquals(True, IsSpecialValue(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._MakeQuietNaN; +begin + s := NegInfinity; + d := NegInfinity; + e := NegInfinity; + + MakeQuietNaN(s, 0); + MakeQuietNaN(d, 0); + MakeQuietNaN(e, 0); + + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + MakeQuietNaN(s, 1); + MakeQuietNaN(d, 2); + MakeQuietNaN(e, 3); + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TMathInfNanSupportTest._GetNaNTag; +var + i: Integer; + +begin + for i := 1 to 8000 do + begin + MakeQuietNaN(s, i); + MakeQuietNaN(d, i); + MakeQuietNaN(e, i); + CheckEquals(True, JclMath.IsNan(s)); + CheckEquals(True, JclMath.IsNan(d)); + CheckEquals(True, JclMath.IsNan(e)); + + CheckEquals(i, GetNaNTag(s)); + CheckEquals(i, GetNaNTag(d)); + CheckEquals(i, GetNaNTag(e)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +initialization + RegisterTest('JCLMath', TMathLogarithmicTest.Suite); + RegisterTest('JCLMath', TMathTranscendentalTest.Suite); + RegisterTest('JCLMath', TMathMiscTest.Suite); + RegisterTest('JCLMath', TMathRationalTest.Suite); + RegisterTest('JCLMath', TMathExponentialTest.Suite); + RegisterTest('JCLMath', TMathFlatSetTest.Suite); + RegisterTest('JCLMath', TMathPrimeTest.Suite); + RegisterTest('JCLMath', TMathInfNanSupportTest.Suite); +end. diff --git a/qa/automated/dunit/units/TestJclStrings.pas b/qa/automated/dunit/units/TestJclStrings.pas index d748eb567c..b3f60154d8 100644 --- a/qa/automated/dunit/units/TestJclStrings.pas +++ b/qa/automated/dunit/units/TestJclStrings.pas @@ -1,3743 +1,3743 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ DUnit Test Unit } -{ } -{ Covers: JclStrings } -{ Last Update: $Date$ } -{ } -{ 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. } -{ } -{**************************************************************************************************} - -unit TestJclStrings; - -interface -uses - TestFramework, - {$IFDEF MSWINDOWS} - Windows, - {$ELSE} - Types, - {$ENDIF} - Classes, - SysUtils, - JclStrings, - JclStringLists; - -{ TJclStringCharacterTestRoutines } - -type - TJclStringCharacterTestRoutines = class(TTestCase) - private - published - procedure _CharEqualNoCase; - procedure _CharIsAlpha; - procedure _CharIsAlphaNum; - procedure _CharIsBlank; - procedure _CharIsControl; - procedure _CharIsDelete; - procedure _CharIsDigit; - procedure _CharIsNumberChar; - procedure _CharIsPrintable; - procedure _CharIsPunctuation; - procedure _CharIsReturn; - procedure _CharIsSpace; - procedure _CharIsWhiteSpace; - procedure _CharIsUpper; - procedure _CharIsLower; -end; - - -{ TJclStringTransformation } - -type - TJclStringTransformation = class (TTestCase) - private - StringArray : array[0..5000] of string; - StringArray2 : array[0..5000] of string; - - published - { String Transformation } - procedure _StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; - procedure _Deprecated_StrContainsChars_StrIsSubset1; - procedure _StringMatchingAgainstChars; - procedure _StrSame; - procedure _StrIsDigit_StrConsistsOfNumberChars; - procedure _StrCenter; - procedure _StrCharPosLower; - procedure _StrCharPosUpper; - procedure _StrDoubleQuote; - procedure _StrEnsurePrefix; - procedure _StrEnsureSuffix; - procedure _StrEscapedToString_StrStringToEscaped; - procedure _StrLower_StrLowerInPlace_StrLowerBuff; - procedure _StrMove; - procedure _StrPadLeft; - procedure _StrPadRight; - procedure _StrProper_StrProperBuff; - procedure _StrQuote; - procedure _StrReplace; - procedure _StrReplaceChar; - procedure _StrReplaceChars; - procedure _StrReplacebutChars; - procedure _StrRemoveChars; - procedure _StrKeepChars; - procedure _StrRepeat; - procedure _StrRepeatLength; - procedure _StrReverse_StrReverseInPlace; - procedure _StrSingleQuote; - procedure _StrSmartCase; - procedure _StrStripNonNumberChars; - procedure _StrToHex_Ansi; - procedure _StrTrimCharLeft; - procedure _StrTrimCharsLeft; - procedure _StrTrimCharRight; - procedure _StrTrimCharsRight; - procedure _StrTrimQuotes; - procedure _StrUpper_StrUpperInPlace_StrUpperBuff; - end; - - { TJclStringManagment } - - TJclStringManagment = class (TTestCase) - published - procedure StringManagement; - end; - - { TJclStringSearchandReplace } - - TJclStringSearchandReplace = class (TTestCase) - private - StringArray: array[0..5000] of string; - StringArray2: array[0..5000] of string; - ResultArray: array[0..5000] of Integer; - fillIdx: Integer; - procedure AddCheck(const s1, s2: string; const res: Integer); - function NormalizeCompareResult(res: Integer): Integer; - procedure TestCompare(idx: Integer; res: Integer; msgFmt: string); - published - procedure _CompareNaturalStr; - procedure _CompareNaturalText; - procedure _StrCharCount; - procedure _StrCharsCount; - procedure _StrStrCount; - procedure _StrCompare; - procedure _StrCompareRange; - procedure _StrFillChar; - procedure _StrFind; - procedure _StrHasPrefix; - procedure _StrIHasPrefix; - procedure _StrIndex; - procedure _StrILastPos; - procedure _StrIPos; - procedure _StrIPrefixIndex; - procedure _StrIsOneOf; - procedure _StrLastPos; - procedure _StrMatch; - procedure _StrNPos; - procedure _StrMatches; - procedure _StrNIPos; - procedure _StrPrefixIndex; - procedure _StrSearch; - end; - - { TJclStringExtraction } - - TJclStringExtraction = class (TTestCase) - published - procedure _StrAfter; - procedure _StrBefore; - procedure _StrBetween; - procedure _StrChopRight; - procedure _StrLeft; - procedure _StrMid; - procedure _StrRight; - procedure _StrRestOf; - end; - - { TJclStringTabSet } - TJclStringTabSet = class(TTestCase) - published - procedure _CalculatedTabWidth; - procedure _Clone; - procedure _Expand; - procedure _FromString; - procedure _NilSet; - procedure _OptimalFill; - procedure _Optimize; - procedure _Referencing; - procedure _TabFrom; - procedure _TabStopAdding; - procedure _TabStopDeleting; - procedure _TabStopModifying; - procedure _ToString; - procedure _UpdatePosition; - procedure _ZeroBased; -end; - - { TJclStringManagment } - - TAnsiStringListTest = class (TTestCase) - published - procedure _SetCommaTextCount; - procedure _GetCommaTextCount; - procedure _GetCommaTextSpacedCount; - procedure _SetCommaTextProperties; - procedure _SetCommaTextQuotedProperties; - procedure _SetCommaTextQuotedSpacedProperties; - procedure _GetCommaTextQuotedProperties; - procedure _SetCommaTextInnerQuotesProperties; - procedure _GetCommaTextInnerQuotesProperties; - procedure _SetDelimitedTextCommaDoubleQuoteFalse; - procedure _GetDelimitedTextCommaDoubleQuoteFalse; - procedure _SetDelimitedTextCommaDoubleQuoteTrue; - procedure _GetDelimitedTextCommaDoubleQuoteTrue; - procedure _SetDelimitedTextFunkyFalse; - procedure _GetDelimitedTextFunkyFalse; - end; - - TJclStringListTest = class (TTestCase) - published - procedure _SetCommaTextCount; - procedure _GetCommaTextCount; - procedure _GetCommaTextSpacedCount; - procedure _SetCommaTextProperties; - procedure _SetCommaTextQuotedProperties; - procedure _SetCommaTextQuotedSpacedProperties; - procedure _GetCommaTextQuotedProperties; - procedure _SetCommaTextInnerQuotesProperties; - procedure _GetCommaTextInnerQuotesProperties; - procedure _SetDelimitedTextCommaDoubleQuoteFalse; - procedure _GetDelimitedTextCommaDoubleQuoteFalse; - procedure _SetDelimitedTextCommaDoubleQuoteTrue; - procedure _GetDelimitedTextCommaDoubleQuoteTrue; - procedure _SetDelimitedTextFunkyFalse; - procedure _GetDelimitedTextFunkyFalse; - procedure _SplitJoin; - end; - -implementation - -{$IFDEF LINUX} -uses - LibC; -{$ENDIF LINUX} -{$IFDEF WIN32} -const - LibC = 'msvcrt40.dll'; - -function isalnum(C: Integer): LongBool; cdecl; external LibC; -function isalpha(C: Integer): LongBool; cdecl; external LibC; -{$ENDIF WIN32} - -//----------------------------------------------------------------------------------------------- -// Generators -//----------------------------------------------------------------------------------------------- - -procedure GenerateAlpha(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 785378134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - v := random(2); - case v of - 0: s := s + chr(ord('a') + d); - 1: s := s + chr(ord('A') + d); - end; - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaLowerCase(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - s: string; - -begin - RandSeed := 728134; // Everything has to be reproducible - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - s := s + chr(ord('a') + d); - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaUpperCase(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - s: string; - -begin - RandSeed := 728134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - s := s + chr(ord('A') + d); - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAlphaNum(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 785378134; // Everything has to be reproducible - - if RandLen then - Len := random(Len) + 1; - - for t := 1 to Count do - begin - s := ''; - - for i := 1 to Len do - begin - d := random(Ord('z')-Ord('a'))+1; - case random(2) of - 0: begin - v := random(2); - case v of - 0: s := s + chr(ord('a') + d); - 1: s := s + chr(ord('A') + d); - end; - end; - 1: begin - d := random(Ord('9')-Ord('0')); - s := s + chr(ord('0') + d); - end; - end; - end; - - Strings[t-1] := s; - end; -end; - -//------------------------------------------------------------------------------ - -procedure GenerateAll(Len: Cardinal; const Count: Cardinal; - var Strings: array of string; RandLen: Boolean = False); -var - i: integer; - t: Integer; - d: Integer; - v: Integer; - s: string; - -begin - RandSeed := 781134; // Everything has to be reproducible - v := Len; - - for t := 1 to Count do - begin - s := ''; - - if RandLen then - Len := random(v) + 1; - - for i := 1 to Len do - begin - d := random(255); - s := s + chr(1+d); - end; - - Strings[t-1] := s; - end; -end; - -function StrLower2(const S: AnsiString): AnsiString; -var sTemp: String; -begin - sTemp := S; - StrLowerInPlace(sTemp); - Result := sTemp; -end; - -//================================================================================================== -// TJclStringTransformation -//================================================================================================== - -procedure TJclStringTransformation._StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; -var - i: Integer; - s: String; - -begin - CheckEquals(False, StrIsAlpha(''), 'StrIsAlpha'); // per doc - CheckEquals(False, StrIsAlphaNumUnderscore(''), 'StrIsAlphaNumUnderscore9'); // per doc - CheckEquals(False, StrIsAlphaNum(''), 'StrIsAlphaNum'); // per doc - - GenerateAlpha(2000, 1000, stringarray); - - for i := 1 to 500 do - begin - s := stringarray[i-1]; - CheckEquals(True, StrIsAlpha(s), 'StrIsAlpha'); - CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); - end; - - GenerateAlphaNum(2000, 1000, stringarray, True); - - for i := 1 to 500 do - begin - s := stringarray[i-1]; - CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); - - s := s + '_'; - CheckEquals(False,StrIsAlphaNum(s),'StrIsAlphaNum'); - CheckEquals(True, StrIsAlphaNumUnderscore(s),'StrIsAlphaNumUnderscore'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -function ContainsValidator(const C: Char): Boolean; -begin - Result := (C = 'g') or (C = 'r'); -end; - -procedure TJclStringTransformation._Deprecated_StrContainsChars_StrIsSubset1; -begin - // StrIsSubset - CheckEquals(StrIsSubset('',[' ']), False,'StrIsSubset'); // per doc - - CheckEquals(True, StrContainsChars('AbcdefghiJkl', ['g', 'r'], False), 'array, CheckAll set to False'); - CheckEquals(False, StrContainsChars('AbcdefghiJkl', ['g', 'r'], True), 'array, CheckAll set to True, only 1 occurring'); - CheckEquals(True, StrContainsChars('AbcdefghiJklr', ['g', 'r'], True), 'array, CheckAll set to True, both occurring'); - - CheckEquals(True, StrContainsChars('AbcdefghiJkl', ContainsValidator, False), 'validator, CheckAll set to False'); - // CheckAll=True will not work with a validator, at least not with the same meaning as with the array-based tests. - // The tests are disabled for now. - { - CheckEquals(False, StrContainsChars('AbcdefghiJkl', ContainsValidator, True), 'validator, CheckAll set to True, only 1 occurring'); - CheckEquals(True, StrContainsChars('AbcdefghiJklr', ContainsValidator, True), 'validator, CheckAll set to True, both occurring'); - } -end; - -procedure TJclStringTransformation._StringMatchingAgainstChars; -begin - CheckTrue (StrContainsEveryChar('AbcdefghiJklr', ['g', 'r'])); - CheckTrue (StrContainsEveryChar('', [])); - CheckFalse(StrContainsEveryChar('AbcdefghiJkl', ['g', 'r'])); - CheckTrue (StrContainsEveryChar('AbcdefghiJklr', 'gr')); - CheckTrue (StrContainsEveryChar('', '')); - CheckFalse(StrContainsEveryChar('AbcdefghiJkl', 'gr')); - - CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ['g', 'r'])); - CheckTrue (StrContainsSomeChar('AbcdefhiJklr', ['r', 'g'])); - CheckFalse(StrContainsSomeChar('AbcdefhiJkl', 'rg')); - CheckTrue (StrContainsSomeChar('AbcdefghiJkl', 'rg')); - CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ContainsValidator)); - CheckTrue (StrContainsSomeChar('AbcdefghiJkl', ContainsValidator)); - - CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ['g', 'r'])); - CheckTrue (StrConsistsOfChars('grrrgr', ['r', 'g'])); - CheckTrue (StrConsistsOfChars('', ['r', 'g'])); - CheckFalse(StrConsistsOfChars('', ['r', 'g'], False)); - CheckFalse(StrConsistsOfChars('AbcdefghiJklr', 'rg')); - CheckTrue (StrConsistsOfChars('grrrgr', 'rg')); - CheckTrue (StrConsistsOfChars('', 'rg')); - CheckFalse (StrConsistsOfChars('', 'rg', False)); - CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ContainsValidator)); - CheckTrue (StrConsistsOfChars('grrrgr', ContainsValidator)); - CheckTrue (StrConsistsOfChars('', ContainsValidator)); - CheckFalse(StrConsistsOfChars('', ContainsValidator, False)); - -(* -function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; -function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; -function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; -function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; - *) -end; - - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSame; -var - i: Integer; - -begin - // StrSame - CheckEquals(StrSame('',''), True, 'StrSame'); // per doc - CheckEquals(True,StrSame('aaa','AAA'), 'StrSame'); // Case insensitive - - GenerateAll(1000, 500, stringarray, True); - GenerateAll(50, 500, stringarray2, True); - - for i := 1 to 500 do - begin - CheckEquals(True, StrSame(stringarray[i-1], stringarray[i-1]), 'StrSame'); - CheckEquals(False, StrSame(stringarray[i-1], stringarray2[i-1]), 'StrSame'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrIsDigit_StrConsistsOfNumberChars; -var s: string; -begin - // StrIsDigit - CheckEquals(StrIsDigit('') , False, 'StrIsDigit'); // per doc - CheckEquals(StrConsistsOfDigits('') , False, 'StrConsistsOfDigits'); // per doc - - // StrConsistsOfNumberChars - CheckEquals(StrConsistsOfNumberChars('') , False,'StrConsistsOfNumberChars'); // per doc - - CheckEquals(StrConsistsOfDigits('2345') , True, 'StrConsistsOfDigits'); // per doc - CheckEquals(StrConsistsOfNumberChars('2345') , True,'StrConsistsOfNumberChars'); // per doc - - s := FormatFloat('#,###.##', -12345.6789); - CheckEquals(StrConsistsOfDigits(s) , False, 'StrConsistsOfDigits'); // per doc - CheckEquals(StrConsistsOfNumberChars(s) , True,'StrConsistsOfNumberChars'); // per doc -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCenter; -var - i: Integer; - s, SN: String; - -begin - // StrCenter should return s unchanged. Since the length parameter is - // smaller than (even negative) the acutal length of S. - - S := '1234567890'; - - for i := -100 to 9 do - begin - SN := StrCenter(S, i, '#'); - CheckEquals(SN, S, 'StrCenter'); - end; - - // StrCenter should add the fill pattern. The length is checked. - - for i := 10 to 400 do - begin - SN := StrCenter(S, i, '#'); - CheckEquals(i, Length(SN), 'StrCenter'); - end; - - // StrCenter work tests. - - SN := StrCenter('', 10, '#'); - CheckEquals(Length(SN), 10, 'StrCenter'); - CheckEquals(SN, '##########', 'StrCenter'); - - SN := StrCenter('t', 6, '#'); - CheckEquals(SN, '##t###', 'StrCenter'); - - SN := StrCenter('t', 7, '!'); - CheckEquals(SN, '!!!t!!!', 'StrCenter'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCharPosLower; -begin - CheckEquals('This is a test.', StrCharPosLower('This is a test.', -1)); - CheckEquals('This is a test.', StrCharPosLower('This is a test.', 0)); - CheckEquals('this is a test.', StrCharPosLower('This is a test.', 1)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrCharPosUpper; -begin - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', -1)); - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 0)); - CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 1)); - CheckEquals('THis is a test.', StrCharPosUpper('This is a test.', 2)); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrDoubleQuote; -var - SN, S: string; - i: Integer; - -begin - SN := StrDoubleQuote(''); - CheckEquals('""', SN, 'StrDoubleQuote'); - - SN := StrDoubleQuote('Project JEDI'); - CheckEquals('"Project JEDI"',SN, 'StrDoubleQuote'); - - // Test if String is has been quoted. Since StrDoubleQuote adds quotes also - // when they are already there no special tests are needed. - - GenerateAll(2000,200, StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - CheckEquals('"'+S+'"',StrDoubleQuote(s) ,'StrDoubleQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEnsurePrefix; -var - Prefix, s, SN: String; - I: Integer; - -begin - s := 'TestIt!'; - CheckEquals('TestIt!', StrEnsurePrefix('',S), 'StrEnsurePrefix'); - CheckEquals(StrEnsurePrefix(S,''), 'TestIt!', 'StrEnsurePrefix'); - CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!', 'StrEnsurePrefix'); - - s := 'TestIT!'; - CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!TestIT!','StrEnsurePrefix'); - - // Test StrEnsurePrefix using the Generators. S is the string, Prefix the - // wanted prefix and SN is prefix + s or s if the prefix is already there. - - GenerateAll(2000, 100, StringArray, True); - GenerateAll(20, 100, StringArray2, True); - - for i := 1 to 100 do - begin - S := StringArray[i-1]; - Prefix := StringArray2[i-1]; - - SN := StrEnsurePrefix(Prefix,S); - - if copy(s, 0, length(Prefix)) <> prefix then - Check(SN = prefix+s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])) - else - Check(SN = s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEnsureSuffix; -var - Suffix, s, SN: String; - I: Integer; -begin - s := 'TestIt!'; - CheckEquals(StrEnsureSuffix('',S), 'TestIt!', 'StrEnsureSuffix'); - CheckEquals(StrEnsureSuffix(S,''), 'TestIt!', 'StrEnsureSuffix'); - CheckEquals(StrEnsureSuffix('TestIt!',S), 'TestIt!', 'StrEnsureSuffix'); - - s := 'TestIT!'; - CheckEquals(StrEnsureSuffix('TestIt!',S) , 'TestIT!TestIt!', 'StrEnsureSuffix'); - - // Test StrEnsureSuffix using the Generators. S is the string, Suffix the - // wanted suffix and SN is s + suffix or s if the suffix is already there. - - GenerateAll(2000, 200, StringArray, True); - GenerateAll(20, 200, StringArray2, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - Suffix := StringArray2[i-1]; - - SN := StrEnsureSuffix(suffix,s); - - if copy(s, length(s) - length(suffix), 300) <> suffix then - Check(SN = s + suffix, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])) - else - Check(SN = s, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrEscapedToString_StrStringToEscaped; -var - s, sn: string; - i: Integer; - - -begin - S := StrEscapedToString(''); - sn := ''; - CheckEquals(StrEscapedToString(SN), S, 'StrEscapedToString'); - - GenerateAll(1000, 200, StringArray, true); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - sn := StrStringToEscaped(s); - - CheckEquals(StrEscapedToString(SN), s, 'StrEscapedToString'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrLower_StrLowerInPlace_StrLowerBuff; -var - sp: pointer; - i: Integer; - s, sn: string; - -begin - CheckEquals(StrLower(''), '', 'StrLower'); - - { LowerBuff nil tests } - sp := nil; - StrLowerBuff(nil); - StrLowerBuff(sp); - CheckEquals(Integer(sp), Integer(nil), 'StrLowerBuff'); - - { Tests StrLower, StrLowerBuff and StrLowerInPlace against AnsiLowerCase and - against each other. The Testdata consits of only uppercase chars in this test. } - - GenerateAlphaUpperCase(500,500,StringArray, True); - - for i := 1 to 500 do - begin - s := StringArray[i-1]; - SN := s; - StrLowerInPlace(SN); - CheckEquals(StrLower(s), AnsiLowerCase(s), 'StrLower'); - CheckEquals(StrLower(s), SN, 'StrLower'); - - StrLowerBuff(PChar(s)); - CheckEquals(s, SN,'StrLowerBuff'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrMove; -var - Dest: string; - -begin - Dest := 'ATest'; - - StrMove(Dest, 'xxxx', 1, 1, 5); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 4, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', -1, 1, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, -1, 3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 1, -3); - CheckEquals('ATest',Dest, 'StrMove'); - - StrMove(Dest, 'xxxx', 1, 1, 3); - CheckEquals('xxxst',Dest, 'StrMove'); - - Dest := 'ATest'; - StrMove(Dest, 'abcd', 3, 2, 2); - CheckEquals('ATbct',Dest, 'StrMove'); - - Dest := 'ATest'; - StrMove(Dest, 'abcd', 5, 4, 1); - CheckEquals('ATesd',Dest, 'StrMove'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrPadLeft; -var - S, S3: String; - I, v,t: Integer; - -begin - // -- StrPadLeft -- - - S := ''; - S := StrPadLeft(S, 10, '#'); - CheckEquals(S, '##########','StrPadLeft'); - - s := StrPadLeft(S, -10, '$'); - CheckEquals(S , '##########','StrPadLeft'); - - { StrPadLeft is tested using the Generator. A random number of dollar signs are - added to the string s. The first comparisation test against the length, the - second performs an actual test.} - - GenerateAll(2000,100, StringArray, True); - RandSeed := 123456; - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - v := random(20)+2; - - s3 := StrPadLeft(s, length(s) + v, '$'); - CheckEquals(Length(s3), length(s) + v,'StrPadLeft'); - - for t := 1 to v do - s := '$' + s; - - CheckEquals(s3, s,'StrPadLeft'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrPadRight; -var - S, S3: String; - I, v,t: Integer; - -begin - // -- StrPadRight -- - S := ''; - s := StrPadRight(S, 10, '#'); - CheckEquals(S , '##########','StrPadRight'); - - s := StrPadRight(S, -10, '$'); - CheckEquals(S , '##########','StrPadRight'); - - { StrPadRight is tested using the Generator. A random number of percent char are - added to the string s. The first comparisation test against the length, the - second performs an actual test.} - - GenerateAll(2000,100,StringArray, True); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - v := random(20)+2; - s3 := StrPadRight(s, length(s) + v, '%'); - CheckEquals(Length(s3), length(s) + v,'StrPadRight'); - - for t := 1 to v do - s := s + '%'; - - CheckEquals(s3, s,'StrPadRight'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrProper_StrProperBuff; -var - s, s3: string; - -begin - CheckEquals('', StrProper(''), 'StrProper1'); - CheckEquals('Test', StrProper('Test') , 'StrProper2'); - CheckEquals('Test', StrProper('TeSt'), 'StrProper3'); - CheckEquals('Test', StrProper('TEST'), 'StrProper4'); - CheckEquals('Test1234', StrProper('TeST1234'), 'StrProper5'); - CheckEquals('Test1234', StrProper('teST1234'), 'StrProper6'); - - s := 'TeST'; - s3 := s; - s3 := StrProper(s); - CheckNotEquals(s, s3, 'StrProper7'); - - // check if StrProperBuff can handle a nil pointer - StrProperBuff(nil); - - // check StrProperBuff works as expected - s3 := Copy(s, 1, Length(s)); - StrProperBuff(PChar(s3)); - CheckEquals('Test', s3, 'StrProperBuff.2') -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrQuote; -var - i: Integer; - s: string; - -begin - CheckEquals(StrQuote('','#'), '','StrQuote'); - CheckEquals(StrQuote('a','#'), '#a#','StrQuote'); - CheckEquals(StrQuote('Test','#'), '#Test#','StrQuote'); - CheckEquals(StrQuote('#Test#','#'), '#Test#','StrQuote'); - CheckEquals(StrQuote('"Test"','#'), '#"Test"#','StrQuote'); - CheckEquals(StrQuote('"Test#','"'), '"Test#"','StrQuote'); - - { StrQuote is tested using the Generator. Since it is possible that the char - is already on the left or right side we have to check all four cases.} - - GenerateAll(2000,200,StringArray, True); - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - if (s[1] <> '"') and (s[Length(s)] <> '"') then - CheckEquals(StrQuote(s,'"'), '"'+s+'"','StrQuote') - else - if (s[1] = '"') and (s[Length(s)] = '"') then - CheckEquals(StrQuote(s,'"'), s,'StrQuote') - else - if (s[1] <> '"') and (s[Length(s)] = '"') then - CheckEquals(StrQuote(s,'"'), '"'+s,'StrQuote') - else - if (s[1] = '"') and (s[Length(s)] <> '"') then - CheckEquals(StrQuote(s,'"'), s+'"','StrQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -threadvar - removeset: TSysCharSet; - -function RemoveValidator(const C: Char): Boolean; -begin - Result := C in removeset; -end; - -procedure TJclStringTransformation._StrRemoveChars; -var - i, t, v: Integer; - s, s3, sn: string; -begin - // -- StrRemoveChars -- - CheckEquals(StrRemoveChars('',['e']), '', 'StrRemoveChars 1'); - CheckEquals(StrRemoveChars('Test',['e']), 'Tst', 'StrRemoveChars 2'); - - GenerateAll(20,200,StringArray2, True); - GenerateAll(400,200,StringArray, True); - - { Check StrRemoveChars against a self made one using the Pos function } - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := StringArray[i-1]; - sn := StringArray2[i-1]; - removeset := []; - - for t := 1 to Length(sn) do - begin - if not (sn[t] in removeset) then - removeset := removeset + [Char(sn[t])]; - - v := Pos(sn[t], s3); - - while v > 0 do - begin - Delete(s3, v, 1); - v := Pos(sn[t], s3); - end; - end; - - CheckEquals(s3, StrRemoveChars(s, RemoveValidator), 'StrRemoveChars 3'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -threadvar - keepset: TSysCharSet; - -function KeepValidator(const C: Char): Boolean; -begin - Result := C in keepset; -end; - -procedure TJclStringTransformation._StrKeepChars; -var - i, t: Integer; - s, s3, sn: String; - -begin - CheckEquals('', StrKeepChars('',[]), 'StrKeepChars 0'); - CheckEquals('oieaouoeioao', StrKeepChars('Joint Endeavour of Delphi Innovators',['e', 'a', 'o', 'u', 'i']), 'StrKeepChars 1'); - CheckEquals('oi eaou o ei oao', StrKeepChars('Joint Endeavour of Delphi Innovators',[' ', 'e', 'a', 'o', 'u', 'i']), 'StrKeepChars 2'); - - GenerateAll(20,200,StringArray2, True); - GenerateAll(400,200,StringArray, True); - - { Check StrKeepChars against a self made one } - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := ''; - sn := StringArray2[i-1]; - keepset := []; - - for t := 1 to length(sn) do - begin - if not (sn[t] in keepset) then - keepset := keepset + [Char(sn[t])]; - end; - - for t := 1 to length(s) do - begin - if s[t] in keepset then - s3 := s3 + s[t]; - end; - - CheckEquals(s3, StrKeepChars(s, KeepValidator), 'StrKeepChars 3'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplace; -var - s: string; - -begin - // test 1: Replace on an empty string with an empty search string should result in the replace string - s := ''; - StrReplace(s, '', 'Test', []); - CheckEquals('Test', s, 'StrReplace1'); - - // test 2: replace a short string with a longer string - s := 'This is a test.'; - StrReplace(s, 'is a', 'is a successful', []); - CheckEquals('This is a successful test.', s, 'StrReplace 2'); - - // test 3: replace a long string with a shorter string - s := 'This is a successful little test.'; - StrReplace(s, 'successful little', 'successful', []); - CheckEquals('This is a successful test.', s, 'StrReplace 3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplaceChar; -begin - CheckEquals(StrReplaceChar('', 'a', 'b'),'','StrReplaceChar'); - CheckEquals(StrReplaceChar('', #0, #0),'','StrReplaceChar'); - CheckEquals(StrReplaceChar('ababab', 'a', 'b'),'bbbbbb','StrReplaceChar'); - CheckEquals(StrReplaceChar('ababab', 'b', 'a'),'aaaaaa','StrReplaceChar'); - CheckEquals(StrReplaceChar('xabababx', 'b', 'a'),'xaaaaaax','StrReplaceChar'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplaceChars; -begin - CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); - CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); - CheckEquals(StrReplaceChars('ababab', ['a','b'], 'b'),'bbbbbb','StrReplaceChars'); - CheckEquals(StrReplaceChars('xabababx', ['a','b'], 'b'),'xbbbbbbx','StrReplaceChars'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReplacebutChars; -begin - CheckEquals(StrReplaceButChars('', ['a'], 'b'),'','StrReplaceButChars'); - CheckEquals(StrReplaceButChars('xabababx', ['a','b'], 'v'),'vabababv','StrReplaceChars'); - CheckEquals(StrReplaceButChars('TxabababxT', ['a','b'], 'v'),'vvabababvv','StrReplaceChars'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrRepeat; -var - i,t, v: Integer; - s, s3: string; - -begin - CheckEquals(StrRepeat('Test',0) , '', 'StrRepeat'); - CheckEquals(StrRepeat('Test',-1) , '', 'StrRepeat'); - CheckEquals(StrRepeat('Test',-1000) , '', 'StrRepeat'); - CheckEquals(StrRepeat('He',3) , 'HeHeHe', 'StrRepeat'); - CheckEquals(StrRepeat('H e',3) , 'H eH eH e', 'StrRepeat'); - - GenerateAll(50,200,StringArray, True); - - { Check StrRepeat against a self made one } - - RandSeed := 432321; - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - s3 := ''; - v := random(20)+1; - - for t := 1 to v do - s3 := s3 + s; - - CheckEquals(StrRepeat(s,v) ,s3, 'StrRepeat'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrRepeatLength; -begin - CheckEquals(StrRepeatLength('Test',0),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',1),'T','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',2),'Te','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',3),'Tes','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',4),'Test','StrRepeatLength'); - CheckEquals(StrRepeatLength('TestTest',8),'TestTest','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',-1),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('Test',-100),'','StrRepeatLength'); - CheckEquals(StrRepeatLength('',-100),'','StrRepeatLength'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrReverse_StrReverseInPlace; -var - i,t: Integer; - s, s3: string; - -begin - // -- StrReverse / StrReverseInPlace -- - CheckEquals(StrReverse(''), '', 'StrReverse'); - CheckEquals(StrReverse('a'), 'a', 'StrReverse'); - CheckEquals(StrReverse('ab'), 'ba', 'StrReverse'); - CheckEquals(StrReverse('abc'), 'cba', 'StrReverse'); - - { Check StrReverse against a (slow) self made one } - - GenerateAll(100,200,StringArray, True); - - for i := 1 to 200 do - begin - s := StringArray[i-1]; - SetLength(s3, length(s)); - - for t := 1 to length(s) do - s3[t] := s[(length(s) - t) + 1]; - - s := StrReverse(s); - CheckEquals(s, s3, 'StrReverse'); - - s := StringArray[i-1]; - - StrReverseInPlace(s); - CheckEquals(s, s3, 'StrReverse'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSingleQuote; -var - i: Integer; - s: string; - -begin - CheckEquals(StrSingleQuote(''), '''''', 'StrSingleQuote'); - CheckEquals(StrSingleQuote('Project JEDI'), '''Project JEDI''', 'StrSingleQuote'); - - GenerateAll(2000,200,StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - CheckEquals(StrSingleQuote(s),''''+S+'''', 'StrSingleQuote'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrSmartCase; -begin - CheckEquals('', StrSmartCase('', [' ']), 'StrSmartCase1'); - CheckEquals('Project Jedi', StrSmartCase('project jedi', [' ']), 'StrSmartCase2'); - CheckEquals('Project Jedi ', StrSmartCase('project jedi ', [' ']), 'StrSmartCase3'); - CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase4'); - CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase5'); - // test 6: delimiters followed by the same delimiter will not force an upper case on the second delimiter - CheckEquals('XxxxxAx', StrSmartCase('xxxxxAx', [' ','x']), 'StrSmartCase6'); - // test 7: delimiters followed by the another delimiter will not force an upper case on the second delimiter - CheckEquals('Xxx xAx', StrSmartCase('xxx xAx', [' ','x']), 'StrSmartCase7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrStripNonNumberChars; -var - i: Integer; - s: string; - -begin - CheckEquals(StrStripNonNumberChars(''),'','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('123+abcabc+123'),'123++123','StrStripNonNumberChars'); - CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); - - GenerateAlpha(200,50,StringArray, True); - - for i := 1 to 50 do - begin - S := StringArray[i-1]; - CheckEquals(StrStripNonNumberChars(s),'', 'StrStripNonNumberChars'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrToHex_Ansi; -var - s, sn: AnsiString; - -begin - CheckEquals(StrToHex(''),'','StrToHex'); - - SN := '262A32543B'; - SetLength(S,20); - HexToBin(PAnsiChar(SN),PAnsiChar(S),20); - CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); - - SN := 'FF2A2B2C2D1A2F'; - HexToBin(PAnsiChar(SN),PAnsiChar(S),20); - CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharLeft; -var - i,t: Integer; - s, s3, sn: string; -begin - CheckEquals('', StrTrimCharLeft('', #0), 'StrTrimCharLeft1'); - CheckEquals('', StrTrimCharLeft('AAAAAAAAAA', 'A'), 'StrTrimCharLeft2'); - - GenerateAll(200, 2000, StringArray); - GenerateAll(1, 2000, StringArray2); - - for i := 1 to 2000 do - begin - S := StringArray[i-1]; - SN := StringArray2[i-1]; - - while S[1] = SN do - s := '#' + s; - - S3 := S; - t := random(100); - - while t <> 0 do - begin - S3 := SN + S3; - dec(t); - end; - - CheckEquals(S, StrTrimCharLeft(S3,SN[1]), 'StrTrimCharLeft3.' + IntToStr(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -function TrimValidator(const C: Char): Boolean; -begin - Result := (C = 'A') or (C = 'B'); -end; - -procedure TJclStringTransformation._StrTrimCharsLeft; -begin - CheckEquals('', StrTrimCharsLeft('', []), 'empty str, empty array'); - CheckEquals('ABC', StrTrimCharsLeft('ABC', []), 'non-empty str, empty array'); - CheckEquals('BCA', StrTrimCharsLeft('ABCA', ['A']), 'ABCA str, A array'); - CheckEquals('CA', StrTrimCharsLeft('ABCA', ['B', 'A']), 'ABCA str, BA array'); - - CheckEquals('CA', StrTrimCharsLeft('ABCA', TrimValidator), 'ABCA str, AB validator'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharRight; -var - i,t: Integer; - s, sn, s3: string; - -begin - // -- StrTrimCharRight -- - CheckEquals('', StrTrimCharRight('', #0), 'StrTrimCharRight1'); - CheckEquals('', StrTrimCharRight('AAAAAAAAAA', 'A'), 'StrTrimCharRight2'); - - GenerateAll(200, 2000, StringArray); - GenerateAll(1, 2000, StringArray2); - - for i := 1 to 2000 do - begin - S := StringArray[i-1]; - SN := StringArray2[i-1]; - - while S[Length(S)] = SN do - s := s + '#'; - - S3 := S; - t := random(100); - - while t <> 0 do - begin - S3 := S3 + SN; - dec(t); - end; - - CheckEquals(S, StrTrimCharRight(S3, SN[1]), 'StrTrimCharRight3.' + IntToStr(i)); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimCharsRight; -begin - CheckEquals('', StrTrimCharsRight('', []), 'empty str, empty array'); - CheckEquals('ABC', StrTrimCharsRight('ABC', []), 'non-empty str, empty array'); - CheckEquals('ABC', StrTrimCharsRight('ABCA', ['A']), 'ABCA str, A array'); - CheckEquals('AB', StrTrimCharsRight('ABCA', ['C', 'A']), 'ABCA str, CA array'); - - CheckEquals('ABC', StrTrimCharsRight('ABCAABA', TrimValidator), 'ABCAABA str, AB validator'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrTrimQuotes; -var - i: Integer; - s, s3, s4: string; -begin - CheckEquals(StrTrimQuotes(''),'','StrTrimQuotes'); - CheckEquals(StrTrimQuotes('""'),'','StrTrimQuotes'); - CheckEquals(StrTrimQuotes(''''''),'','StrTrimQuotes'); - - CheckEquals(StrTrimQuotes('""TEST""'),'"TEST"','StrTrimQuotes'); - CheckEquals(StrTrimQuotes('''''TEST'''''),'''TEST''','StrTrimQuotes'); - - GenerateAll(200,100,StringArray); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - s3 := StrDoubleQuote(s); - s4 := StrSingleQuote(s); - - CheckEquals(StrTrimQuotes(s3),s,'StrTrimQuotes'); - CheckEquals(StrTrimQuotes(s4),s,'StrTrimQuotes'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringTransformation._StrUpper_StrUpperInPlace_StrUpperBuff; -var - i: Integer; - s4, s, s3: string; - -begin - GenerateAll(200,200,StringArray); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S3 := AnsiUpperCase(s); - S4 := S; - StrUpperInPlace(S4); - CheckEquals(StrUpper(S), S3, 'StrUpper'); - CheckEquals(S4, S3, 'StrUpperInPlace'); - - S4 := S; - StrUpperBuff(PChar(S4)); - CheckEquals(S4, S3, 'StrUpperBuff'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -//================================================================================================== -// String Managment -//================================================================================================== - -procedure TJclStringManagment.StringManagement; -{$IFNDEF SUPPORTS_UNICODE} -{$IFDEF KEEP_DEPRECATED} -var - s1: string; -{$ENDIF KEEP_DEPRECATED} -{$ENDIF !SUPPORTS_UNICODE} - -begin -{$IFNDEF SUPPORTS_UNICODE} -{$IFDEF KEEP_DEPRECATED} - StrAddRef(s1); - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 0,'StrRefCount'); - - s1 := 'test'; - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 2,'StrRefCount'); - - StrAddRef(s1); - StrAddRef(s1); - CheckEquals(StrRefCount(s1), 4,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 3,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 2,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 1,'StrRefCount'); - StrDecRef(s1); - CheckEquals(StrRefCount(s1), 0,'StrRefCount'); -{$ELSE !KEEP_DEPRECATED} - Check(True, 'Ignored because KEEP_DEPRECATED not defined'); -{$ENDIF KEEP_DEPRECATED} -{$ELSE SUPPORT_UNICODE} - Check(True, 'Ignored because SUPPORT_UNICODE is defined'); -{$ENDIF !SUPPORTS_UNICODE} -end; - -//================================================================================================== -// String Search and Replace -//================================================================================================== - -procedure TJclStringSearchandReplace.AddCheck(const s1, s2: string; const res: Integer); -begin - StringArray[fillIdx] := s1; - StringArray2[fillIdx] := s2; - ResultArray[fillIdx] := res; - Inc(fillIdx); -end; - -function TJclStringSearchandReplace.NormalizeCompareResult(res: Integer): Integer; -begin - if res < 0 then - Result := -1 - else - if res > 0 then - Result := 1 - else - Result := 0; -end; - -procedure TJclStringSearchandReplace.TestCompare(idx: Integer; res: Integer; msgFmt: string); -begin - CheckEquals(ResultArray[idx], res, Format('[%d] ' + msgFmt, [idx, QuotedStr(StringArray[idx]), QuotedStr(StringArray2[idx])])); -end; - -procedure TJclStringSearchandReplace._CompareNaturalStr; -var - idx: Integer; - s1: string; - s2: string; -begin - fillIdx := 0; - - // mixed strings, whitespace ignoring for number components only - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi Highlander', 'Delphi 2005', 1); - AddCheck('Delphi Highlander', 'Delphi Highlander', 1); - AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); - AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 1); // case-sensitivity test - - // version/revision numbering schemes - AddCheck('1.2', '1.10', -1); - AddCheck('1.20', '1.3a', 1); - AddCheck('1.1.1', '1.1', 1); - AddCheck('1.1', '1.1a', -1); - AddCheck('1.1.a', '1.1a', -1); - AddCheck('a', '1', 1); - AddCheck('a', 'b', -1); - AddCheck('1', '2', -1); - - // leading zeroes overrule normal number comparisons - AddCheck('0002', '1', -1); - AddCheck('1.5', '1.06', 1); - - // hyphen binds looser than period (technically compares a number against a non-number component) - AddCheck('1-2', '1-1', 1); - AddCheck('1-2', '1.2', -1); - - // handling of positive/negative number comparisons - AddCheck('0', '-5', 1); - AddCheck('-5', '+2', -1); - - for idx := 0 to fillIdx - 1 do - begin - s1 := StringArray[idx]; - s2 := StringArray2[idx]; - TestCompare(idx, NormalizeCompareResult(CompareNaturalStr(s1, s2)), 'CompareNaturalStr(%s, %s)'); - end; -end; - -procedure TJclStringSearchandReplace._CompareNaturalText; -var - idx: Integer; -begin - fillIdx := 0; - - // mixed strings, whitespace ignoring for number components only - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 2005', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi 5', 'Delphi 6', -1); - AddCheck('Delphi Highlander', 'Delphi 2005', 1); - AddCheck('Delphi Highlander', 'Delphi Highlander', 1); - AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); - AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 0); // case-sensitivity test - - // version/revision numbering schemes - AddCheck('1.2', '1.10', -1); - AddCheck('1.20', '1.3a', 1); - AddCheck('1.1.1', '1.1', 1); - AddCheck('1.1', '1.1a', -1); - AddCheck('1.1.a', '1.1a', -1); - AddCheck('a', '1', 1); - AddCheck('a', 'b', -1); - AddCheck('1', '2', -1); - - // leading zeroes overrule normal number comparisons - AddCheck('0002', '1', -1); - AddCheck('1.5', '1.06', 1); - - // hyphen binds looser than period (technically compares a number against a non-number component) - AddCheck('1-2', '1-1', 1); - AddCheck('1-2', '1.2', -1); - - // handling of positive/negative number comparisons - AddCheck('0', '-5', 1); - AddCheck('-5', '+2', -1); - - for idx := 0 to fillIdx - 1 do - TestCompare(idx, NormalizeCompareResult(CompareNaturalText(StringArray[idx], StringArray2[idx])), 'CompareNaturalText(%s, %s)'); -end; - -procedure TJclStringSearchandReplace._StrCharCount; -var - s: string; - ca, t, i: Integer; - c: char; - -begin - CheckEquals(StrCharCount('','x'),0,'StrCharCount'); - CheckEquals(StrCharCount('Test',#0),0,'StrCharCount'); - CheckEquals(StrCharCount('Test','T'),1,'StrCharCount'); - CheckEquals(StrCharCount('Test','t'),1,'StrCharCount'); - CheckEquals(StrCharCount('TestTT','T'),3,'StrCharCount'); - CheckEquals(StrCharCount('Ttetstt','t'),4,'StrCharCount'); - - GenerateAll(500,100,StringArray, True); - - for i := 1 to 100 do - begin - s := StringArray[i-1]; - - for c := #1 to #255 do - begin - ca := 0; - - for t := 1 to length(s) do - begin - if s[t] = c then - inc(ca); - end; - - CheckEquals(StrCharCount(s,c),ca,'StrCharCount'); - end; - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCharsCount; -begin - CheckEquals(StrCharsCount('',['x']),0,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',[#0]),0,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',['T']),1,'StrCharsCount'); - CheckEquals(StrCharsCount('Test',['t']),1,'StrCharsCount'); - CheckEquals(StrCharsCount('TestTT',['T']),3,'StrCharsCount'); - CheckEquals(StrCharsCount('Ttetstt',['t']),4,'StrCharsCount'); - CheckEquals(StrCharsCount('Ttetstt',['t','T']),5,'StrCharsCount'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrStrCount; -begin - CheckEquals(1, StrStrCount('Test', 'Test'), 'StrStrCount_1'); - CheckEquals(2, StrStrCount('TestTest', 'Test'), 'StrStrCount_2'); - CheckEquals(0, StrStrCount('Test', 'Quark'), 'StrStrCount_3'); - CheckEquals(0, StrStrCount('', 'Quark'), 'StrStrCount_4'); - CheckEquals(0, StrStrCount('', ''), 'StrStrCount_5'); - CheckEquals(0, StrStrCount('Test', ''), 'StrStrCount_6'); - CheckEquals(0, StrStrCount('Test', 'TEST'), 'StrStrCount_7'); // Case sensive ? - CheckEquals(0, StrStrCount('', 'Test'), 'StrStrCount_8'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCompare; -var - i, t: Integer; - S, S1, S2: String; - -begin - CheckEquals(StrCompare('',''),0,'StrCompare'); - CheckEquals(StrCompare('jedi','jedi'),0,'StrCompare'); - CheckEquals(StrCompare('jedi','je'),2,'StrCompare'); - CheckEquals(StrCompare('di','jedi'),-2,'StrCompare'); - CheckEquals(StrCompare('project jedi','jedi'),8,'StrCompare'); - CheckEquals(StrCompare('jedi','judi'),Ord('e') - Ord('u'),'StrCompare'); - CheckEquals(StrCompare('JEDI','Judi'),Ord('e') - Ord('u'),'StrCompare'); - - GenerateAll(600,200,StringArray); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S1 := S; - CheckEquals(StrCompare(S,S1),0,'StrCompare'); - CheckEquals(StrCompare(S,S),0,'StrCompare'); - end; - - GenerateAll(600,1000,StringArray, True); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S1 := StringArray[199+i]; - - if Length(S) = Length(S1) then - S1 := S1 + 'x'; - - CheckEquals(StrCompare(S,S1),Length(S) - Length(S1),'StrCompare'); - CheckEquals(StrCompare(S1,S),Length(S1) - Length(S),'StrCompare'); - end; - - GenerateAll(600,2000,StringArray); - GenerateAll(1,1000,StringArray2); - - for i := 1 to 200 do - begin - S := StringArray[i-1]; - S2 := S; - - S1 := StringArray[i]; - t := random(Length(S)); - - while s1 = S[1 + t] do - t := random(Length(S)); - - S[1+t] := Char(s1[1]); - CheckEquals(StrCompare(S2,S), ord(CharLower(S2[1+t])) - ord(CharLower(S[1+t])) ,'StrCompare'); - CheckEquals(StrCompare(S,S2), ord(CharLower(S[1+t])) - ord(CharLower(S2[1+t])) ,'StrCompare'); - end; -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrCompareRange; -begin - CheckEquals(0, StrCompareRange('', '', 1, 0), 'StrCompareRange1'); - CheckEquals(0, StrCompareRange('Test1234', 'Test', 1, 4), 'StrCompareRange5'); - CheckEquals(0, StrCompareRange('Test1234', 'Test1234', 1, 25), 'StrCompareRange6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrFillChar; - - procedure TestCombo(ch: Char; res: string); - var - s: array[0..79] of Char; - str: string; - begin - StrFillChar(s, Length(res), ch); - s[Length(res)] := #0; - str := s; - CheckEquals(res, s, 'StrFillChar ' + IntToStr(Length(res)) + '*' + ch); - end; - -begin - TestCombo('a', ''); - TestCombo('a', 'a'); - TestCombo('a', 'aa'); - TestCombo('b', 'bbbb'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrFind; -begin - CheckEquals(0, StrFind('abc', 'Test'), 'StrFind_1'); - CheckEquals(1, StrFind('Test', 'Test'), 'StrFind_2'); - CheckEquals(1, StrFind('Test', 'test'), 'StrFind_3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrHasPrefix; -begin - CheckEquals(False, StrHasPrefix('', []), 'StrHasPrefix1'); - CheckEquals(False, StrHasPrefix('', ['TEST']), 'StrHasPrefix2'); - CheckEquals(False, StrHasPrefix('', ['TEST', 'TEST2']), 'StrHasPrefix3'); - CheckEquals(False, StrHasPrefix('Test', ['TEST', 'TEST2']), 'StrHasPrefix4'); - CheckEquals(True, StrHasPrefix('Test2', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix5'); - CheckEquals(True, StrHasPrefix('Test12345', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix6'); - CheckEquals(True, StrHasPrefix('Test21234', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIHasPrefix; -begin - CheckEquals(False, StrIHasPrefix('', []), 'StrIHasPrefix1'); - CheckEquals(False, StrIHasPrefix('', ['TEST']), 'StrIHasPrefix2'); - CheckEquals(False, StrIHasPrefix('', ['TEST', 'TEST2']), 'StrIHasPrefix3'); - CheckEquals(True, StrIHasPrefix('Test', ['TEST', 'TEST2']), 'StrIHasPrefix4'); - CheckEquals(True, StrIHasPrefix('Test2', ['TEST', 'TEST2']), 'StrIHasPrefix5'); - CheckEquals(True, StrIHasPrefix('Test12345', ['TEST', 'TEST2']), 'StrIHasPrefix6'); - CheckEquals(True, StrIHasPrefix('Test21234', ['TEST', 'TEST2']), 'StrIHasPrefix7'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIndex; -begin - CheckEquals(-1, StrIndex('', ['A', 'B']), 'Empty string in array of AB'); - CheckEquals(-1, StrIndex('A', []), '''A'' string in empty array'); - CheckEquals(0, StrIndex('A', ['A', 'B']), '''A'' string in array of AB, equal case'); - CheckEquals(0, StrIndex('a', ['A', 'B']), '''A'' string in array of AB, differing case'); - CheckEquals(1, StrIndex('B', ['A', 'B']), '''B'' string in array of AB, equal case'); - CheckEquals(2, StrIndex('C', ['A', 'B', 'C', 'C']), '''C'' string in array of ABCC, equal case'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrILastPos; -begin - CheckEquals(10, StrILastPos('A', 'aaaaaaaaaa'), 'StrILastPos_1'); - CheckEquals(16, StrILastPos('abA', 'aabaaababababababa'), 'StrILastPos_2'); - CheckEquals(8, StrILastPos('abbA', 'abbaabbabba'), 'StrILastPos_3'); - CheckEquals(0, StrILastPos('_abba', 'abbaabbabba'), 'StrILastPos_4'); - CheckEquals(5, StrILastPos('_aBBa', 'abba_abbabba'), 'StrILastPos_5'); - CheckEquals(15, StrILastPos('ABA', 'aabaaaABAbabababa'), 'StrILastPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIPos; -begin - CheckEquals(1, StrIPos('A', 'aaaaaaaaaa'), 'StrIPos_1'); - CheckEquals(2, StrIPos('abA', 'aabaaababababababa'), 'StrIPos_2'); - CheckEquals(1, StrIPos('abbA', 'abbaabbabba'), 'StrIPos_3'); - CheckEquals(0, StrIPos('_abba', 'abbaabbabba'), 'StrIPos_4'); - CheckEquals(5, StrIPos('_aBBa', 'abba_abbabba'), 'StrIPos_5'); - CheckEquals(2, StrIPos('ABA', 'aabaaaABAbabababa'), 'StrIPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIPrefixIndex; -begin - CheckEquals(0, StrIPrefixIndex('Project',['Pro']), 'StrIPrefixIndex1'); - CheckEquals(0, StrIPrefixIndex('Project',['Pro','Con']), 'StrIPrefixIndex2'); - CheckEquals(0, StrIPrefixIndex('Project',['']), 'StrIPrefixIndex3'); - CheckEquals(1, StrIPrefixIndex('Project',['Con','Pro']), 'StrIPrefixIndex4'); - CheckEquals(1, StrIPrefixIndex('Project',['Con','PRO']), 'StrIPrefixIndex5'); - CheckEquals(-1, StrIPrefixIndex('Project',['Con','PRA']), 'StrIPrefixIndex5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrIsOneOf; -begin - CheckEquals(True, StrIsOneOf('Test', ['a','atest','Test', 'Fest']), 'StrIsOneOf_1'); - CheckEquals(False, StrIsOneOf('Test', ['a','atest', 'Fest']), 'StrIsOneOf_2'); - CheckEquals(False, StrIsOneOf('', ['a','atest', 'Fest']), 'StrIsOneOf_3'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrLastPos; -begin - CheckEquals(10, StrLastPos('a', 'aaaaaaaaaa'), 'StrLastPos_1'); - CheckEquals(16, StrLastPos('aba', 'aabaaababababababa'), 'StrLastPos_2'); - CheckEquals(8, StrLastPos('abba', 'abbaabbabba'), 'StrLastPos_3'); - CheckEquals(0, StrLastPos('_abba', 'abbaabbabba'), 'StrLastPos_4'); - CheckEquals(5, StrLastPos('_abba', 'abba_abbabba'), 'StrLastPos_5'); - CheckEquals(7, StrLastPos('ABA', 'aabaaaABAbabababa'), 'StrLastPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrMatch; -begin - CheckEquals(0, StrMatch('', 'Test', 1), 'StrMatch_1'); - CheckEquals(1, StrMatch('Test', 'Test', 1), 'StrMatch_2'); - CheckEquals(2, StrMatch('Test', 'aTest', 1), 'StrMatch_3'); - CheckEquals(3, StrMatch('Test', 'abTest', 1), 'StrMatch_4'); - CheckEquals(4, StrMatch('Test', 'abcTest', 1), 'StrMatch_5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrNPos; -begin - CheckEquals(0, StrNPos('testtesttest','Test',3)); // case sensitive test - CheckEquals(9, StrNPos('TestTestTest','Test',3)); - - CheckEquals(1, StrNPos('Test','Test',1), 'StrNPos_1'); - CheckEquals(0, StrNPos('Test','Test',0), 'StrNPos_2'); - CheckEquals(0, StrNPos('Test','Test',-1), 'StrNPos_3'); - CheckEquals(5, StrNPos('TestTest','Test',2), 'StrNPos_4'); - CheckEquals(0, StrNPos('Testtest','Test',2), 'StrNPos_5'); - CheckEquals(3, StrNPos('__Test__','Test',1), 'StrNPos_6'); - CheckEquals(9, StrNPos('__Test__Test','Test',2), 'StrNPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrMatches; -begin - //CheckEquals(False, StrMatches('','Test',1), 'StrMatches_1'); - CheckEquals(True, StrMatches('Test','Test',1), 'StrMatches_2'); - CheckEquals(True, StrMatches('Test','aTest',2), 'StrMatches_3'); - CheckEquals(False, StrMatches('Test','abTest',1), 'StrMatches_4'); - CheckEquals(False, StrMatches('Test','abcTest',1), 'StrMatches_5'); - CheckEquals(True, StrMatches('T?st', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T??t', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T*', 'Test'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T*st', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T*st', 'Tett'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T???', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T???', 'Tes'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T?*', 'Test'), 'StrMatches_6'); - CheckEquals(False, StrMatches('T?*', 'T'), 'StrMatches_6'); - CheckEquals(True, StrMatches('T?s?', 'Test'), 'StrMatches_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrNIPos; -begin - CheckEquals(5, StrNIPos('aaaaaaaaaa', 'A', 5), 'StrNIPos_1'); - CheckEquals(0, StrNIPos('aabaaababababababa', 'abA', 0), 'StrNIPos_2'); - CheckEquals(0, StrNIPos('abbaabbabba', 'abbA', 4), 'StrNIPos_3'); - CheckEquals(8, StrNIPos('abbaabbabba', 'abba', 3), 'StrNIPos_4'); - CheckEquals(5, StrNIPos('abba_abbabba', '_aBBa', 1), 'StrNIPos_5'); - CheckEquals(11, StrNIPos('aabaaaABAbabababa', 'ABA', 4), 'StrNIPos_6'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrPrefixIndex; -begin - CheckEquals(0, StrPrefixIndex('Project',['Pro']), 'StrPrefixIndex1'); - CheckEquals(0, StrPrefixIndex('Project',['Pro','Con']), 'StrPrefixIndex2'); - CheckEquals(0, StrPrefixIndex('Project',['']), 'StrPrefixIndex3'); - CheckEquals(1, StrPrefixIndex('Project',['Con','Pro']), 'StrPrefixIndex4'); - CheckEquals(-1, StrPrefixIndex('Project',['Con','PRO']), 'StrPrefixIndex5'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringSearchandReplace._StrSearch; -begin - CheckEquals(StrSearch('', '', 1), 0, 'StrSearch_1'); - CheckEquals(StrSearch('Test', 'Test', 1), 1, 'StrSearch_2'); - CheckEquals(StrSearch('Test', 'Test12', 1), 1, 'StrSearch_3'); - CheckEquals(StrSearch('Test', 'Test123', 1), 1, 'StrSearch_4'); - CheckEquals(StrSearch('Test', 'abTest123', 1), 3, 'StrSearch_5'); - CheckEquals(StrSearch('Test', 'abTest123', 3), 3, 'StrSearch_6'); - CheckEquals(StrSearch('Test', 'abTaest123', 3), 0, 'StrSearch_7'); - CheckEquals(StrSearch('Test', 'abT', 4), 0, 'StrSearch_8'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharEqualNoCase; -var - c1, c2: char; - -begin - for c1 := #0 to #255 do - for c2 := #0 to #255 do - Check(CharEqualNoCase(c1,c2) = (AnsiUpperCase(C1) = AnsiUpperCase(C2)),Format('CharEqualNoCase: C1: %s C2: %s',[c1,c2])); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsAlpha; -var - C: char; -begin - for C := #0 to #255 do - CheckEquals( - isalpha(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #181, #186, #192 .. #214, - #216 .. #246, #248 .. #255]), - CharIsAlpha(C), - 'CharIsAlpha #' + IntToStr(Ord(C))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsAlphaNum; -var - C: char; -begin - for C := #0 to #255 do - CheckEquals( - isalnum(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #178, #179, #181, #185, #186, - #192 .. #214, #216 .. #246, #248 .. #255]), - CharIsAlphaNum(C) , - 'CharIsAlphaNum #' + IntToStr(Ord(C))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsBlank; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#9, ' ', #160]), - CharIsBlank(c1), - 'CharIsBlank #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsControl; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), - CharIsControl(c1), - 'CharIsControl #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsDelete; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals((ord(c1) = 8), CharIsDelete(c1), 'CharIsDelete #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsDigit; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['0'..'9', #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), - CharIsDigit(c1), - 'CharIsDigit #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsNumberChar; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['0'..'9', '+', '-', DecimalSeparator, #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), - CharIsNumberChar(c1), - 'CharIsNumberChar #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsPrintable; -var - c1: char; - -begin - for c1 := #0 to #255 do - CheckEquals( - not (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), - CharIsPrintable(c1), - 'CharIsPrintable #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsPunctuation; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [#123..#126, #130, #132 .. #135, #137, #139, #145 .. #151, #155, #161 .. #191, #215, #247, - #91..#96, #38..#47, '@', #60..#63, '#','$','%','"','.',',','!',':','=',';']), - CharIsPunctuation(c1), - 'CharIsPunctuation #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsReturn; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals(((c1 = #13) or (c1 = #10)), CharIsReturn(c1), 'CharIsReturn #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsSpace; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - c1 in [#9, #10, #11, #12, #13, ' ', #160], - CharIsSpace(c1), - 'CharIsSpace #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsWhiteSpace; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in [NativeTab, NativeLineFeed, NativeVerticalTab, NativeFormFeed, NativeCarriageReturn, NativeSpace]), - CharIsWhiteSpace(c1), - 'CharIsWhiteSpace #' + IntToStr(Ord(c1)) - ); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsUpper; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['A'..'Z', #138, #140, #142, #159, #192 .. #214, #216 .. #222]), - CharIsUpper(c1), - 'CharIsUpper #' + IntToStr(Ord(c1))); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringCharacterTestRoutines._CharIsLower; -var - c1: char; -begin - for c1 := #0 to #255 do - CheckEquals( - (c1 in ['a' .. 'z', #131, #154, #156, #158, #170, #181, #186, #223 .. #246, #248 .. #255]), - CharIsLower(c1), - 'CharIsLower #' + IntToStr(Ord(c1))); -end; - - -//================================================================================================== -// String Extraction -//================================================================================================== - -procedure TJclStringExtraction._StrAfter; -begin - CheckEquals(StrAfter('',''),'','StrAfter'); - CheckEquals(StrAfter('Hello', 'Hello World'),' World','StrAfter'); - CheckEquals(StrAfter('Hello ', 'Hello World'),'World','StrAfter'); - CheckEquals(StrAfter('is a ', 'This is a test.'),'test.','StrAfter'); - CheckEquals(StrAfter('is a ', 'This is a test. is a test'),'test. is a test','StrAfter'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrBefore; -begin - CheckEquals(StrBefore('',''),'','StrBefore'); - CheckEquals(StrBefore('World', 'Hello World'),'Hello ','StrBefore'); - CheckEquals(StrBefore('Hello ', 'Hello World'),'','StrBefore'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrBetween; -begin - CheckEquals('', StrBetween('', Char(#0), Char(#0)), 'StrBetween1'); - CheckEquals('', StrBetween('', Char(#0), Char(#1)), 'StrBetween2'); - CheckEquals('Test', StrBetween('aTestb', Char('a'), Char('b')), 'StrBetween3'); - CheckEquals('Test', StrBetween(' Test ', Char(' '), Char(' ')), 'StrBetween4'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrChopRight; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrChopRight('',i),'','StrChopRight'); - - CheckEquals(StrChopRight('Project JEDI',1),'Project JED','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',2),'Project JE','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',3),'Project J','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',4),'Project ','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',5),'Project','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',15),'','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',50),'','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',-5),'Project JEDI','StrChopRight'); - CheckEquals(StrChopRight('Project JEDI',-50),'Project JEDI','StrChopRight'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrLeft; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrLeft('',i),'','StrLeft'); - - CheckEquals(StrLeft('Project JEDI',0),'','StrLeft'); - CheckEquals(StrLeft('Project JEDI',1),'P','StrLeft'); - CheckEquals(StrLeft('Project JEDI',3),'Pro','StrLeft'); - CheckEquals(StrLeft('Project JEDI',5),'Proje','StrLeft'); - CheckEquals(StrLeft('Project JEDI',-5),'','StrLeft'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrMid; -begin - CheckEquals(StrMid('Test',1,4),'Test','StrLeft'); - CheckEquals(StrMid('Test',1,3),'Tes','StrLeft'); - CheckEquals(StrMid('Test',1,2),'Te','StrLeft'); - CheckEquals(StrMid('Test',1,1),'T','StrLeft'); - CheckEquals(StrMid('Test',1,-1),'','StrLeft'); - CheckEquals(StrMid('Test',1,0),'','StrLeft'); - CheckEquals(StrMid('Test',2,0),'','StrLeft'); - CheckEquals(StrMid('Test',2,4),'est','StrLeft'); - CheckEquals(StrMid('Test',2,3),'est','StrLeft'); - CheckEquals(StrMid('Test',2,2),'es','StrLeft'); - CheckEquals(StrMid('Test',2,1),'e','StrLeft'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrRight; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrRight('',i),'','StrRight'); - - CheckEquals(StrRight('Test',1),'t','StrRight'); - CheckEquals(StrRight('Test',2),'st','StrRight'); - CheckEquals(StrRight('Test',3),'est','StrRight'); - CheckEquals(StrRight('Test',4),'Test','StrRight'); - CheckEquals(StrRight('Test',8),'Test','StrRight'); - CheckEquals(StrRight('Test',-8),'','StrRight'); -end; - -//-------------------------------------------------------------------------------------------------- - -procedure TJclStringExtraction._StrRestOf; -var - i: Integer; - -begin - for i := -10 to 10 do - CheckEquals(StrRestOf('',i),'','StrRestOf'); - - for i := -100 to -1 do - CheckEquals(StrRestOf('Test',i),'Test','StrRestOf'); - - CheckEquals(StrRestOf('Test',1),'Test','StrRestOf'); - CheckEquals(StrRestOf('Test',2),'est','StrRestOf'); - CheckEquals(StrRestOf('Test',3),'st','StrRestOf'); -end; - -//-------------------------------------------------------------------------------------------------- - -(* -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.CharacterTransformationRoutines; -var - i,t : integer; - c1, c2: char; - charhextable: array[0..255] of byte; - -begin - // -- CharHex -- - for i:=0 to 255 do - charhextable[i] := $FF; - - for i := ord('0') to ord('9') do - charhextable[i] := i - ord('0'); - - for i := ord('a') to ord('f') do - charhextable[i] := 10 + i - ord('a'); - - for i := ord('A') to ord('F') do - charhextable[i] := 10 + i - ord('A'); - - for c1 := #0 to #255 do - CheckEquals(CharHex(c1) , charhextable[ord(c1)], 'CharHex'); - - // -- CharLower -- - for c1 := 'A' to 'Z' do - CheckEquals(CharLower(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharLower %s (%d)',[string(c1),ord(c1)])); - - // -- CharUpper -- - for c1 := 'a' to 'z' do - CheckEquals(CharUpper(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharUpper %s (%d)',[string(c1),ord(c1)])); - - // -- CharToggleCase -- - for c1 := 'a' to 'z' do - CheckEquals(CharToggleCase(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); - - for c1 := 'A' to 'Z' do - CheckEquals(CharToggleCase(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.CharacterSearchandReplace; -var - s: string; - Strings: TStringList; - c, c1, c2: char; - index, i, r: Integer; - -begin - Strings := TStringList.Create; - try - Strings.LoadFromFile('Data/charpos.dat'); - - i := 0; - - while i < Strings.Count do - begin - s := Strings.Strings[i]; - c := (Strings.Strings[i+1])[1]; - index := strtoint(Strings.Strings[i+2]); - r := CharPos(s, c, index); - Check(r = strtoint(Strings.Strings[i+3]),Format('CharPos %s %s %d %d ',[s,c,index, r])); - r := CharIPos(s, c, index); - Check(r = strtoint(Strings.Strings[i+4]),Format('CharIPos %s',[s])); - inc(i,5); - end; - - c := #0; - r := CharIPos('',c); - CheckEquals(r , 0,'CharIPos'); - r := CharPos('',c); - CheckEquals(r , 0,'CharPos'); - - // -- CharReplace -- - - Strings.LoadFromFile('Data/charreplace.dat'); - - i := 0; - - while i < Strings.Count - 1 do - begin - s := Strings.Strings[i]; - c1 := (Strings.Strings[i+1])[1]; - c2 := (Strings.Strings[i+2])[1]; - r := strtoint(Strings.Strings[i+3]); - CheckEquals(CharReplace(s,c1,c2), r , 'CharReplace'); - CheckEquals(s, Strings.Strings[i+4] , 'CharReplace'); - inc(i,5); - end; - - SetLength(s,0); - CheckEquals(CharReplace(s,#0,#0) , 0,'CharReplace'); - - finally - Strings.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.PCharVectorRoutines; -var - Strings: TStringList; - Strings2: TStringList; - Vector: PCharVector; - i: Integer; - -begin - // -- StringsToPCharVector -- - Strings := TStringList.Create; - try - Strings2 := TStringList.Create; - - try - for i := 1 to 1000 do - begin - Strings.Add(inttostr(i)) - end; - - StringsToPCharVector(Vector, Strings); - - // -- PCharVectorCount -- - CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); - CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); - - for i := 1001 to 1500 do - begin - Strings.Add(inttostr(i)) - end; - - StringsToPCharVector(Vector, Strings); - - // -- PCharVectorCount -- - CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); - CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); - - // -- PCharVectorToStrings -- - PCharVectorToStrings(Strings2, Vector); - - for i := 0 to 1499 do - begin - CheckEquals(Strings.Strings[i],Strings2.Strings[i],'PCharVectorToStrings'); - end; - - // -- FreePCharVector -- - FreePCharVector(Vector); - CheckEquals(Integer(Vector),0,'FreePCharVector'); - finally - Strings2.Free; - end; - - finally - Strings.Free; - end; - -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.MultiSzRoutines; -var - msz: PChar; - g: TStringList; - nb: Integer; - mszo: PChar; - s: string; - -begin - g := TStringList.Create; - try - g.Add('Project'); - g.Add('JEDI'); - g.Add('RULES!'); - - StringsToMultiSz(Msz, g); - - // Check it in memory - s := 'Project' + #0 + 'JEDI' + #0 + 'RULES!' + #0 + #0; - MsZo := PChar(s); - - CheckEquals(CompareMem(Msz, MszO, 21), True, 'StringsToMultiSz'); - - FreeMultiSz(Msz); - finally - g.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.TStringsManipulation; -var - source, dest: TStringList; - -begin - // -- StrToStrings -- - - // -- StringsToStr -- - - // -- TrimStrings -- - - // -- TrimStringsRight -- - - // -- TrimStringsLeft -- -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringsTest.Miscellaneous; -var - S: String; - B: Boolean; - SL: TStringList; - -begin - // -- BooleanToStr -- - B := True; - CheckEquals(BooleanToStr(B) , 'True', 'BooleanToStr(TRUE)'); - CheckEquals(BooleanToStr(not B) , 'False', 'BooleanToStr(FALSE)'); - - // -- FileToString -- - // -- StringToFile -- - - // -- StrToken -- - S := 'Test1;Test2'; - CheckEquals(StrToken(s,';'),'Test1','StrToken'); - CheckEquals(S,'Test2','StrToken'); - - S := ';Test'; - CheckEquals(StrToken(s,';'),'','StrToken'); - CheckEquals(S,'Test','StrToken'); - - S := ';;Test'; - CheckEquals(StrToken(s,';'),'','StrToken'); - CheckEquals(S,';Test','StrToken'); - - // -- StrTokens -- - // -- StrTokenToStrings -- - SL := TStringList.Create; - - S := 'Test1;Test2;Test3;Test4'; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Strings[0],'Test1','StrToken'); - CheckEquals(SL.Strings[1],'Test2','StrToken'); - CheckEquals(SL.Strings[2],'Test3','StrToken'); - CheckEquals(SL.Strings[3],'Test4','StrToken'); - CheckEquals(SL.Count, 4,'StrTokenToStrings'); - - SL.Clear; - S := 'Test1;;Test3;Test4'; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Strings[0],'Test1','StrTokenToStrings'); - CheckEquals(SL.Strings[1],'','StrTokenToStrings'); - CheckEquals(SL.Strings[2],'Test3','StrTokenToStrings'); - CheckEquals(SL.Strings[3],'Test4','StrTokenToStrings'); - CheckEquals(SL.Count, 4,'StrTokenToStrings'); - - SL.Clear; - S := ''; - StrTokenToStrings(S,';',SL); - CheckEquals(SL.Count, 0,'StrTokenToStrings'); - SL.Free; - - // -- StrWord -- - // -- StrToFloatSafe -- - // -- StrToIntSafe -- -end; - -*) - -//================================================================================================== -// TabSet -//================================================================================================== - -procedure TJclStringTabSet._CalculatedTabWidth; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; -begin - tabs1 := TJclTabSet.Create([4,8], True); - try - CheckEquals(0, tabs1.TabWidth, 'tabs1.TabWidth'); - CheckEquals(4, tabs1.ActualTabWidth, 'tabs1.ActualTabWidth'); - finally - FreeAndNil(tabs1); - end; - - tabs2 := TJclTabSet.Create([4,7], False, -1); - try - CheckEquals(-1, tabs2.TabWidth, 'tabs2.TabWidth'); - CheckEquals(3, tabs2.ActualTabWidth, 'tabs2.ActualTabWidth'); - finally - FreeAndNil(tabs2); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Clone; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; - - procedure NilClone; - begin - tabs1 := nil; - tabs2 := tabs1.Clone; - try - CheckTrue(tabs2 = nil, 'NilClone: tabs2 = nil'); - finally - FreeAndNil(tabs2); - end; - end; - - procedure NormalClone; - begin - tabs1 := TJclTabSet.Create([4, 8], False, 2); - try - tabs2 := tabs1.Clone; - try - CheckTrue(tabs1 <> tabs2, 'NormalClone: tabs1 <> tabs2'); - CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalClone: .TabWidth'); - CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalClone: .ActualTabWidth'); - CheckEquals(tabs1.Count, tabs2.Count, 'NormalClone: .Count'); - CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalClone: .TabStops[0]'); - CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalClone: .TabStops[1]'); - - // changing values in one reference should not influence the other reference - tabs1.TabWidth := 3; - CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); - - // freeing the first instance should leave the second instance working - FreeAndNil(tabs1); - CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); - finally - FreeAndNil(tabs2); - end; - finally - FreeAndNil(tabs1); - end; - end; - -begin - NilClone; - NormalClone; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Expand; -var - tabs: TJclTabSet; - inp: string; - exp: string; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - inp := 'Test:'#9'LD'#9'A,(HL)'#9'; Read from memory'#13#10+ - #9'LD'#9'B, 100'#13#10 + - #9'CALL'#9'Test2'#13#10+ - #9#9#9'; another comment'; - exp := 'Test: LD A,(HL) ; Read from memory'#13#10 + - ' LD B, 100'#13#10 + - ' CALL Test2'#13#10+ - ' ; another comment'; - CheckEqualsString(exp, tabs.Expand(inp)); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._FromString; -var - tabs: TJclTabSet; -begin - // just a tab width - tabs := TJclTabSet.FromString('+4'); - try - CheckEquals(0, tabs.Count, 'FromString(''+4'').Count'); - CheckEquals(False, tabs.ZeroBased, 'FromString(''+4'').ZeroBased'); - CheckEquals(4, tabs.ActualTabWidth, 'FromString(''+4'').ActualTabWidth'); - CheckEquals(4, tabs.TabWidth, 'FromString(''+4'').TabWidth'); - finally - FreeAndNil(tabs); - end; - - // stops and tab width; with excessive whitespace, including tab - tabs := TJclTabSet.FromString('4, 7 ' + #9 + '+4'); - try - CheckEquals(2, tabs.Count, 'FromString(''4, 7 '' + #9 + ''+4'').Count'); - CheckEquals(4, tabs[0], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[0]'); - CheckEquals(7, tabs[1], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[1]'); - CheckEquals(False, tabs.ZeroBased, 'FromString(''4, 7 '' + #9 + ''+4'').ZeroBased'); - CheckEquals(4, tabs.ActualTabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').ActualTabWidth'); - CheckEquals(4, tabs.TabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').TabWidth'); - finally - FreeAndNil(tabs); - end; - - // zero-based, bracketed stops, auto width - tabs := TJclTabSet.FromString('0[4,7]'); - try - CheckEquals(2, tabs.Count, 'FromString(''0[4,7]'').Count'); - CheckEquals(4, tabs[0], 'FromString(''0[4,7]'').tabs[0]'); - CheckEquals(7, tabs[1], 'FromString(''0[4,7]'').tabs[1]'); - CheckEquals(True, tabs.ZeroBased, 'FromString(''0[4,7]'').ZeroBased'); - CheckEquals(3, tabs.ActualTabWidth, 'FromString(''0[4,7]'').ActualTabWidth'); - CheckTrue(tabs.TabWidth < 1, 'FromString(''0[4,7]'').TabWidth'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._NilSet; -var - tabs: TJclTabSet; -begin - // simplify nil tabset access - tabs := nil; - - // nil tabset should be zero based - CheckTrue(tabs.ZeroBased, 'Nil tabset.ZeroBased'); - - // nil tabset should have no tab stops - CheckEquals(0, tabs.Count, 'Nil tabset.Count'); - - // nil tabset should have an actual tabwidth of 2 - CheckEquals(2, tabs.ActualTabWidth, 'Nil tabset.ActualTabWidth'); - - // nil tabset should have a set tabwidth of <1 or 2 - CheckTrue((tabs.TabWidth = 2) or (tabs.TabWidth < 1), 'Nil tabset.TabWidth'); - - // nil tabset expand test - CheckEquals('A bc de', tabs.Expand('A'#9'bc'#9'de'), 'Nil tabset.Expand') -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._OptimalFill; -var - tabs: TJclTabSet; - tabCount: Integer; - spaceCount: Integer; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - // test 1: tabs and spaces to get from column 1 to column 17 - tabs.OptimalFillInfo(1, 17, tabCount, spaceCount); - CheckEquals(1, tabCount, 'tabCount for column 1->17'); - CheckEquals(0, spaceCount, 'spaceCount for column 1->17'); - - // test 2: tabs and spaces to get from column 1 to column 4 - tabs.OptimalFillInfo(1, 4, tabCount, spaceCount); - CheckEquals(0, tabCount, 'tabCount for column 1->4'); - CheckEquals(3, spaceCount, 'spaceCount for column 1->4'); - - // test 3: tabs and spaces to get from column 1 to column 34 - tabs.OptimalFillInfo(1, 34, tabCount, spaceCount); - CheckEquals(3, tabCount, 'tabCount for column 1->34'); - CheckEquals(2, spaceCount, 'spaceCount for column 1->34'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Optimize; -var - tabs: TJclTabSet; - inp: string; - exp: string; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - inp := ' '#9' test second'; - exp := #9' test'#9#9#9#9#9' second'; - CheckEquals(exp, tabs.Optimize(inp)); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._Referencing; -var - tabs1: TJclTabSet; - tabs2: TJclTabSet; - - procedure NilReference; - begin - tabs1 := nil; - tabs2 := tabs1.NewReference; - try - CheckTrue(tabs2 = nil, 'NilReference: tabs2 = nil'); - finally - FreeAndNil(tabs2); - end; - end; - - procedure NormalReference; - begin - tabs1 := TJclTabSet.Create([4, 8], False, 2); - try - tabs2 := tabs1.NewReference; - try - CheckTrue(tabs1 <> tabs2, 'NormalReference: tabs1 <> tabs2'); - CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalReference: .TabWidth'); - CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalReference: .ActualTabWidth'); - CheckEquals(tabs1.Count, tabs2.Count, 'NormalReference: .Count'); - CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalReference: .TabStops[0]'); - CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalReference: .TabStops[1]'); - - // changing values in one reference should also occur in the other reference - tabs1.TabWidth := 3; - CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); - - // freeing the first instance should leave the second instance working - FreeAndNil(tabs1); - CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); - finally - FreeAndNil(tabs2); - end; - finally - FreeAndNil(tabs1); - end; - end; - -begin - NilReference; - NormalReference; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabFrom; -var - tabs: TJclTabSet; - idx: Integer; -begin - tabs := TJclTabSet.Create([15, 20, 30], True, 2); - try - // test first fixed stop - // columns 0 through 14 will tab to column 15 - for idx := 0 to 14 do - CheckEquals(15, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test second fixed stop - // columns 15 through 19 will tab to column 20 - for idx := 15 to 19 do - CheckEquals(20, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test third and final fixed stop - // columns 20 through 29 will tab to column 30 - for idx := 20 to 29 do - CheckEquals(30, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - - // test tab width beyond fixed positions - // columns 30 through 39 will tab to column 32 (30-31), 34 (32-33), 36 (34-35), 38 (36-37) or 40 (38-39) - for idx := 30 to 39 do - CheckEquals(2 * Succ(idx div 2), tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopAdding; -var - tabs: TJclTabSet; - x: Integer; - failed: Boolean; -begin - tabs := TJclTabSet.Create([15, 30], True); - try - // Add column 20 and check if the index=1 - CheckEquals(1, tabs.Add(20), 'Index of Add(20)'); - // We should have three stops - CheckEquals(3, tabs.Count, 'Count after Add(20)'); - // The first should be 15 - CheckEquals(15, tabs[0], 'tabs[0]'); - // The second should be 20 - CheckEquals(20, tabs[1], 'tabs[1]'); - // The third should be 30 - CheckEquals(30, tabs[2], 'tabs[2]'); - // Adding a duplicate should fail... - begin - try - x := tabs.Add(30); - failed := True; - except - failed := False; - x := 0; // make compiler happy - end; - if failed then - Fail('tabs.Add(30) returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); - end; - // Adding anything less than StartColumn should fail... - begin - try - x := tabs.Add(tabs.StartColumn - 1); - failed := True; - except - failed := False; - x := 0; - end; - if failed then - Fail('tabs.Add(' + IntToStr(tabs.StartColumn - 1) + ') returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); - end; - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopDeleting; -var - tabs: TJclTabSet; - x: Integer; -begin - tabs := TJclTabSet.Create([15, 17, 20, 30], True, 2); - try - CheckEquals(1, tabs.Delete(17), 'Index of Delete(17)'); - // We should have three stops - CheckEquals(3, tabs.Count, 'Count after Add(20)'); - // The first should be 15 - CheckEquals(15, tabs[0], 'tabs[0]'); - // The second should be 20 - CheckEquals(20, tabs[1], 'tabs[1]'); - // The third should be 30 - CheckEquals(30, tabs[2], 'tabs[2]'); - // Deleting a non-existing tab stop should result in a negative value - x := tabs.Delete(24); - CheckTrue(x < 0, 'tabs.Delete(24) returned ' + IntToStr(x) + '; should''ve returned a negative value.'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._TabStopModifying; -var - tabs: TJclTabSet; -begin - tabs := TJclTabSet.Create([15, 17, 2, 30], True, 2); - try - // check tabs array before overwriting the first tab stop... - CheckEquals(2, tabs[0], 'tabs[0] before modify.'); - CheckEquals(15, tabs[1], 'tabs[1] before modify.'); - CheckEquals(17, tabs[2], 'tabs[2] before modify.'); - CheckEquals(30, tabs[3], 'tabs[3] before modify.'); - // overwrite the first tab stop - tabs[0] := 20; - // check tabs array after overwriting the first tab stop... - CheckEquals(15, tabs[0], 'tabs[0] after modify.'); - CheckEquals(17, tabs[1], 'tabs[1] after modify.'); - CheckEquals(20, tabs[2], 'tabs[2] after modify.'); - CheckEquals(30, tabs[3], 'tabs[3] after modify.'); - finally - FreeAndNil(tabs); - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._ToString; -var - tabs: TJclTabSet; -begin - tabs := TJclTabSet.Create([15, 17, 20, 30], True, 4); - try - CheckEquals('0 [15,17,20,30] +4', tabs.ToString, 'zero-based, full'); - CheckEquals('0 15,17,20,30 +4', tabs.ToString(TabSetFormatting_Default), 'zero-based, default'); - tabs.ZeroBased := False; - CheckEquals('[16,18,21,31] +4', tabs.ToString, 'one-based, full'); - CheckEquals('16,18,21,31 +4', tabs.ToString(TabSetFormatting_Default), 'one-based, default'); - finally - tabs.Free; - end; - - tabs := TJclTabSet.FromString(''); // nil; ????????????????? - CheckEquals('0 [] +2', tabs.ToString, 'nil-set, full'); - CheckEquals('0', tabs.ToString(TabSetFormatting_Default), 'nil-set, default'); -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._UpdatePosition; -var - tabs: TJclTabSet; - column: Integer; - line: Integer; -begin - tabs := TJclTabSet.Create([17, 22, 32], False, 4); - try - column := tabs.StartColumn; - line := 1; - tabs.UpdatePosition( - 'Label1:'#9'LD'#9'A,0'#9'; init A'#13#10+ - #9'LD'#9'B, 100'#9'; loop counter'#13#10+ - #13#10+ - 'lp1:'#9'ADD'#9'(HL)'#9'; add data'#13+ - #9'JR'#9'NC,nxt'#9'; no carry=>skip to nxt'#13+ - #13+ - #9'RRCA'#10+ - #10+ - 'nxt:'#9'INC'#9'H'#9'; next scanline'#13#10+ - #9'DJNZ'#9'lp1', column, line); - CheckEquals(10, line, 'line'); - CheckEquals(25, column, 'column'); - finally - tabs.Free; - end; -end; - -//------------------------------------------------------------------------------ - -procedure TJclStringTabSet._ZeroBased; -var - tabs: TJclTabSet; - x: Integer; - failed: Boolean; -begin - tabs := TJclTabSet.Create([15, 20, 30], True, 2); - try - // make sure it's actually zero-based - CheckTrue(tabs.ZeroBased, 'tabset should be zero based.'); - // can we tab from column 0? - CheckEquals(15, tabs.TabFrom(0), 'tabs.TabFrom(0) in zero-based mode.'); - // we should have three stops - CheckEquals(3, tabs.Count, 'tabs.Count (zero-based)'); - // are they 15, 20 and 30 respectively? - CheckEquals(15, tabs[0], 'tabs[0] (zero-based)'); - CheckEquals(20, tabs[1], 'tabs[1] (zero-based)'); - CheckEquals(30, tabs[2], 'tabs[2] (zero-based)'); - - // switch to not zero-based - tabs.ZeroBased := False; - // make sure it's no longer zero-based - CheckFalse(tabs.ZeroBased, 'tabset shouldn''t be zero based.'); - // we still should have three stops - CheckEquals(3, tabs.Count, 'tabs.Count (not zero-based)'); - // are they 16, 21 and 31 respectively? - CheckEquals(16, tabs[0], 'tabs[0] (not zero-based)'); - CheckEquals(21, tabs[1], 'tabs[1] (not zero-based)'); - CheckEquals(31, tabs[2], 'tabs[2] (not zero-based)'); - // we shouldn't be able to tab from column 0? - try - x := tabs.TabFrom(0); - failed := False; - except - // swallow exception - failed := True; - x := 0; // make compiler happy - end; - if not failed then - Fail('tab.TabFrom(0) resulted in ' + IntToStr(x) + '; should''ve resulted in an exception when not in zero-based mode.'); - finally - FreeAndNil(tabs); - end; -end; - -{ TAnsiStringListTest } - -procedure TAnsiStringListTest._GetCommaTextCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextInnerQuotesProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('"World"'); - slRTL.Add('Hello'); - slRTL.Add('"World"'); - CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TAnsiStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextQuotedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('My World'); - slRTL.Add('Hello'); - slRTL.Add('My World'); - CheckEquals('Hello,"My World"', slJCL.CommaText, 'TAnsiStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetCommaTextSpacedCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World,There!'; - slRTL.CommaText := 'Hello,My World,There!'; - CheckEquals(4, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World'; - slRTL.CommaText := 'Hello,My World'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._GetDelimitedTextFunkyFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextCount; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextInnerQuotesProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"""World"""'; - slRTL.CommaText := 'Hello,"""World"""'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('"World"', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextQuotedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"World"'; - slRTL.CommaText := 'Hello,"World"'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetCommaTextQuotedSpacedProperties; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World",There!'; - slRTL.CommaText := 'Hello,"My World",There!'; - CheckEquals(3, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=3 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello,"My World"'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello,"My World"'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slJCL.DelimitedText := 'Hello,My World'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - slRTL.DelimitedText := 'Hello,My World'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TAnsiStringListTest._SetDelimitedTextFunkyFalse; -var slJCL: TAnsiStringList; - slRTL: TStringList; -begin - slJCL := TAnsiStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello-|My World|'; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello-|My World|'; - CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); - CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -{ TJclStringListTest } - -procedure TJclStringListTest._GetCommaTextCount; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetCommaTextInnerQuotesProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('"World"'); - slRTL.Add('Hello'); - slRTL.Add('"World"'); - CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TJclStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetCommaTextQuotedProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.Add('Hello'); - slJCL.Add('My World'); - slRTL.Add('Hello'); - slRTL.Add('My World'); - CheckEquals('Hello,"My World"', slJCL.CommaText, 'TJclStringList.CommaText'); - CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetCommaTextSpacedCount; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World,There!'; - slRTL.CommaText := 'Hello,My World,There!'; - CheckEquals(4, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,My World'; - slRTL.CommaText := 'Hello,My World'; - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._GetDelimitedTextFunkyFalse; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World"'; - slRTL.CommaText := 'Hello,"My World"'; - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetCommaTextCount; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetCommaTextInnerQuotesProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"""World"""'; - slRTL.CommaText := 'Hello,"""World"""'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('"World"', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetCommaTextProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,World'; - slRTL.CommaText := 'Hello,World'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetCommaTextQuotedProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"World"'; - slRTL.CommaText := 'Hello,"World"'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetCommaTextQuotedSpacedProperties; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.CommaText := 'Hello,"My World",There!'; - slRTL.CommaText := 'Hello,"My World",There!'; - CheckEquals(3, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=3 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello,"My World"'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello,"My World"'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '"'; - slJCL.Delimiter := ','; - slJCL.StrictDelimiter := true; - slJCL.DelimitedText := 'Hello,My World'; - slRTL.QuoteChar := '"'; - slRTL.Delimiter := ','; - slRTL.StrictDelimiter := true; - slRTL.DelimitedText := 'Hello,My World'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SetDelimitedTextFunkyFalse; -var slJCL: TJclStringList; - slRTL: TStringList; -begin - slJCL := TJclStringList.Create; - slRTL := TStringList.Create; - try - slJCL.QuoteChar := '|'; - slJCL.Delimiter := '-'; - slJCL.StrictDelimiter := false; - slJCL.DelimitedText := 'Hello-|My World|'; - slRTL.QuoteChar := '|'; - slRTL.Delimiter := '-'; - slRTL.StrictDelimiter := false; - slRTL.DelimitedText := 'Hello-|My World|'; - CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); - CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); - if slJCL.Count=2 then begin - CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); - CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); - CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); - CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); - end; - finally - FreeAndNil(slJCL); - FreeAndNil(slRTL); - end; -end; - -procedure TJclStringListTest._SplitJoin; -var slJCL: IJclStringList; -begin - slJCL := TJclStringList.Create; - - CheckEquals(0, slJCL.Count); - slJcl.Add('111'); - slJcl.Add('222'); - CheckEquals(2, slJCL.Count); - slJcl.Split('1111f2222f3333f','f'); - CheckEquals(4, slJCL.Count); - CheckEquals(3, slJCL.LastIndex); - CheckEquals(0, Length(slJCL.Last)); - slJcl.Split('1111f2222f3333f','f', False); - CheckEquals(8, slJCL.Count); - CheckEquals(7, slJCL.LastIndex); - CheckEquals(0, Length(slJCL.Last)); - slJcl.Clear; - CheckEquals(0, slJCL.Count); - CheckEquals('', slJCL.Join('111')); - slJcl.Add('0000'); - CheckEquals('0000', slJCL.Join('222')); - slJcl.Split('1111f2222f3333f','f', False); - slJCL.Delete(slJCL.LastIndex); - CheckEquals('0000a1111a2222a3333', slJCL.Join('a')); -end; - -initialization - - RegisterTest('JCLStrings', TJclStringTransformation.Suite); - RegisterTest('JCLStrings', TJclStringManagment.Suite); - RegisterTest('JCLStrings', TJclStringSearchandReplace.Suite); - RegisterTest('JCLStrings', TJclStringCharacterTestRoutines.Suite); - RegisterTest('JCLStrings', TJclStringExtraction.Suite); - RegisterTest('JCLStrings', TJclStringTabSet.Suite); - RegisterTest('JCLStrings', TAnsiStringListTest.Suite); - RegisterTest('JCLStrings', TJCLStringListTest.Suite); - -// History: -// -// $Log$ -// Revision 1.3 2004/12/05 15:55:32 rrossmair -// - restored D5 compatibility -// - -end. +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ DUnit Test Unit } +{ } +{ Covers: JclStrings } +{ Last Update: $Date$ } +{ } +{ 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. } +{ } +{**************************************************************************************************} + +unit TestJclStrings; + +interface +uses + TestFramework, + {$IFDEF MSWINDOWS} + Windows, + {$ELSE} + Types, + {$ENDIF} + Classes, + SysUtils, + JclStrings, + JclStringLists; + +{ TJclStringCharacterTestRoutines } + +type + TJclStringCharacterTestRoutines = class(TTestCase) + private + published + procedure _CharEqualNoCase; + procedure _CharIsAlpha; + procedure _CharIsAlphaNum; + procedure _CharIsBlank; + procedure _CharIsControl; + procedure _CharIsDelete; + procedure _CharIsDigit; + procedure _CharIsNumberChar; + procedure _CharIsPrintable; + procedure _CharIsPunctuation; + procedure _CharIsReturn; + procedure _CharIsSpace; + procedure _CharIsWhiteSpace; + procedure _CharIsUpper; + procedure _CharIsLower; +end; + + +{ TJclStringTransformation } + +type + TJclStringTransformation = class (TTestCase) + private + StringArray : array[0..5000] of string; + StringArray2 : array[0..5000] of string; + + published + { String Transformation } + procedure _StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; + procedure _Deprecated_StrContainsChars_StrIsSubset1; + procedure _StringMatchingAgainstChars; + procedure _StrSame; + procedure _StrIsDigit_StrConsistsOfNumberChars; + procedure _StrCenter; + procedure _StrCharPosLower; + procedure _StrCharPosUpper; + procedure _StrDoubleQuote; + procedure _StrEnsurePrefix; + procedure _StrEnsureSuffix; + procedure _StrEscapedToString_StrStringToEscaped; + procedure _StrLower_StrLowerInPlace_StrLowerBuff; + procedure _StrMove; + procedure _StrPadLeft; + procedure _StrPadRight; + procedure _StrProper_StrProperBuff; + procedure _StrQuote; + procedure _StrReplace; + procedure _StrReplaceChar; + procedure _StrReplaceChars; + procedure _StrReplacebutChars; + procedure _StrRemoveChars; + procedure _StrKeepChars; + procedure _StrRepeat; + procedure _StrRepeatLength; + procedure _StrReverse_StrReverseInPlace; + procedure _StrSingleQuote; + procedure _StrSmartCase; + procedure _StrStripNonNumberChars; + procedure _StrToHex_Ansi; + procedure _StrTrimCharLeft; + procedure _StrTrimCharsLeft; + procedure _StrTrimCharRight; + procedure _StrTrimCharsRight; + procedure _StrTrimQuotes; + procedure _StrUpper_StrUpperInPlace_StrUpperBuff; + end; + + { TJclStringManagment } + + TJclStringManagment = class (TTestCase) + published + procedure StringManagement; + end; + + { TJclStringSearchandReplace } + + TJclStringSearchandReplace = class (TTestCase) + private + StringArray: array[0..5000] of string; + StringArray2: array[0..5000] of string; + ResultArray: array[0..5000] of Integer; + fillIdx: Integer; + procedure AddCheck(const s1, s2: string; const res: Integer); + function NormalizeCompareResult(res: Integer): Integer; + procedure TestCompare(idx: Integer; res: Integer; msgFmt: string); + published + procedure _CompareNaturalStr; + procedure _CompareNaturalText; + procedure _StrCharCount; + procedure _StrCharsCount; + procedure _StrStrCount; + procedure _StrCompare; + procedure _StrCompareRange; + procedure _StrFillChar; + procedure _StrFind; + procedure _StrHasPrefix; + procedure _StrIHasPrefix; + procedure _StrIndex; + procedure _StrILastPos; + procedure _StrIPos; + procedure _StrIPrefixIndex; + procedure _StrIsOneOf; + procedure _StrLastPos; + procedure _StrMatch; + procedure _StrNPos; + procedure _StrMatches; + procedure _StrNIPos; + procedure _StrPrefixIndex; + procedure _StrSearch; + end; + + { TJclStringExtraction } + + TJclStringExtraction = class (TTestCase) + published + procedure _StrAfter; + procedure _StrBefore; + procedure _StrBetween; + procedure _StrChopRight; + procedure _StrLeft; + procedure _StrMid; + procedure _StrRight; + procedure _StrRestOf; + end; + + { TJclStringTabSet } + TJclStringTabSet = class(TTestCase) + published + procedure _CalculatedTabWidth; + procedure _Clone; + procedure _Expand; + procedure _FromString; + procedure _NilSet; + procedure _OptimalFill; + procedure _Optimize; + procedure _Referencing; + procedure _TabFrom; + procedure _TabStopAdding; + procedure _TabStopDeleting; + procedure _TabStopModifying; + procedure _ToString; + procedure _UpdatePosition; + procedure _ZeroBased; +end; + + { TJclStringManagment } + + TAnsiStringListTest = class (TTestCase) + published + procedure _SetCommaTextCount; + procedure _GetCommaTextCount; + procedure _GetCommaTextSpacedCount; + procedure _SetCommaTextProperties; + procedure _SetCommaTextQuotedProperties; + procedure _SetCommaTextQuotedSpacedProperties; + procedure _GetCommaTextQuotedProperties; + procedure _SetCommaTextInnerQuotesProperties; + procedure _GetCommaTextInnerQuotesProperties; + procedure _SetDelimitedTextCommaDoubleQuoteFalse; + procedure _GetDelimitedTextCommaDoubleQuoteFalse; + procedure _SetDelimitedTextCommaDoubleQuoteTrue; + procedure _GetDelimitedTextCommaDoubleQuoteTrue; + procedure _SetDelimitedTextFunkyFalse; + procedure _GetDelimitedTextFunkyFalse; + end; + + TJclStringListTest = class (TTestCase) + published + procedure _SetCommaTextCount; + procedure _GetCommaTextCount; + procedure _GetCommaTextSpacedCount; + procedure _SetCommaTextProperties; + procedure _SetCommaTextQuotedProperties; + procedure _SetCommaTextQuotedSpacedProperties; + procedure _GetCommaTextQuotedProperties; + procedure _SetCommaTextInnerQuotesProperties; + procedure _GetCommaTextInnerQuotesProperties; + procedure _SetDelimitedTextCommaDoubleQuoteFalse; + procedure _GetDelimitedTextCommaDoubleQuoteFalse; + procedure _SetDelimitedTextCommaDoubleQuoteTrue; + procedure _GetDelimitedTextCommaDoubleQuoteTrue; + procedure _SetDelimitedTextFunkyFalse; + procedure _GetDelimitedTextFunkyFalse; + procedure _SplitJoin; + end; + +implementation + +{$IFDEF LINUX} +uses + LibC; +{$ENDIF LINUX} +{$IFDEF WIN32} +const + LibC = 'msvcrt40.dll'; + +function isalnum(C: Integer): LongBool; cdecl; external LibC; +function isalpha(C: Integer): LongBool; cdecl; external LibC; +{$ENDIF WIN32} + +//----------------------------------------------------------------------------------------------- +// Generators +//----------------------------------------------------------------------------------------------- + +procedure GenerateAlpha(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 785378134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + v := random(2); + case v of + 0: s := s + chr(ord('a') + d); + 1: s := s + chr(ord('A') + d); + end; + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaLowerCase(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + s: string; + +begin + RandSeed := 728134; // Everything has to be reproducible + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + s := s + chr(ord('a') + d); + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaUpperCase(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + s: string; + +begin + RandSeed := 728134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + s := s + chr(ord('A') + d); + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAlphaNum(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 785378134; // Everything has to be reproducible + + if RandLen then + Len := random(Len) + 1; + + for t := 1 to Count do + begin + s := ''; + + for i := 1 to Len do + begin + d := random(Ord('z')-Ord('a'))+1; + case random(2) of + 0: begin + v := random(2); + case v of + 0: s := s + chr(ord('a') + d); + 1: s := s + chr(ord('A') + d); + end; + end; + 1: begin + d := random(Ord('9')-Ord('0')); + s := s + chr(ord('0') + d); + end; + end; + end; + + Strings[t-1] := s; + end; +end; + +//------------------------------------------------------------------------------ + +procedure GenerateAll(Len: Cardinal; const Count: Cardinal; + var Strings: array of string; RandLen: Boolean = False); +var + i: integer; + t: Integer; + d: Integer; + v: Integer; + s: string; + +begin + RandSeed := 781134; // Everything has to be reproducible + v := Len; + + for t := 1 to Count do + begin + s := ''; + + if RandLen then + Len := random(v) + 1; + + for i := 1 to Len do + begin + d := random(255); + s := s + chr(1+d); + end; + + Strings[t-1] := s; + end; +end; + +function StrLower2(const S: AnsiString): AnsiString; +var sTemp: String; +begin + sTemp := S; + StrLowerInPlace(sTemp); + Result := sTemp; +end; + +//================================================================================================== +// TJclStringTransformation +//================================================================================================== + +procedure TJclStringTransformation._StrIsAlpha_StrIsAlpaNum_StrIsAlphaNumUnderscore; +var + i: Integer; + s: String; + +begin + CheckEquals(False, StrIsAlpha(''), 'StrIsAlpha'); // per doc + CheckEquals(False, StrIsAlphaNumUnderscore(''), 'StrIsAlphaNumUnderscore9'); // per doc + CheckEquals(False, StrIsAlphaNum(''), 'StrIsAlphaNum'); // per doc + + GenerateAlpha(2000, 1000, stringarray); + + for i := 1 to 500 do + begin + s := stringarray[i-1]; + CheckEquals(True, StrIsAlpha(s), 'StrIsAlpha'); + CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); + end; + + GenerateAlphaNum(2000, 1000, stringarray, True); + + for i := 1 to 500 do + begin + s := stringarray[i-1]; + CheckEquals(True, StrIsAlphaNum(s), 'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s), 'StrIsAlphaNumUnderscore'); + + s := s + '_'; + CheckEquals(False,StrIsAlphaNum(s),'StrIsAlphaNum'); + CheckEquals(True, StrIsAlphaNumUnderscore(s),'StrIsAlphaNumUnderscore'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +function ContainsValidator(const C: Char): Boolean; +begin + Result := (C = 'g') or (C = 'r'); +end; + +procedure TJclStringTransformation._Deprecated_StrContainsChars_StrIsSubset1; +begin + // StrIsSubset + CheckEquals(StrIsSubset('',[' ']), False,'StrIsSubset'); // per doc + + CheckEquals(True, StrContainsChars('AbcdefghiJkl', ['g', 'r'], False), 'array, CheckAll set to False'); + CheckEquals(False, StrContainsChars('AbcdefghiJkl', ['g', 'r'], True), 'array, CheckAll set to True, only 1 occurring'); + CheckEquals(True, StrContainsChars('AbcdefghiJklr', ['g', 'r'], True), 'array, CheckAll set to True, both occurring'); + + CheckEquals(True, StrContainsChars('AbcdefghiJkl', ContainsValidator, False), 'validator, CheckAll set to False'); + // CheckAll=True will not work with a validator, at least not with the same meaning as with the array-based tests. + // The tests are disabled for now. + { + CheckEquals(False, StrContainsChars('AbcdefghiJkl', ContainsValidator, True), 'validator, CheckAll set to True, only 1 occurring'); + CheckEquals(True, StrContainsChars('AbcdefghiJklr', ContainsValidator, True), 'validator, CheckAll set to True, both occurring'); + } +end; + +procedure TJclStringTransformation._StringMatchingAgainstChars; +begin + CheckTrue (StrContainsEveryChar('AbcdefghiJklr', ['g', 'r'])); + CheckTrue (StrContainsEveryChar('', [])); + CheckFalse(StrContainsEveryChar('AbcdefghiJkl', ['g', 'r'])); + CheckTrue (StrContainsEveryChar('AbcdefghiJklr', 'gr')); + CheckTrue (StrContainsEveryChar('', '')); + CheckFalse(StrContainsEveryChar('AbcdefghiJkl', 'gr')); + + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ['g', 'r'])); + CheckTrue (StrContainsSomeChar('AbcdefhiJklr', ['r', 'g'])); + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', 'rg')); + CheckTrue (StrContainsSomeChar('AbcdefghiJkl', 'rg')); + CheckFalse(StrContainsSomeChar('AbcdefhiJkl', ContainsValidator)); + CheckTrue (StrContainsSomeChar('AbcdefghiJkl', ContainsValidator)); + + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ['g', 'r'])); + CheckTrue (StrConsistsOfChars('grrrgr', ['r', 'g'])); + CheckTrue (StrConsistsOfChars('', ['r', 'g'])); + CheckFalse(StrConsistsOfChars('', ['r', 'g'], False)); + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', 'rg')); + CheckTrue (StrConsistsOfChars('grrrgr', 'rg')); + CheckTrue (StrConsistsOfChars('', 'rg')); + CheckFalse (StrConsistsOfChars('', 'rg', False)); + CheckFalse(StrConsistsOfChars('AbcdefghiJklr', ContainsValidator)); + CheckTrue (StrConsistsOfChars('grrrgr', ContainsValidator)); + CheckTrue (StrConsistsOfChars('', ContainsValidator)); + CheckFalse(StrConsistsOfChars('', ContainsValidator, False)); + +(* +function StrContainsEveryChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsEveryChar(const S: string; const Chars: string): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: TCharValidator): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: array of Char): Boolean; overload; +function StrContainsSomeChar(const S: string; const Chars: string): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: TCharValidator; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: array of Char; const AllowEmpty: Boolean = True): Boolean; overload; +function StrConsistsOfChars(const S: string; const Chars: string; const AllowEmpty: Boolean = True): Boolean; overload; + *) +end; + + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSame; +var + i: Integer; + +begin + // StrSame + CheckEquals(StrSame('',''), True, 'StrSame'); // per doc + CheckEquals(True,StrSame('aaa','AAA'), 'StrSame'); // Case insensitive + + GenerateAll(1000, 500, stringarray, True); + GenerateAll(50, 500, stringarray2, True); + + for i := 1 to 500 do + begin + CheckEquals(True, StrSame(stringarray[i-1], stringarray[i-1]), 'StrSame'); + CheckEquals(False, StrSame(stringarray[i-1], stringarray2[i-1]), 'StrSame'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrIsDigit_StrConsistsOfNumberChars; +var s: string; +begin + // StrIsDigit + CheckEquals(StrIsDigit('') , False, 'StrIsDigit'); // per doc + CheckEquals(StrConsistsOfDigits('') , False, 'StrConsistsOfDigits'); // per doc + + // StrConsistsOfNumberChars + CheckEquals(StrConsistsOfNumberChars('') , False,'StrConsistsOfNumberChars'); // per doc + + CheckEquals(StrConsistsOfDigits('2345') , True, 'StrConsistsOfDigits'); // per doc + CheckEquals(StrConsistsOfNumberChars('2345') , True,'StrConsistsOfNumberChars'); // per doc + + s := FormatFloat('#,###.##', -12345.6789); + CheckEquals(StrConsistsOfDigits(s) , False, 'StrConsistsOfDigits'); // per doc + CheckEquals(StrConsistsOfNumberChars(s) , True,'StrConsistsOfNumberChars'); // per doc +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCenter; +var + i: Integer; + s, SN: String; + +begin + // StrCenter should return s unchanged. Since the length parameter is + // smaller than (even negative) the acutal length of S. + + S := '1234567890'; + + for i := -100 to 9 do + begin + SN := StrCenter(S, i, '#'); + CheckEquals(SN, S, 'StrCenter'); + end; + + // StrCenter should add the fill pattern. The length is checked. + + for i := 10 to 400 do + begin + SN := StrCenter(S, i, '#'); + CheckEquals(i, Length(SN), 'StrCenter'); + end; + + // StrCenter work tests. + + SN := StrCenter('', 10, '#'); + CheckEquals(Length(SN), 10, 'StrCenter'); + CheckEquals(SN, '##########', 'StrCenter'); + + SN := StrCenter('t', 6, '#'); + CheckEquals(SN, '##t###', 'StrCenter'); + + SN := StrCenter('t', 7, '!'); + CheckEquals(SN, '!!!t!!!', 'StrCenter'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCharPosLower; +begin + CheckEquals('This is a test.', StrCharPosLower('This is a test.', -1)); + CheckEquals('This is a test.', StrCharPosLower('This is a test.', 0)); + CheckEquals('this is a test.', StrCharPosLower('This is a test.', 1)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrCharPosUpper; +begin + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', -1)); + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 0)); + CheckEquals('This is a test.', StrCharPosUpper('This is a test.', 1)); + CheckEquals('THis is a test.', StrCharPosUpper('This is a test.', 2)); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrDoubleQuote; +var + SN, S: string; + i: Integer; + +begin + SN := StrDoubleQuote(''); + CheckEquals('""', SN, 'StrDoubleQuote'); + + SN := StrDoubleQuote('Project JEDI'); + CheckEquals('"Project JEDI"',SN, 'StrDoubleQuote'); + + // Test if String is has been quoted. Since StrDoubleQuote adds quotes also + // when they are already there no special tests are needed. + + GenerateAll(2000,200, StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + CheckEquals('"'+S+'"',StrDoubleQuote(s) ,'StrDoubleQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEnsurePrefix; +var + Prefix, s, SN: String; + I: Integer; + +begin + s := 'TestIt!'; + CheckEquals('TestIt!', StrEnsurePrefix('',S), 'StrEnsurePrefix'); + CheckEquals(StrEnsurePrefix(S,''), 'TestIt!', 'StrEnsurePrefix'); + CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!', 'StrEnsurePrefix'); + + s := 'TestIT!'; + CheckEquals(StrEnsurePrefix('TestIt!',S), 'TestIt!TestIT!','StrEnsurePrefix'); + + // Test StrEnsurePrefix using the Generators. S is the string, Prefix the + // wanted prefix and SN is prefix + s or s if the prefix is already there. + + GenerateAll(2000, 100, StringArray, True); + GenerateAll(20, 100, StringArray2, True); + + for i := 1 to 100 do + begin + S := StringArray[i-1]; + Prefix := StringArray2[i-1]; + + SN := StrEnsurePrefix(Prefix,S); + + if copy(s, 0, length(Prefix)) <> prefix then + Check(SN = prefix+s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])) + else + Check(SN = s, Format('StrEnsurePrefix source: %s prefix: %s result: %s ', [s, prefix, sn])); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEnsureSuffix; +var + Suffix, s, SN: String; + I: Integer; +begin + s := 'TestIt!'; + CheckEquals(StrEnsureSuffix('',S), 'TestIt!', 'StrEnsureSuffix'); + CheckEquals(StrEnsureSuffix(S,''), 'TestIt!', 'StrEnsureSuffix'); + CheckEquals(StrEnsureSuffix('TestIt!',S), 'TestIt!', 'StrEnsureSuffix'); + + s := 'TestIT!'; + CheckEquals(StrEnsureSuffix('TestIt!',S) , 'TestIT!TestIt!', 'StrEnsureSuffix'); + + // Test StrEnsureSuffix using the Generators. S is the string, Suffix the + // wanted suffix and SN is s + suffix or s if the suffix is already there. + + GenerateAll(2000, 200, StringArray, True); + GenerateAll(20, 200, StringArray2, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + Suffix := StringArray2[i-1]; + + SN := StrEnsureSuffix(suffix,s); + + if copy(s, length(s) - length(suffix), 300) <> suffix then + Check(SN = s + suffix, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])) + else + Check(SN = s, Format('StrEnsureSuffix source: %s prefix: %s result: %s ', [s, suffix, sn])); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrEscapedToString_StrStringToEscaped; +var + s, sn: string; + i: Integer; + + +begin + S := StrEscapedToString(''); + sn := ''; + CheckEquals(StrEscapedToString(SN), S, 'StrEscapedToString'); + + GenerateAll(1000, 200, StringArray, true); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + sn := StrStringToEscaped(s); + + CheckEquals(StrEscapedToString(SN), s, 'StrEscapedToString'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrLower_StrLowerInPlace_StrLowerBuff; +var + sp: pointer; + i: Integer; + s, sn: string; + +begin + CheckEquals(StrLower(''), '', 'StrLower'); + + { LowerBuff nil tests } + sp := nil; + StrLowerBuff(nil); + StrLowerBuff(sp); + CheckEquals(Integer(sp), Integer(nil), 'StrLowerBuff'); + + { Tests StrLower, StrLowerBuff and StrLowerInPlace against AnsiLowerCase and + against each other. The Testdata consits of only uppercase chars in this test. } + + GenerateAlphaUpperCase(500,500,StringArray, True); + + for i := 1 to 500 do + begin + s := StringArray[i-1]; + SN := s; + StrLowerInPlace(SN); + CheckEquals(StrLower(s), AnsiLowerCase(s), 'StrLower'); + CheckEquals(StrLower(s), SN, 'StrLower'); + + StrLowerBuff(PChar(s)); + CheckEquals(s, SN,'StrLowerBuff'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrMove; +var + Dest: string; + +begin + Dest := 'ATest'; + + StrMove(Dest, 'xxxx', 1, 1, 5); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 4, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', -1, 1, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, -1, 3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 1, -3); + CheckEquals('ATest',Dest, 'StrMove'); + + StrMove(Dest, 'xxxx', 1, 1, 3); + CheckEquals('xxxst',Dest, 'StrMove'); + + Dest := 'ATest'; + StrMove(Dest, 'abcd', 3, 2, 2); + CheckEquals('ATbct',Dest, 'StrMove'); + + Dest := 'ATest'; + StrMove(Dest, 'abcd', 5, 4, 1); + CheckEquals('ATesd',Dest, 'StrMove'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrPadLeft; +var + S, S3: String; + I, v,t: Integer; + +begin + // -- StrPadLeft -- + + S := ''; + S := StrPadLeft(S, 10, '#'); + CheckEquals(S, '##########','StrPadLeft'); + + s := StrPadLeft(S, -10, '$'); + CheckEquals(S , '##########','StrPadLeft'); + + { StrPadLeft is tested using the Generator. A random number of dollar signs are + added to the string s. The first comparisation test against the length, the + second performs an actual test.} + + GenerateAll(2000,100, StringArray, True); + RandSeed := 123456; + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + v := random(20)+2; + + s3 := StrPadLeft(s, length(s) + v, '$'); + CheckEquals(Length(s3), length(s) + v,'StrPadLeft'); + + for t := 1 to v do + s := '$' + s; + + CheckEquals(s3, s,'StrPadLeft'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrPadRight; +var + S, S3: String; + I, v,t: Integer; + +begin + // -- StrPadRight -- + S := ''; + s := StrPadRight(S, 10, '#'); + CheckEquals(S , '##########','StrPadRight'); + + s := StrPadRight(S, -10, '$'); + CheckEquals(S , '##########','StrPadRight'); + + { StrPadRight is tested using the Generator. A random number of percent char are + added to the string s. The first comparisation test against the length, the + second performs an actual test.} + + GenerateAll(2000,100,StringArray, True); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + v := random(20)+2; + s3 := StrPadRight(s, length(s) + v, '%'); + CheckEquals(Length(s3), length(s) + v,'StrPadRight'); + + for t := 1 to v do + s := s + '%'; + + CheckEquals(s3, s,'StrPadRight'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrProper_StrProperBuff; +var + s, s3: string; + +begin + CheckEquals('', StrProper(''), 'StrProper1'); + CheckEquals('Test', StrProper('Test') , 'StrProper2'); + CheckEquals('Test', StrProper('TeSt'), 'StrProper3'); + CheckEquals('Test', StrProper('TEST'), 'StrProper4'); + CheckEquals('Test1234', StrProper('TeST1234'), 'StrProper5'); + CheckEquals('Test1234', StrProper('teST1234'), 'StrProper6'); + + s := 'TeST'; + s3 := s; + s3 := StrProper(s); + CheckNotEquals(s, s3, 'StrProper7'); + + // check if StrProperBuff can handle a nil pointer + StrProperBuff(nil); + + // check StrProperBuff works as expected + s3 := Copy(s, 1, Length(s)); + StrProperBuff(PChar(s3)); + CheckEquals('Test', s3, 'StrProperBuff.2') +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrQuote; +var + i: Integer; + s: string; + +begin + CheckEquals(StrQuote('','#'), '','StrQuote'); + CheckEquals(StrQuote('a','#'), '#a#','StrQuote'); + CheckEquals(StrQuote('Test','#'), '#Test#','StrQuote'); + CheckEquals(StrQuote('#Test#','#'), '#Test#','StrQuote'); + CheckEquals(StrQuote('"Test"','#'), '#"Test"#','StrQuote'); + CheckEquals(StrQuote('"Test#','"'), '"Test#"','StrQuote'); + + { StrQuote is tested using the Generator. Since it is possible that the char + is already on the left or right side we have to check all four cases.} + + GenerateAll(2000,200,StringArray, True); + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + if (s[1] <> '"') and (s[Length(s)] <> '"') then + CheckEquals(StrQuote(s,'"'), '"'+s+'"','StrQuote') + else + if (s[1] = '"') and (s[Length(s)] = '"') then + CheckEquals(StrQuote(s,'"'), s,'StrQuote') + else + if (s[1] <> '"') and (s[Length(s)] = '"') then + CheckEquals(StrQuote(s,'"'), '"'+s,'StrQuote') + else + if (s[1] = '"') and (s[Length(s)] <> '"') then + CheckEquals(StrQuote(s,'"'), s+'"','StrQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +threadvar + removeset: TSysCharSet; + +function RemoveValidator(const C: Char): Boolean; +begin + Result := C in removeset; +end; + +procedure TJclStringTransformation._StrRemoveChars; +var + i, t, v: Integer; + s, s3, sn: string; +begin + // -- StrRemoveChars -- + CheckEquals(StrRemoveChars('',['e']), '', 'StrRemoveChars 1'); + CheckEquals(StrRemoveChars('Test',['e']), 'Tst', 'StrRemoveChars 2'); + + GenerateAll(20,200,StringArray2, True); + GenerateAll(400,200,StringArray, True); + + { Check StrRemoveChars against a self made one using the Pos function } + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := StringArray[i-1]; + sn := StringArray2[i-1]; + removeset := []; + + for t := 1 to Length(sn) do + begin + if not (sn[t] in removeset) then + removeset := removeset + [Char(sn[t])]; + + v := Pos(sn[t], s3); + + while v > 0 do + begin + Delete(s3, v, 1); + v := Pos(sn[t], s3); + end; + end; + + CheckEquals(s3, StrRemoveChars(s, RemoveValidator), 'StrRemoveChars 3'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +threadvar + keepset: TSysCharSet; + +function KeepValidator(const C: Char): Boolean; +begin + Result := C in keepset; +end; + +procedure TJclStringTransformation._StrKeepChars; +var + i, t: Integer; + s, s3, sn: String; + +begin + CheckEquals('', StrKeepChars('',[]), 'StrKeepChars 0'); + CheckEquals('oieaouoeioao', StrKeepChars('Joint Endeavour of Delphi Innovators',['e', 'a', 'o', 'u', 'i']), 'StrKeepChars 1'); + CheckEquals('oi eaou o ei oao', StrKeepChars('Joint Endeavour of Delphi Innovators',[' ', 'e', 'a', 'o', 'u', 'i']), 'StrKeepChars 2'); + + GenerateAll(20,200,StringArray2, True); + GenerateAll(400,200,StringArray, True); + + { Check StrKeepChars against a self made one } + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := ''; + sn := StringArray2[i-1]; + keepset := []; + + for t := 1 to length(sn) do + begin + if not (sn[t] in keepset) then + keepset := keepset + [Char(sn[t])]; + end; + + for t := 1 to length(s) do + begin + if s[t] in keepset then + s3 := s3 + s[t]; + end; + + CheckEquals(s3, StrKeepChars(s, KeepValidator), 'StrKeepChars 3'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplace; +var + s: string; + +begin + // test 1: Replace on an empty string with an empty search string should result in the replace string + s := ''; + StrReplace(s, '', 'Test', []); + CheckEquals('Test', s, 'StrReplace1'); + + // test 2: replace a short string with a longer string + s := 'This is a test.'; + StrReplace(s, 'is a', 'is a successful', []); + CheckEquals('This is a successful test.', s, 'StrReplace 2'); + + // test 3: replace a long string with a shorter string + s := 'This is a successful little test.'; + StrReplace(s, 'successful little', 'successful', []); + CheckEquals('This is a successful test.', s, 'StrReplace 3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplaceChar; +begin + CheckEquals(StrReplaceChar('', 'a', 'b'),'','StrReplaceChar'); + CheckEquals(StrReplaceChar('', #0, #0),'','StrReplaceChar'); + CheckEquals(StrReplaceChar('ababab', 'a', 'b'),'bbbbbb','StrReplaceChar'); + CheckEquals(StrReplaceChar('ababab', 'b', 'a'),'aaaaaa','StrReplaceChar'); + CheckEquals(StrReplaceChar('xabababx', 'b', 'a'),'xaaaaaax','StrReplaceChar'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplaceChars; +begin + CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); + CheckEquals(StrReplaceChars('', ['a'], 'b'),'','StrReplaceChars'); + CheckEquals(StrReplaceChars('ababab', ['a','b'], 'b'),'bbbbbb','StrReplaceChars'); + CheckEquals(StrReplaceChars('xabababx', ['a','b'], 'b'),'xbbbbbbx','StrReplaceChars'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReplacebutChars; +begin + CheckEquals(StrReplaceButChars('', ['a'], 'b'),'','StrReplaceButChars'); + CheckEquals(StrReplaceButChars('xabababx', ['a','b'], 'v'),'vabababv','StrReplaceChars'); + CheckEquals(StrReplaceButChars('TxabababxT', ['a','b'], 'v'),'vvabababvv','StrReplaceChars'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrRepeat; +var + i,t, v: Integer; + s, s3: string; + +begin + CheckEquals(StrRepeat('Test',0) , '', 'StrRepeat'); + CheckEquals(StrRepeat('Test',-1) , '', 'StrRepeat'); + CheckEquals(StrRepeat('Test',-1000) , '', 'StrRepeat'); + CheckEquals(StrRepeat('He',3) , 'HeHeHe', 'StrRepeat'); + CheckEquals(StrRepeat('H e',3) , 'H eH eH e', 'StrRepeat'); + + GenerateAll(50,200,StringArray, True); + + { Check StrRepeat against a self made one } + + RandSeed := 432321; + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + s3 := ''; + v := random(20)+1; + + for t := 1 to v do + s3 := s3 + s; + + CheckEquals(StrRepeat(s,v) ,s3, 'StrRepeat'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrRepeatLength; +begin + CheckEquals(StrRepeatLength('Test',0),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',1),'T','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',2),'Te','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',3),'Tes','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',4),'Test','StrRepeatLength'); + CheckEquals(StrRepeatLength('TestTest',8),'TestTest','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',-1),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('Test',-100),'','StrRepeatLength'); + CheckEquals(StrRepeatLength('',-100),'','StrRepeatLength'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrReverse_StrReverseInPlace; +var + i,t: Integer; + s, s3: string; + +begin + // -- StrReverse / StrReverseInPlace -- + CheckEquals(StrReverse(''), '', 'StrReverse'); + CheckEquals(StrReverse('a'), 'a', 'StrReverse'); + CheckEquals(StrReverse('ab'), 'ba', 'StrReverse'); + CheckEquals(StrReverse('abc'), 'cba', 'StrReverse'); + + { Check StrReverse against a (slow) self made one } + + GenerateAll(100,200,StringArray, True); + + for i := 1 to 200 do + begin + s := StringArray[i-1]; + SetLength(s3, length(s)); + + for t := 1 to length(s) do + s3[t] := s[(length(s) - t) + 1]; + + s := StrReverse(s); + CheckEquals(s, s3, 'StrReverse'); + + s := StringArray[i-1]; + + StrReverseInPlace(s); + CheckEquals(s, s3, 'StrReverse'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSingleQuote; +var + i: Integer; + s: string; + +begin + CheckEquals(StrSingleQuote(''), '''''', 'StrSingleQuote'); + CheckEquals(StrSingleQuote('Project JEDI'), '''Project JEDI''', 'StrSingleQuote'); + + GenerateAll(2000,200,StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + CheckEquals(StrSingleQuote(s),''''+S+'''', 'StrSingleQuote'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrSmartCase; +begin + CheckEquals('', StrSmartCase('', [' ']), 'StrSmartCase1'); + CheckEquals('Project Jedi', StrSmartCase('project jedi', [' ']), 'StrSmartCase2'); + CheckEquals('Project Jedi ', StrSmartCase('project jedi ', [' ']), 'StrSmartCase3'); + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase4'); + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', [' ']), 'StrSmartCase5'); + // test 6: delimiters followed by the same delimiter will not force an upper case on the second delimiter + CheckEquals('XxxxxAx', StrSmartCase('xxxxxAx', [' ','x']), 'StrSmartCase6'); + // test 7: delimiters followed by the another delimiter will not force an upper case on the second delimiter + CheckEquals('Xxx xAx', StrSmartCase('xxx xAx', [' ','x']), 'StrSmartCase7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrStripNonNumberChars; +var + i: Integer; + s: string; + +begin + CheckEquals(StrStripNonNumberChars(''),'','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('123+abcabc+123'),'123++123','StrStripNonNumberChars'); + CheckEquals(StrStripNonNumberChars('abc1234+1234abc'),'1234+1234','StrStripNonNumberChars'); + + GenerateAlpha(200,50,StringArray, True); + + for i := 1 to 50 do + begin + S := StringArray[i-1]; + CheckEquals(StrStripNonNumberChars(s),'', 'StrStripNonNumberChars'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrToHex_Ansi; +var + s, sn: AnsiString; + +begin + CheckEquals(StrToHex(''),'','StrToHex'); + + SN := '262A32543B'; + SetLength(S,20); + HexToBin(PAnsiChar(SN),PAnsiChar(S),20); + CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); + + SN := 'FF2A2B2C2D1A2F'; + HexToBin(PAnsiChar(SN),PAnsiChar(S),20); + CheckEquals(StrToHex(SN),Copy(S,1,Length(SN) div 2),'StrToHex'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharLeft; +var + i,t: Integer; + s, s3, sn: string; +begin + CheckEquals('', StrTrimCharLeft('', #0), 'StrTrimCharLeft1'); + CheckEquals('', StrTrimCharLeft('AAAAAAAAAA', 'A'), 'StrTrimCharLeft2'); + + GenerateAll(200, 2000, StringArray); + GenerateAll(1, 2000, StringArray2); + + for i := 1 to 2000 do + begin + S := StringArray[i-1]; + SN := StringArray2[i-1]; + + while S[1] = SN do + s := '#' + s; + + S3 := S; + t := random(100); + + while t <> 0 do + begin + S3 := SN + S3; + dec(t); + end; + + CheckEquals(S, StrTrimCharLeft(S3,SN[1]), 'StrTrimCharLeft3.' + IntToStr(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +function TrimValidator(const C: Char): Boolean; +begin + Result := (C = 'A') or (C = 'B'); +end; + +procedure TJclStringTransformation._StrTrimCharsLeft; +begin + CheckEquals('', StrTrimCharsLeft('', []), 'empty str, empty array'); + CheckEquals('ABC', StrTrimCharsLeft('ABC', []), 'non-empty str, empty array'); + CheckEquals('BCA', StrTrimCharsLeft('ABCA', ['A']), 'ABCA str, A array'); + CheckEquals('CA', StrTrimCharsLeft('ABCA', ['B', 'A']), 'ABCA str, BA array'); + + CheckEquals('CA', StrTrimCharsLeft('ABCA', TrimValidator), 'ABCA str, AB validator'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharRight; +var + i,t: Integer; + s, sn, s3: string; + +begin + // -- StrTrimCharRight -- + CheckEquals('', StrTrimCharRight('', #0), 'StrTrimCharRight1'); + CheckEquals('', StrTrimCharRight('AAAAAAAAAA', 'A'), 'StrTrimCharRight2'); + + GenerateAll(200, 2000, StringArray); + GenerateAll(1, 2000, StringArray2); + + for i := 1 to 2000 do + begin + S := StringArray[i-1]; + SN := StringArray2[i-1]; + + while S[Length(S)] = SN do + s := s + '#'; + + S3 := S; + t := random(100); + + while t <> 0 do + begin + S3 := S3 + SN; + dec(t); + end; + + CheckEquals(S, StrTrimCharRight(S3, SN[1]), 'StrTrimCharRight3.' + IntToStr(i)); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimCharsRight; +begin + CheckEquals('', StrTrimCharsRight('', []), 'empty str, empty array'); + CheckEquals('ABC', StrTrimCharsRight('ABC', []), 'non-empty str, empty array'); + CheckEquals('ABC', StrTrimCharsRight('ABCA', ['A']), 'ABCA str, A array'); + CheckEquals('AB', StrTrimCharsRight('ABCA', ['C', 'A']), 'ABCA str, CA array'); + + CheckEquals('ABC', StrTrimCharsRight('ABCAABA', TrimValidator), 'ABCAABA str, AB validator'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrTrimQuotes; +var + i: Integer; + s, s3, s4: string; +begin + CheckEquals(StrTrimQuotes(''),'','StrTrimQuotes'); + CheckEquals(StrTrimQuotes('""'),'','StrTrimQuotes'); + CheckEquals(StrTrimQuotes(''''''),'','StrTrimQuotes'); + + CheckEquals(StrTrimQuotes('""TEST""'),'"TEST"','StrTrimQuotes'); + CheckEquals(StrTrimQuotes('''''TEST'''''),'''TEST''','StrTrimQuotes'); + + GenerateAll(200,100,StringArray); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + s3 := StrDoubleQuote(s); + s4 := StrSingleQuote(s); + + CheckEquals(StrTrimQuotes(s3),s,'StrTrimQuotes'); + CheckEquals(StrTrimQuotes(s4),s,'StrTrimQuotes'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringTransformation._StrUpper_StrUpperInPlace_StrUpperBuff; +var + i: Integer; + s4, s, s3: string; + +begin + GenerateAll(200,200,StringArray); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S3 := AnsiUpperCase(s); + S4 := S; + StrUpperInPlace(S4); + CheckEquals(StrUpper(S), S3, 'StrUpper'); + CheckEquals(S4, S3, 'StrUpperInPlace'); + + S4 := S; + StrUpperBuff(PChar(S4)); + CheckEquals(S4, S3, 'StrUpperBuff'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +//================================================================================================== +// String Managment +//================================================================================================== + +procedure TJclStringManagment.StringManagement; +{$IFNDEF SUPPORTS_UNICODE} +{$IFDEF KEEP_DEPRECATED} +var + s1: string; +{$ENDIF KEEP_DEPRECATED} +{$ENDIF !SUPPORTS_UNICODE} + +begin +{$IFNDEF SUPPORTS_UNICODE} +{$IFDEF KEEP_DEPRECATED} + StrAddRef(s1); + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 0,'StrRefCount'); + + s1 := 'test'; + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 2,'StrRefCount'); + + StrAddRef(s1); + StrAddRef(s1); + CheckEquals(StrRefCount(s1), 4,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 3,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 2,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 1,'StrRefCount'); + StrDecRef(s1); + CheckEquals(StrRefCount(s1), 0,'StrRefCount'); +{$ELSE !KEEP_DEPRECATED} + Check(True, 'Ignored because KEEP_DEPRECATED not defined'); +{$ENDIF KEEP_DEPRECATED} +{$ELSE SUPPORT_UNICODE} + Check(True, 'Ignored because SUPPORT_UNICODE is defined'); +{$ENDIF !SUPPORTS_UNICODE} +end; + +//================================================================================================== +// String Search and Replace +//================================================================================================== + +procedure TJclStringSearchandReplace.AddCheck(const s1, s2: string; const res: Integer); +begin + StringArray[fillIdx] := s1; + StringArray2[fillIdx] := s2; + ResultArray[fillIdx] := res; + Inc(fillIdx); +end; + +function TJclStringSearchandReplace.NormalizeCompareResult(res: Integer): Integer; +begin + if res < 0 then + Result := -1 + else + if res > 0 then + Result := 1 + else + Result := 0; +end; + +procedure TJclStringSearchandReplace.TestCompare(idx: Integer; res: Integer; msgFmt: string); +begin + CheckEquals(ResultArray[idx], res, Format('[%d] ' + msgFmt, [idx, QuotedStr(StringArray[idx]), QuotedStr(StringArray2[idx])])); +end; + +procedure TJclStringSearchandReplace._CompareNaturalStr; +var + idx: Integer; + s1: string; + s2: string; +begin + fillIdx := 0; + + // mixed strings, whitespace ignoring for number components only + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi Highlander', 'Delphi 2005', 1); + AddCheck('Delphi Highlander', 'Delphi Highlander', 1); + AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); + AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 1); // case-sensitivity test + + // version/revision numbering schemes + AddCheck('1.2', '1.10', -1); + AddCheck('1.20', '1.3a', 1); + AddCheck('1.1.1', '1.1', 1); + AddCheck('1.1', '1.1a', -1); + AddCheck('1.1.a', '1.1a', -1); + AddCheck('a', '1', 1); + AddCheck('a', 'b', -1); + AddCheck('1', '2', -1); + + // leading zeroes overrule normal number comparisons + AddCheck('0002', '1', -1); + AddCheck('1.5', '1.06', 1); + + // hyphen binds looser than period (technically compares a number against a non-number component) + AddCheck('1-2', '1-1', 1); + AddCheck('1-2', '1.2', -1); + + // handling of positive/negative number comparisons + AddCheck('0', '-5', 1); + AddCheck('-5', '+2', -1); + + for idx := 0 to fillIdx - 1 do + begin + s1 := StringArray[idx]; + s2 := StringArray2[idx]; + TestCompare(idx, NormalizeCompareResult(CompareNaturalStr(s1, s2)), 'CompareNaturalStr(%s, %s)'); + end; +end; + +procedure TJclStringSearchandReplace._CompareNaturalText; +var + idx: Integer; +begin + fillIdx := 0; + + // mixed strings, whitespace ignoring for number components only + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 2005', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi 5', 'Delphi 6', -1); + AddCheck('Delphi Highlander', 'Delphi 2005', 1); + AddCheck('Delphi Highlander', 'Delphi Highlander', 1); + AddCheck('Foobar v0.9.4', 'Foobar v0.10.3', -1); + AddCheck('Foobar v0.9.4', 'Foobar V0.9.4', 0); // case-sensitivity test + + // version/revision numbering schemes + AddCheck('1.2', '1.10', -1); + AddCheck('1.20', '1.3a', 1); + AddCheck('1.1.1', '1.1', 1); + AddCheck('1.1', '1.1a', -1); + AddCheck('1.1.a', '1.1a', -1); + AddCheck('a', '1', 1); + AddCheck('a', 'b', -1); + AddCheck('1', '2', -1); + + // leading zeroes overrule normal number comparisons + AddCheck('0002', '1', -1); + AddCheck('1.5', '1.06', 1); + + // hyphen binds looser than period (technically compares a number against a non-number component) + AddCheck('1-2', '1-1', 1); + AddCheck('1-2', '1.2', -1); + + // handling of positive/negative number comparisons + AddCheck('0', '-5', 1); + AddCheck('-5', '+2', -1); + + for idx := 0 to fillIdx - 1 do + TestCompare(idx, NormalizeCompareResult(CompareNaturalText(StringArray[idx], StringArray2[idx])), 'CompareNaturalText(%s, %s)'); +end; + +procedure TJclStringSearchandReplace._StrCharCount; +var + s: string; + ca, t, i: Integer; + c: char; + +begin + CheckEquals(StrCharCount('','x'),0,'StrCharCount'); + CheckEquals(StrCharCount('Test',#0),0,'StrCharCount'); + CheckEquals(StrCharCount('Test','T'),1,'StrCharCount'); + CheckEquals(StrCharCount('Test','t'),1,'StrCharCount'); + CheckEquals(StrCharCount('TestTT','T'),3,'StrCharCount'); + CheckEquals(StrCharCount('Ttetstt','t'),4,'StrCharCount'); + + GenerateAll(500,100,StringArray, True); + + for i := 1 to 100 do + begin + s := StringArray[i-1]; + + for c := #1 to #255 do + begin + ca := 0; + + for t := 1 to length(s) do + begin + if s[t] = c then + inc(ca); + end; + + CheckEquals(StrCharCount(s,c),ca,'StrCharCount'); + end; + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCharsCount; +begin + CheckEquals(StrCharsCount('',['x']),0,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',[#0]),0,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',['T']),1,'StrCharsCount'); + CheckEquals(StrCharsCount('Test',['t']),1,'StrCharsCount'); + CheckEquals(StrCharsCount('TestTT',['T']),3,'StrCharsCount'); + CheckEquals(StrCharsCount('Ttetstt',['t']),4,'StrCharsCount'); + CheckEquals(StrCharsCount('Ttetstt',['t','T']),5,'StrCharsCount'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrStrCount; +begin + CheckEquals(1, StrStrCount('Test', 'Test'), 'StrStrCount_1'); + CheckEquals(2, StrStrCount('TestTest', 'Test'), 'StrStrCount_2'); + CheckEquals(0, StrStrCount('Test', 'Quark'), 'StrStrCount_3'); + CheckEquals(0, StrStrCount('', 'Quark'), 'StrStrCount_4'); + CheckEquals(0, StrStrCount('', ''), 'StrStrCount_5'); + CheckEquals(0, StrStrCount('Test', ''), 'StrStrCount_6'); + CheckEquals(0, StrStrCount('Test', 'TEST'), 'StrStrCount_7'); // Case sensive ? + CheckEquals(0, StrStrCount('', 'Test'), 'StrStrCount_8'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCompare; +var + i, t: Integer; + S, S1, S2: String; + +begin + CheckEquals(StrCompare('',''),0,'StrCompare'); + CheckEquals(StrCompare('jedi','jedi'),0,'StrCompare'); + CheckEquals(StrCompare('jedi','je'),2,'StrCompare'); + CheckEquals(StrCompare('di','jedi'),-2,'StrCompare'); + CheckEquals(StrCompare('project jedi','jedi'),8,'StrCompare'); + CheckEquals(StrCompare('jedi','judi'),Ord('e') - Ord('u'),'StrCompare'); + CheckEquals(StrCompare('JEDI','Judi'),Ord('e') - Ord('u'),'StrCompare'); + + GenerateAll(600,200,StringArray); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S1 := S; + CheckEquals(StrCompare(S,S1),0,'StrCompare'); + CheckEquals(StrCompare(S,S),0,'StrCompare'); + end; + + GenerateAll(600,1000,StringArray, True); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S1 := StringArray[199+i]; + + if Length(S) = Length(S1) then + S1 := S1 + 'x'; + + CheckEquals(StrCompare(S,S1),Length(S) - Length(S1),'StrCompare'); + CheckEquals(StrCompare(S1,S),Length(S1) - Length(S),'StrCompare'); + end; + + GenerateAll(600,2000,StringArray); + GenerateAll(1,1000,StringArray2); + + for i := 1 to 200 do + begin + S := StringArray[i-1]; + S2 := S; + + S1 := StringArray[i]; + t := random(Length(S)); + + while s1 = S[1 + t] do + t := random(Length(S)); + + S[1+t] := Char(s1[1]); + CheckEquals(StrCompare(S2,S), ord(CharLower(S2[1+t])) - ord(CharLower(S[1+t])) ,'StrCompare'); + CheckEquals(StrCompare(S,S2), ord(CharLower(S[1+t])) - ord(CharLower(S2[1+t])) ,'StrCompare'); + end; +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrCompareRange; +begin + CheckEquals(0, StrCompareRange('', '', 1, 0), 'StrCompareRange1'); + CheckEquals(0, StrCompareRange('Test1234', 'Test', 1, 4), 'StrCompareRange5'); + CheckEquals(0, StrCompareRange('Test1234', 'Test1234', 1, 25), 'StrCompareRange6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrFillChar; + + procedure TestCombo(ch: Char; res: string); + var + s: array[0..79] of Char; + str: string; + begin + StrFillChar(s, Length(res), ch); + s[Length(res)] := #0; + str := s; + CheckEquals(res, s, 'StrFillChar ' + IntToStr(Length(res)) + '*' + ch); + end; + +begin + TestCombo('a', ''); + TestCombo('a', 'a'); + TestCombo('a', 'aa'); + TestCombo('b', 'bbbb'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrFind; +begin + CheckEquals(0, StrFind('abc', 'Test'), 'StrFind_1'); + CheckEquals(1, StrFind('Test', 'Test'), 'StrFind_2'); + CheckEquals(1, StrFind('Test', 'test'), 'StrFind_3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrHasPrefix; +begin + CheckEquals(False, StrHasPrefix('', []), 'StrHasPrefix1'); + CheckEquals(False, StrHasPrefix('', ['TEST']), 'StrHasPrefix2'); + CheckEquals(False, StrHasPrefix('', ['TEST', 'TEST2']), 'StrHasPrefix3'); + CheckEquals(False, StrHasPrefix('Test', ['TEST', 'TEST2']), 'StrHasPrefix4'); + CheckEquals(True, StrHasPrefix('Test2', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix5'); + CheckEquals(True, StrHasPrefix('Test12345', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix6'); + CheckEquals(True, StrHasPrefix('Test21234', ['TEST', 'TEST2', 'Test']), 'StrHasPrefix7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIHasPrefix; +begin + CheckEquals(False, StrIHasPrefix('', []), 'StrIHasPrefix1'); + CheckEquals(False, StrIHasPrefix('', ['TEST']), 'StrIHasPrefix2'); + CheckEquals(False, StrIHasPrefix('', ['TEST', 'TEST2']), 'StrIHasPrefix3'); + CheckEquals(True, StrIHasPrefix('Test', ['TEST', 'TEST2']), 'StrIHasPrefix4'); + CheckEquals(True, StrIHasPrefix('Test2', ['TEST', 'TEST2']), 'StrIHasPrefix5'); + CheckEquals(True, StrIHasPrefix('Test12345', ['TEST', 'TEST2']), 'StrIHasPrefix6'); + CheckEquals(True, StrIHasPrefix('Test21234', ['TEST', 'TEST2']), 'StrIHasPrefix7'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIndex; +begin + CheckEquals(-1, StrIndex('', ['A', 'B']), 'Empty string in array of AB'); + CheckEquals(-1, StrIndex('A', []), '''A'' string in empty array'); + CheckEquals(0, StrIndex('A', ['A', 'B']), '''A'' string in array of AB, equal case'); + CheckEquals(0, StrIndex('a', ['A', 'B']), '''A'' string in array of AB, differing case'); + CheckEquals(1, StrIndex('B', ['A', 'B']), '''B'' string in array of AB, equal case'); + CheckEquals(2, StrIndex('C', ['A', 'B', 'C', 'C']), '''C'' string in array of ABCC, equal case'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrILastPos; +begin + CheckEquals(10, StrILastPos('A', 'aaaaaaaaaa'), 'StrILastPos_1'); + CheckEquals(16, StrILastPos('abA', 'aabaaababababababa'), 'StrILastPos_2'); + CheckEquals(8, StrILastPos('abbA', 'abbaabbabba'), 'StrILastPos_3'); + CheckEquals(0, StrILastPos('_abba', 'abbaabbabba'), 'StrILastPos_4'); + CheckEquals(5, StrILastPos('_aBBa', 'abba_abbabba'), 'StrILastPos_5'); + CheckEquals(15, StrILastPos('ABA', 'aabaaaABAbabababa'), 'StrILastPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIPos; +begin + CheckEquals(1, StrIPos('A', 'aaaaaaaaaa'), 'StrIPos_1'); + CheckEquals(2, StrIPos('abA', 'aabaaababababababa'), 'StrIPos_2'); + CheckEquals(1, StrIPos('abbA', 'abbaabbabba'), 'StrIPos_3'); + CheckEquals(0, StrIPos('_abba', 'abbaabbabba'), 'StrIPos_4'); + CheckEquals(5, StrIPos('_aBBa', 'abba_abbabba'), 'StrIPos_5'); + CheckEquals(2, StrIPos('ABA', 'aabaaaABAbabababa'), 'StrIPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIPrefixIndex; +begin + CheckEquals(0, StrIPrefixIndex('Project',['Pro']), 'StrIPrefixIndex1'); + CheckEquals(0, StrIPrefixIndex('Project',['Pro','Con']), 'StrIPrefixIndex2'); + CheckEquals(0, StrIPrefixIndex('Project',['']), 'StrIPrefixIndex3'); + CheckEquals(1, StrIPrefixIndex('Project',['Con','Pro']), 'StrIPrefixIndex4'); + CheckEquals(1, StrIPrefixIndex('Project',['Con','PRO']), 'StrIPrefixIndex5'); + CheckEquals(-1, StrIPrefixIndex('Project',['Con','PRA']), 'StrIPrefixIndex5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrIsOneOf; +begin + CheckEquals(True, StrIsOneOf('Test', ['a','atest','Test', 'Fest']), 'StrIsOneOf_1'); + CheckEquals(False, StrIsOneOf('Test', ['a','atest', 'Fest']), 'StrIsOneOf_2'); + CheckEquals(False, StrIsOneOf('', ['a','atest', 'Fest']), 'StrIsOneOf_3'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrLastPos; +begin + CheckEquals(10, StrLastPos('a', 'aaaaaaaaaa'), 'StrLastPos_1'); + CheckEquals(16, StrLastPos('aba', 'aabaaababababababa'), 'StrLastPos_2'); + CheckEquals(8, StrLastPos('abba', 'abbaabbabba'), 'StrLastPos_3'); + CheckEquals(0, StrLastPos('_abba', 'abbaabbabba'), 'StrLastPos_4'); + CheckEquals(5, StrLastPos('_abba', 'abba_abbabba'), 'StrLastPos_5'); + CheckEquals(7, StrLastPos('ABA', 'aabaaaABAbabababa'), 'StrLastPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrMatch; +begin + CheckEquals(0, StrMatch('', 'Test', 1), 'StrMatch_1'); + CheckEquals(1, StrMatch('Test', 'Test', 1), 'StrMatch_2'); + CheckEquals(2, StrMatch('Test', 'aTest', 1), 'StrMatch_3'); + CheckEquals(3, StrMatch('Test', 'abTest', 1), 'StrMatch_4'); + CheckEquals(4, StrMatch('Test', 'abcTest', 1), 'StrMatch_5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrNPos; +begin + CheckEquals(0, StrNPos('testtesttest','Test',3)); // case sensitive test + CheckEquals(9, StrNPos('TestTestTest','Test',3)); + + CheckEquals(1, StrNPos('Test','Test',1), 'StrNPos_1'); + CheckEquals(0, StrNPos('Test','Test',0), 'StrNPos_2'); + CheckEquals(0, StrNPos('Test','Test',-1), 'StrNPos_3'); + CheckEquals(5, StrNPos('TestTest','Test',2), 'StrNPos_4'); + CheckEquals(0, StrNPos('Testtest','Test',2), 'StrNPos_5'); + CheckEquals(3, StrNPos('__Test__','Test',1), 'StrNPos_6'); + CheckEquals(9, StrNPos('__Test__Test','Test',2), 'StrNPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrMatches; +begin + //CheckEquals(False, StrMatches('','Test',1), 'StrMatches_1'); + CheckEquals(True, StrMatches('Test','Test',1), 'StrMatches_2'); + CheckEquals(True, StrMatches('Test','aTest',2), 'StrMatches_3'); + CheckEquals(False, StrMatches('Test','abTest',1), 'StrMatches_4'); + CheckEquals(False, StrMatches('Test','abcTest',1), 'StrMatches_5'); + CheckEquals(True, StrMatches('T?st', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T??t', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T*', 'Test'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T*st', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T*st', 'Tett'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T???', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T???', 'Tes'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T?*', 'Test'), 'StrMatches_6'); + CheckEquals(False, StrMatches('T?*', 'T'), 'StrMatches_6'); + CheckEquals(True, StrMatches('T?s?', 'Test'), 'StrMatches_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrNIPos; +begin + CheckEquals(5, StrNIPos('aaaaaaaaaa', 'A', 5), 'StrNIPos_1'); + CheckEquals(0, StrNIPos('aabaaababababababa', 'abA', 0), 'StrNIPos_2'); + CheckEquals(0, StrNIPos('abbaabbabba', 'abbA', 4), 'StrNIPos_3'); + CheckEquals(8, StrNIPos('abbaabbabba', 'abba', 3), 'StrNIPos_4'); + CheckEquals(5, StrNIPos('abba_abbabba', '_aBBa', 1), 'StrNIPos_5'); + CheckEquals(11, StrNIPos('aabaaaABAbabababa', 'ABA', 4), 'StrNIPos_6'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrPrefixIndex; +begin + CheckEquals(0, StrPrefixIndex('Project',['Pro']), 'StrPrefixIndex1'); + CheckEquals(0, StrPrefixIndex('Project',['Pro','Con']), 'StrPrefixIndex2'); + CheckEquals(0, StrPrefixIndex('Project',['']), 'StrPrefixIndex3'); + CheckEquals(1, StrPrefixIndex('Project',['Con','Pro']), 'StrPrefixIndex4'); + CheckEquals(-1, StrPrefixIndex('Project',['Con','PRO']), 'StrPrefixIndex5'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringSearchandReplace._StrSearch; +begin + CheckEquals(StrSearch('', '', 1), 0, 'StrSearch_1'); + CheckEquals(StrSearch('Test', 'Test', 1), 1, 'StrSearch_2'); + CheckEquals(StrSearch('Test', 'Test12', 1), 1, 'StrSearch_3'); + CheckEquals(StrSearch('Test', 'Test123', 1), 1, 'StrSearch_4'); + CheckEquals(StrSearch('Test', 'abTest123', 1), 3, 'StrSearch_5'); + CheckEquals(StrSearch('Test', 'abTest123', 3), 3, 'StrSearch_6'); + CheckEquals(StrSearch('Test', 'abTaest123', 3), 0, 'StrSearch_7'); + CheckEquals(StrSearch('Test', 'abT', 4), 0, 'StrSearch_8'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharEqualNoCase; +var + c1, c2: char; + +begin + for c1 := #0 to #255 do + for c2 := #0 to #255 do + Check(CharEqualNoCase(c1,c2) = (AnsiUpperCase(C1) = AnsiUpperCase(C2)),Format('CharEqualNoCase: C1: %s C2: %s',[c1,c2])); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsAlpha; +var + C: char; +begin + for C := #0 to #255 do + CheckEquals( + isalpha(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #181, #186, #192 .. #214, + #216 .. #246, #248 .. #255]), + CharIsAlpha(C), + 'CharIsAlpha #' + IntToStr(Ord(C))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsAlphaNum; +var + C: char; +begin + for C := #0 to #255 do + CheckEquals( + isalnum(Ord(C)) or (C in [#131, #138, #140, #142, #154, #156, #158, #159, #170, #178, #179, #181, #185, #186, + #192 .. #214, #216 .. #246, #248 .. #255]), + CharIsAlphaNum(C) , + 'CharIsAlphaNum #' + IntToStr(Ord(C))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsBlank; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#9, ' ', #160]), + CharIsBlank(c1), + 'CharIsBlank #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsControl; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), + CharIsControl(c1), + 'CharIsControl #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsDelete; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals((ord(c1) = 8), CharIsDelete(c1), 'CharIsDelete #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsDigit; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['0'..'9', #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), + CharIsDigit(c1), + 'CharIsDigit #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsNumberChar; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['0'..'9', '+', '-', DecimalSeparator, #178 { power of 2 }, #179 {power of 3}, #185 {power of 1}]), + CharIsNumberChar(c1), + 'CharIsNumberChar #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsPrintable; +var + c1: char; + +begin + for c1 := #0 to #255 do + CheckEquals( + not (c1 in [#0 .. #31, #127, #129, #141, #143, #144, #157]), + CharIsPrintable(c1), + 'CharIsPrintable #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsPunctuation; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [#123..#126, #130, #132 .. #135, #137, #139, #145 .. #151, #155, #161 .. #191, #215, #247, + #91..#96, #38..#47, '@', #60..#63, '#','$','%','"','.',',','!',':','=',';']), + CharIsPunctuation(c1), + 'CharIsPunctuation #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsReturn; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals(((c1 = #13) or (c1 = #10)), CharIsReturn(c1), 'CharIsReturn #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsSpace; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + c1 in [#9, #10, #11, #12, #13, ' ', #160], + CharIsSpace(c1), + 'CharIsSpace #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsWhiteSpace; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in [NativeTab, NativeLineFeed, NativeVerticalTab, NativeFormFeed, NativeCarriageReturn, NativeSpace]), + CharIsWhiteSpace(c1), + 'CharIsWhiteSpace #' + IntToStr(Ord(c1)) + ); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsUpper; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['A'..'Z', #138, #140, #142, #159, #192 .. #214, #216 .. #222]), + CharIsUpper(c1), + 'CharIsUpper #' + IntToStr(Ord(c1))); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringCharacterTestRoutines._CharIsLower; +var + c1: char; +begin + for c1 := #0 to #255 do + CheckEquals( + (c1 in ['a' .. 'z', #131, #154, #156, #158, #170, #181, #186, #223 .. #246, #248 .. #255]), + CharIsLower(c1), + 'CharIsLower #' + IntToStr(Ord(c1))); +end; + + +//================================================================================================== +// String Extraction +//================================================================================================== + +procedure TJclStringExtraction._StrAfter; +begin + CheckEquals(StrAfter('',''),'','StrAfter'); + CheckEquals(StrAfter('Hello', 'Hello World'),' World','StrAfter'); + CheckEquals(StrAfter('Hello ', 'Hello World'),'World','StrAfter'); + CheckEquals(StrAfter('is a ', 'This is a test.'),'test.','StrAfter'); + CheckEquals(StrAfter('is a ', 'This is a test. is a test'),'test. is a test','StrAfter'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrBefore; +begin + CheckEquals(StrBefore('',''),'','StrBefore'); + CheckEquals(StrBefore('World', 'Hello World'),'Hello ','StrBefore'); + CheckEquals(StrBefore('Hello ', 'Hello World'),'','StrBefore'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrBetween; +begin + CheckEquals('', StrBetween('', Char(#0), Char(#0)), 'StrBetween1'); + CheckEquals('', StrBetween('', Char(#0), Char(#1)), 'StrBetween2'); + CheckEquals('Test', StrBetween('aTestb', Char('a'), Char('b')), 'StrBetween3'); + CheckEquals('Test', StrBetween(' Test ', Char(' '), Char(' ')), 'StrBetween4'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrChopRight; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrChopRight('',i),'','StrChopRight'); + + CheckEquals(StrChopRight('Project JEDI',1),'Project JED','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',2),'Project JE','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',3),'Project J','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',4),'Project ','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',5),'Project','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',15),'','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',50),'','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',-5),'Project JEDI','StrChopRight'); + CheckEquals(StrChopRight('Project JEDI',-50),'Project JEDI','StrChopRight'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrLeft; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrLeft('',i),'','StrLeft'); + + CheckEquals(StrLeft('Project JEDI',0),'','StrLeft'); + CheckEquals(StrLeft('Project JEDI',1),'P','StrLeft'); + CheckEquals(StrLeft('Project JEDI',3),'Pro','StrLeft'); + CheckEquals(StrLeft('Project JEDI',5),'Proje','StrLeft'); + CheckEquals(StrLeft('Project JEDI',-5),'','StrLeft'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrMid; +begin + CheckEquals(StrMid('Test',1,4),'Test','StrLeft'); + CheckEquals(StrMid('Test',1,3),'Tes','StrLeft'); + CheckEquals(StrMid('Test',1,2),'Te','StrLeft'); + CheckEquals(StrMid('Test',1,1),'T','StrLeft'); + CheckEquals(StrMid('Test',1,-1),'','StrLeft'); + CheckEquals(StrMid('Test',1,0),'','StrLeft'); + CheckEquals(StrMid('Test',2,0),'','StrLeft'); + CheckEquals(StrMid('Test',2,4),'est','StrLeft'); + CheckEquals(StrMid('Test',2,3),'est','StrLeft'); + CheckEquals(StrMid('Test',2,2),'es','StrLeft'); + CheckEquals(StrMid('Test',2,1),'e','StrLeft'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrRight; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrRight('',i),'','StrRight'); + + CheckEquals(StrRight('Test',1),'t','StrRight'); + CheckEquals(StrRight('Test',2),'st','StrRight'); + CheckEquals(StrRight('Test',3),'est','StrRight'); + CheckEquals(StrRight('Test',4),'Test','StrRight'); + CheckEquals(StrRight('Test',8),'Test','StrRight'); + CheckEquals(StrRight('Test',-8),'','StrRight'); +end; + +//-------------------------------------------------------------------------------------------------- + +procedure TJclStringExtraction._StrRestOf; +var + i: Integer; + +begin + for i := -10 to 10 do + CheckEquals(StrRestOf('',i),'','StrRestOf'); + + for i := -100 to -1 do + CheckEquals(StrRestOf('Test',i),'Test','StrRestOf'); + + CheckEquals(StrRestOf('Test',1),'Test','StrRestOf'); + CheckEquals(StrRestOf('Test',2),'est','StrRestOf'); + CheckEquals(StrRestOf('Test',3),'st','StrRestOf'); +end; + +//-------------------------------------------------------------------------------------------------- + +(* +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.CharacterTransformationRoutines; +var + i,t : integer; + c1, c2: char; + charhextable: array[0..255] of byte; + +begin + // -- CharHex -- + for i:=0 to 255 do + charhextable[i] := $FF; + + for i := ord('0') to ord('9') do + charhextable[i] := i - ord('0'); + + for i := ord('a') to ord('f') do + charhextable[i] := 10 + i - ord('a'); + + for i := ord('A') to ord('F') do + charhextable[i] := 10 + i - ord('A'); + + for c1 := #0 to #255 do + CheckEquals(CharHex(c1) , charhextable[ord(c1)], 'CharHex'); + + // -- CharLower -- + for c1 := 'A' to 'Z' do + CheckEquals(CharLower(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharLower %s (%d)',[string(c1),ord(c1)])); + + // -- CharUpper -- + for c1 := 'a' to 'z' do + CheckEquals(CharUpper(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharUpper %s (%d)',[string(c1),ord(c1)])); + + // -- CharToggleCase -- + for c1 := 'a' to 'z' do + CheckEquals(CharToggleCase(c1) , chr(ord('A') + ord(c1) - ord('a')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); + + for c1 := 'A' to 'Z' do + CheckEquals(CharToggleCase(c1) , chr(ord('a') + ord(c1) - ord('A')), Format('CharToggleCase %s (%d)',[string(c1),ord(c1)])); +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.CharacterSearchandReplace; +var + s: string; + Strings: TStringList; + c, c1, c2: char; + index, i, r: Integer; + +begin + Strings := TStringList.Create; + try + Strings.LoadFromFile('Data/charpos.dat'); + + i := 0; + + while i < Strings.Count do + begin + s := Strings.Strings[i]; + c := (Strings.Strings[i+1])[1]; + index := strtoint(Strings.Strings[i+2]); + r := CharPos(s, c, index); + Check(r = strtoint(Strings.Strings[i+3]),Format('CharPos %s %s %d %d ',[s,c,index, r])); + r := CharIPos(s, c, index); + Check(r = strtoint(Strings.Strings[i+4]),Format('CharIPos %s',[s])); + inc(i,5); + end; + + c := #0; + r := CharIPos('',c); + CheckEquals(r , 0,'CharIPos'); + r := CharPos('',c); + CheckEquals(r , 0,'CharPos'); + + // -- CharReplace -- + + Strings.LoadFromFile('Data/charreplace.dat'); + + i := 0; + + while i < Strings.Count - 1 do + begin + s := Strings.Strings[i]; + c1 := (Strings.Strings[i+1])[1]; + c2 := (Strings.Strings[i+2])[1]; + r := strtoint(Strings.Strings[i+3]); + CheckEquals(CharReplace(s,c1,c2), r , 'CharReplace'); + CheckEquals(s, Strings.Strings[i+4] , 'CharReplace'); + inc(i,5); + end; + + SetLength(s,0); + CheckEquals(CharReplace(s,#0,#0) , 0,'CharReplace'); + + finally + Strings.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.PCharVectorRoutines; +var + Strings: TStringList; + Strings2: TStringList; + Vector: PCharVector; + i: Integer; + +begin + // -- StringsToPCharVector -- + Strings := TStringList.Create; + try + Strings2 := TStringList.Create; + + try + for i := 1 to 1000 do + begin + Strings.Add(inttostr(i)) + end; + + StringsToPCharVector(Vector, Strings); + + // -- PCharVectorCount -- + CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); + CheckEquals(PCharVectorCount(Vector),1000,'PCharVectorCount'); + + for i := 1001 to 1500 do + begin + Strings.Add(inttostr(i)) + end; + + StringsToPCharVector(Vector, Strings); + + // -- PCharVectorCount -- + CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); + CheckEquals(PCharVectorCount(Vector),1500,'PCharVectorCount'); + + // -- PCharVectorToStrings -- + PCharVectorToStrings(Strings2, Vector); + + for i := 0 to 1499 do + begin + CheckEquals(Strings.Strings[i],Strings2.Strings[i],'PCharVectorToStrings'); + end; + + // -- FreePCharVector -- + FreePCharVector(Vector); + CheckEquals(Integer(Vector),0,'FreePCharVector'); + finally + Strings2.Free; + end; + + finally + Strings.Free; + end; + +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.MultiSzRoutines; +var + msz: PChar; + g: TStringList; + nb: Integer; + mszo: PChar; + s: string; + +begin + g := TStringList.Create; + try + g.Add('Project'); + g.Add('JEDI'); + g.Add('RULES!'); + + StringsToMultiSz(Msz, g); + + // Check it in memory + s := 'Project' + #0 + 'JEDI' + #0 + 'RULES!' + #0 + #0; + MsZo := PChar(s); + + CheckEquals(CompareMem(Msz, MszO, 21), True, 'StringsToMultiSz'); + + FreeMultiSz(Msz); + finally + g.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.TStringsManipulation; +var + source, dest: TStringList; + +begin + // -- StrToStrings -- + + // -- StringsToStr -- + + // -- TrimStrings -- + + // -- TrimStringsRight -- + + // -- TrimStringsLeft -- +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringsTest.Miscellaneous; +var + S: String; + B: Boolean; + SL: TStringList; + +begin + // -- BooleanToStr -- + B := True; + CheckEquals(BooleanToStr(B) , 'True', 'BooleanToStr(TRUE)'); + CheckEquals(BooleanToStr(not B) , 'False', 'BooleanToStr(FALSE)'); + + // -- FileToString -- + // -- StringToFile -- + + // -- StrToken -- + S := 'Test1;Test2'; + CheckEquals(StrToken(s,';'),'Test1','StrToken'); + CheckEquals(S,'Test2','StrToken'); + + S := ';Test'; + CheckEquals(StrToken(s,';'),'','StrToken'); + CheckEquals(S,'Test','StrToken'); + + S := ';;Test'; + CheckEquals(StrToken(s,';'),'','StrToken'); + CheckEquals(S,';Test','StrToken'); + + // -- StrTokens -- + // -- StrTokenToStrings -- + SL := TStringList.Create; + + S := 'Test1;Test2;Test3;Test4'; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Strings[0],'Test1','StrToken'); + CheckEquals(SL.Strings[1],'Test2','StrToken'); + CheckEquals(SL.Strings[2],'Test3','StrToken'); + CheckEquals(SL.Strings[3],'Test4','StrToken'); + CheckEquals(SL.Count, 4,'StrTokenToStrings'); + + SL.Clear; + S := 'Test1;;Test3;Test4'; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Strings[0],'Test1','StrTokenToStrings'); + CheckEquals(SL.Strings[1],'','StrTokenToStrings'); + CheckEquals(SL.Strings[2],'Test3','StrTokenToStrings'); + CheckEquals(SL.Strings[3],'Test4','StrTokenToStrings'); + CheckEquals(SL.Count, 4,'StrTokenToStrings'); + + SL.Clear; + S := ''; + StrTokenToStrings(S,';',SL); + CheckEquals(SL.Count, 0,'StrTokenToStrings'); + SL.Free; + + // -- StrWord -- + // -- StrToFloatSafe -- + // -- StrToIntSafe -- +end; + +*) + +//================================================================================================== +// TabSet +//================================================================================================== + +procedure TJclStringTabSet._CalculatedTabWidth; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; +begin + tabs1 := TJclTabSet.Create([4,8], True); + try + CheckEquals(0, tabs1.TabWidth, 'tabs1.TabWidth'); + CheckEquals(4, tabs1.ActualTabWidth, 'tabs1.ActualTabWidth'); + finally + FreeAndNil(tabs1); + end; + + tabs2 := TJclTabSet.Create([4,7], False, -1); + try + CheckEquals(-1, tabs2.TabWidth, 'tabs2.TabWidth'); + CheckEquals(3, tabs2.ActualTabWidth, 'tabs2.ActualTabWidth'); + finally + FreeAndNil(tabs2); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Clone; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; + + procedure NilClone; + begin + tabs1 := nil; + tabs2 := tabs1.Clone; + try + CheckTrue(tabs2 = nil, 'NilClone: tabs2 = nil'); + finally + FreeAndNil(tabs2); + end; + end; + + procedure NormalClone; + begin + tabs1 := TJclTabSet.Create([4, 8], False, 2); + try + tabs2 := tabs1.Clone; + try + CheckTrue(tabs1 <> tabs2, 'NormalClone: tabs1 <> tabs2'); + CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalClone: .TabWidth'); + CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalClone: .ActualTabWidth'); + CheckEquals(tabs1.Count, tabs2.Count, 'NormalClone: .Count'); + CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalClone: .TabStops[0]'); + CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalClone: .TabStops[1]'); + + // changing values in one reference should not influence the other reference + tabs1.TabWidth := 3; + CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); + + // freeing the first instance should leave the second instance working + FreeAndNil(tabs1); + CheckEquals(2, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); + finally + FreeAndNil(tabs2); + end; + finally + FreeAndNil(tabs1); + end; + end; + +begin + NilClone; + NormalClone; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Expand; +var + tabs: TJclTabSet; + inp: string; + exp: string; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + inp := 'Test:'#9'LD'#9'A,(HL)'#9'; Read from memory'#13#10+ + #9'LD'#9'B, 100'#13#10 + + #9'CALL'#9'Test2'#13#10+ + #9#9#9'; another comment'; + exp := 'Test: LD A,(HL) ; Read from memory'#13#10 + + ' LD B, 100'#13#10 + + ' CALL Test2'#13#10+ + ' ; another comment'; + CheckEqualsString(exp, tabs.Expand(inp)); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._FromString; +var + tabs: TJclTabSet; +begin + // just a tab width + tabs := TJclTabSet.FromString('+4'); + try + CheckEquals(0, tabs.Count, 'FromString(''+4'').Count'); + CheckEquals(False, tabs.ZeroBased, 'FromString(''+4'').ZeroBased'); + CheckEquals(4, tabs.ActualTabWidth, 'FromString(''+4'').ActualTabWidth'); + CheckEquals(4, tabs.TabWidth, 'FromString(''+4'').TabWidth'); + finally + FreeAndNil(tabs); + end; + + // stops and tab width; with excessive whitespace, including tab + tabs := TJclTabSet.FromString('4, 7 ' + #9 + '+4'); + try + CheckEquals(2, tabs.Count, 'FromString(''4, 7 '' + #9 + ''+4'').Count'); + CheckEquals(4, tabs[0], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[0]'); + CheckEquals(7, tabs[1], 'FromString(''4, 7 '' + #9 + ''+4'').tabs[1]'); + CheckEquals(False, tabs.ZeroBased, 'FromString(''4, 7 '' + #9 + ''+4'').ZeroBased'); + CheckEquals(4, tabs.ActualTabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').ActualTabWidth'); + CheckEquals(4, tabs.TabWidth, 'FromString(''4, 7 '' + #9 + ''+4'').TabWidth'); + finally + FreeAndNil(tabs); + end; + + // zero-based, bracketed stops, auto width + tabs := TJclTabSet.FromString('0[4,7]'); + try + CheckEquals(2, tabs.Count, 'FromString(''0[4,7]'').Count'); + CheckEquals(4, tabs[0], 'FromString(''0[4,7]'').tabs[0]'); + CheckEquals(7, tabs[1], 'FromString(''0[4,7]'').tabs[1]'); + CheckEquals(True, tabs.ZeroBased, 'FromString(''0[4,7]'').ZeroBased'); + CheckEquals(3, tabs.ActualTabWidth, 'FromString(''0[4,7]'').ActualTabWidth'); + CheckTrue(tabs.TabWidth < 1, 'FromString(''0[4,7]'').TabWidth'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._NilSet; +var + tabs: TJclTabSet; +begin + // simplify nil tabset access + tabs := nil; + + // nil tabset should be zero based + CheckTrue(tabs.ZeroBased, 'Nil tabset.ZeroBased'); + + // nil tabset should have no tab stops + CheckEquals(0, tabs.Count, 'Nil tabset.Count'); + + // nil tabset should have an actual tabwidth of 2 + CheckEquals(2, tabs.ActualTabWidth, 'Nil tabset.ActualTabWidth'); + + // nil tabset should have a set tabwidth of <1 or 2 + CheckTrue((tabs.TabWidth = 2) or (tabs.TabWidth < 1), 'Nil tabset.TabWidth'); + + // nil tabset expand test + CheckEquals('A bc de', tabs.Expand('A'#9'bc'#9'de'), 'Nil tabset.Expand') +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._OptimalFill; +var + tabs: TJclTabSet; + tabCount: Integer; + spaceCount: Integer; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + // test 1: tabs and spaces to get from column 1 to column 17 + tabs.OptimalFillInfo(1, 17, tabCount, spaceCount); + CheckEquals(1, tabCount, 'tabCount for column 1->17'); + CheckEquals(0, spaceCount, 'spaceCount for column 1->17'); + + // test 2: tabs and spaces to get from column 1 to column 4 + tabs.OptimalFillInfo(1, 4, tabCount, spaceCount); + CheckEquals(0, tabCount, 'tabCount for column 1->4'); + CheckEquals(3, spaceCount, 'spaceCount for column 1->4'); + + // test 3: tabs and spaces to get from column 1 to column 34 + tabs.OptimalFillInfo(1, 34, tabCount, spaceCount); + CheckEquals(3, tabCount, 'tabCount for column 1->34'); + CheckEquals(2, spaceCount, 'spaceCount for column 1->34'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Optimize; +var + tabs: TJclTabSet; + inp: string; + exp: string; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + inp := ' '#9' test second'; + exp := #9' test'#9#9#9#9#9' second'; + CheckEquals(exp, tabs.Optimize(inp)); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._Referencing; +var + tabs1: TJclTabSet; + tabs2: TJclTabSet; + + procedure NilReference; + begin + tabs1 := nil; + tabs2 := tabs1.NewReference; + try + CheckTrue(tabs2 = nil, 'NilReference: tabs2 = nil'); + finally + FreeAndNil(tabs2); + end; + end; + + procedure NormalReference; + begin + tabs1 := TJclTabSet.Create([4, 8], False, 2); + try + tabs2 := tabs1.NewReference; + try + CheckTrue(tabs1 <> tabs2, 'NormalReference: tabs1 <> tabs2'); + CheckEquals(tabs1.TabWidth, tabs2.TabWidth, 'NormalReference: .TabWidth'); + CheckEquals(tabs1.ActualTabWidth, tabs2.ActualTabWidth, 'NormalReference: .ActualTabWidth'); + CheckEquals(tabs1.Count, tabs2.Count, 'NormalReference: .Count'); + CheckEquals(tabs1.TabStops[0], tabs2.TabStops[0], 'NormalReference: .TabStops[0]'); + CheckEquals(tabs1.TabStops[1], tabs2.TabStops[1], 'NormalReference: .TabStops[1]'); + + // changing values in one reference should also occur in the other reference + tabs1.TabWidth := 3; + CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth changed'); + + // freeing the first instance should leave the second instance working + FreeAndNil(tabs1); + CheckEquals(3, tabs2.TabWidth, 'NormalReference: .TabWidth after freeing instance 1'); + finally + FreeAndNil(tabs2); + end; + finally + FreeAndNil(tabs1); + end; + end; + +begin + NilReference; + NormalReference; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabFrom; +var + tabs: TJclTabSet; + idx: Integer; +begin + tabs := TJclTabSet.Create([15, 20, 30], True, 2); + try + // test first fixed stop + // columns 0 through 14 will tab to column 15 + for idx := 0 to 14 do + CheckEquals(15, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test second fixed stop + // columns 15 through 19 will tab to column 20 + for idx := 15 to 19 do + CheckEquals(20, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test third and final fixed stop + // columns 20 through 29 will tab to column 30 + for idx := 20 to 29 do + CheckEquals(30, tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + + // test tab width beyond fixed positions + // columns 30 through 39 will tab to column 32 (30-31), 34 (32-33), 36 (34-35), 38 (36-37) or 40 (38-39) + for idx := 30 to 39 do + CheckEquals(2 * Succ(idx div 2), tabs.TabFrom(idx), 'set=[15,20,30]+2; TabFrom(' + IntToStr(idx) + ')'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopAdding; +var + tabs: TJclTabSet; + x: Integer; + failed: Boolean; +begin + tabs := TJclTabSet.Create([15, 30], True); + try + // Add column 20 and check if the index=1 + CheckEquals(1, tabs.Add(20), 'Index of Add(20)'); + // We should have three stops + CheckEquals(3, tabs.Count, 'Count after Add(20)'); + // The first should be 15 + CheckEquals(15, tabs[0], 'tabs[0]'); + // The second should be 20 + CheckEquals(20, tabs[1], 'tabs[1]'); + // The third should be 30 + CheckEquals(30, tabs[2], 'tabs[2]'); + // Adding a duplicate should fail... + begin + try + x := tabs.Add(30); + failed := True; + except + failed := False; + x := 0; // make compiler happy + end; + if failed then + Fail('tabs.Add(30) returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); + end; + // Adding anything less than StartColumn should fail... + begin + try + x := tabs.Add(tabs.StartColumn - 1); + failed := True; + except + failed := False; + x := 0; + end; + if failed then + Fail('tabs.Add(' + IntToStr(tabs.StartColumn - 1) + ') returned ' + IntToStr(x) + '; should''ve resulted in an exception.'); + end; + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopDeleting; +var + tabs: TJclTabSet; + x: Integer; +begin + tabs := TJclTabSet.Create([15, 17, 20, 30], True, 2); + try + CheckEquals(1, tabs.Delete(17), 'Index of Delete(17)'); + // We should have three stops + CheckEquals(3, tabs.Count, 'Count after Add(20)'); + // The first should be 15 + CheckEquals(15, tabs[0], 'tabs[0]'); + // The second should be 20 + CheckEquals(20, tabs[1], 'tabs[1]'); + // The third should be 30 + CheckEquals(30, tabs[2], 'tabs[2]'); + // Deleting a non-existing tab stop should result in a negative value + x := tabs.Delete(24); + CheckTrue(x < 0, 'tabs.Delete(24) returned ' + IntToStr(x) + '; should''ve returned a negative value.'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._TabStopModifying; +var + tabs: TJclTabSet; +begin + tabs := TJclTabSet.Create([15, 17, 2, 30], True, 2); + try + // check tabs array before overwriting the first tab stop... + CheckEquals(2, tabs[0], 'tabs[0] before modify.'); + CheckEquals(15, tabs[1], 'tabs[1] before modify.'); + CheckEquals(17, tabs[2], 'tabs[2] before modify.'); + CheckEquals(30, tabs[3], 'tabs[3] before modify.'); + // overwrite the first tab stop + tabs[0] := 20; + // check tabs array after overwriting the first tab stop... + CheckEquals(15, tabs[0], 'tabs[0] after modify.'); + CheckEquals(17, tabs[1], 'tabs[1] after modify.'); + CheckEquals(20, tabs[2], 'tabs[2] after modify.'); + CheckEquals(30, tabs[3], 'tabs[3] after modify.'); + finally + FreeAndNil(tabs); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._ToString; +var + tabs: TJclTabSet; +begin + tabs := TJclTabSet.Create([15, 17, 20, 30], True, 4); + try + CheckEquals('0 [15,17,20,30] +4', tabs.ToString, 'zero-based, full'); + CheckEquals('0 15,17,20,30 +4', tabs.ToString(TabSetFormatting_Default), 'zero-based, default'); + tabs.ZeroBased := False; + CheckEquals('[16,18,21,31] +4', tabs.ToString, 'one-based, full'); + CheckEquals('16,18,21,31 +4', tabs.ToString(TabSetFormatting_Default), 'one-based, default'); + finally + tabs.Free; + end; + + tabs := TJclTabSet.FromString(''); // nil; ????????????????? + CheckEquals('0 [] +2', tabs.ToString, 'nil-set, full'); + CheckEquals('0', tabs.ToString(TabSetFormatting_Default), 'nil-set, default'); +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._UpdatePosition; +var + tabs: TJclTabSet; + column: Integer; + line: Integer; +begin + tabs := TJclTabSet.Create([17, 22, 32], False, 4); + try + column := tabs.StartColumn; + line := 1; + tabs.UpdatePosition( + 'Label1:'#9'LD'#9'A,0'#9'; init A'#13#10+ + #9'LD'#9'B, 100'#9'; loop counter'#13#10+ + #13#10+ + 'lp1:'#9'ADD'#9'(HL)'#9'; add data'#13+ + #9'JR'#9'NC,nxt'#9'; no carry=>skip to nxt'#13+ + #13+ + #9'RRCA'#10+ + #10+ + 'nxt:'#9'INC'#9'H'#9'; next scanline'#13#10+ + #9'DJNZ'#9'lp1', column, line); + CheckEquals(10, line, 'line'); + CheckEquals(25, column, 'column'); + finally + tabs.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TJclStringTabSet._ZeroBased; +var + tabs: TJclTabSet; + x: Integer; + failed: Boolean; +begin + tabs := TJclTabSet.Create([15, 20, 30], True, 2); + try + // make sure it's actually zero-based + CheckTrue(tabs.ZeroBased, 'tabset should be zero based.'); + // can we tab from column 0? + CheckEquals(15, tabs.TabFrom(0), 'tabs.TabFrom(0) in zero-based mode.'); + // we should have three stops + CheckEquals(3, tabs.Count, 'tabs.Count (zero-based)'); + // are they 15, 20 and 30 respectively? + CheckEquals(15, tabs[0], 'tabs[0] (zero-based)'); + CheckEquals(20, tabs[1], 'tabs[1] (zero-based)'); + CheckEquals(30, tabs[2], 'tabs[2] (zero-based)'); + + // switch to not zero-based + tabs.ZeroBased := False; + // make sure it's no longer zero-based + CheckFalse(tabs.ZeroBased, 'tabset shouldn''t be zero based.'); + // we still should have three stops + CheckEquals(3, tabs.Count, 'tabs.Count (not zero-based)'); + // are they 16, 21 and 31 respectively? + CheckEquals(16, tabs[0], 'tabs[0] (not zero-based)'); + CheckEquals(21, tabs[1], 'tabs[1] (not zero-based)'); + CheckEquals(31, tabs[2], 'tabs[2] (not zero-based)'); + // we shouldn't be able to tab from column 0? + try + x := tabs.TabFrom(0); + failed := False; + except + // swallow exception + failed := True; + x := 0; // make compiler happy + end; + if not failed then + Fail('tab.TabFrom(0) resulted in ' + IntToStr(x) + '; should''ve resulted in an exception when not in zero-based mode.'); + finally + FreeAndNil(tabs); + end; +end; + +{ TAnsiStringListTest } + +procedure TAnsiStringListTest._GetCommaTextCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextInnerQuotesProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('"World"'); + slRTL.Add('Hello'); + slRTL.Add('"World"'); + CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TAnsiStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextQuotedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('My World'); + slRTL.Add('Hello'); + slRTL.Add('My World'); + CheckEquals('Hello,"My World"', slJCL.CommaText, 'TAnsiStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TAnsiStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetCommaTextSpacedCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World,There!'; + slRTL.CommaText := 'Hello,My World,There!'; + CheckEquals(4, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World'; + slRTL.CommaText := 'Hello,My World'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._GetDelimitedTextFunkyFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TAnsiStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextCount; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextInnerQuotesProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"""World"""'; + slRTL.CommaText := 'Hello,"""World"""'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('"World"', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextQuotedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"World"'; + slRTL.CommaText := 'Hello,"World"'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetCommaTextQuotedSpacedProperties; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World",There!'; + slRTL.CommaText := 'Hello,"My World",There!'; + CheckEquals(3, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=3 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello,"My World"'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello,"My World"'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slJCL.DelimitedText := 'Hello,My World'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + slRTL.DelimitedText := 'Hello,My World'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TAnsiStringListTest._SetDelimitedTextFunkyFalse; +var slJCL: TAnsiStringList; + slRTL: TStringList; +begin + slJCL := TAnsiStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello-|My World|'; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello-|My World|'; + CheckEquals(2, slJCL.Count, 'TAnsiStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TAnsiStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TAnsiStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TAnsiStringList[0]'); + CheckEquals('My World', slJCL[1], 'TAnsiStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TAnsiStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +{ TJclStringListTest } + +procedure TJclStringListTest._GetCommaTextCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextInnerQuotesProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('"World"'); + slRTL.Add('Hello'); + slRTL.Add('"World"'); + CheckEquals('Hello,"""World"""', slJCL.CommaText, 'TJclStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextQuotedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.Add('Hello'); + slJCL.Add('My World'); + slRTL.Add('Hello'); + slRTL.Add('My World'); + CheckEquals('Hello,"My World"', slJCL.CommaText, 'TJclStringList.CommaText'); + CheckEquals(slRTL.CommaText, slJCL.CommaText, 'TJclStringList.CommaText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetCommaTextSpacedCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World,There!'; + slRTL.CommaText := 'Hello,My World,There!'; + CheckEquals(4, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + CheckEquals('Hello,"My World"', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,My World'; + slRTL.CommaText := 'Hello,My World'; + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + CheckEquals('Hello,My,World', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._GetDelimitedTextFunkyFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World"'; + slRTL.CommaText := 'Hello,"My World"'; + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + CheckEquals('Hello-|My World|', slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + CheckEquals(slRTL.DelimitedText, slJCL.DelimitedText, 'TJclStringList.DelimitedText'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextCount; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextInnerQuotesProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"""World"""'; + slRTL.CommaText := 'Hello,"""World"""'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('"World"', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,World'; + slRTL.CommaText := 'Hello,World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextQuotedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"World"'; + slRTL.CommaText := 'Hello,"World"'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetCommaTextQuotedSpacedProperties; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.CommaText := 'Hello,"My World",There!'; + slRTL.CommaText := 'Hello,"My World",There!'; + CheckEquals(3, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=3 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello,"My World"'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello,"My World"'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextCommaDoubleQuoteTrue; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '"'; + slJCL.Delimiter := ','; + slJCL.StrictDelimiter := true; + slJCL.DelimitedText := 'Hello,My World'; + slRTL.QuoteChar := '"'; + slRTL.Delimiter := ','; + slRTL.StrictDelimiter := true; + slRTL.DelimitedText := 'Hello,My World'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SetDelimitedTextFunkyFalse; +var slJCL: TJclStringList; + slRTL: TStringList; +begin + slJCL := TJclStringList.Create; + slRTL := TStringList.Create; + try + slJCL.QuoteChar := '|'; + slJCL.Delimiter := '-'; + slJCL.StrictDelimiter := false; + slJCL.DelimitedText := 'Hello-|My World|'; + slRTL.QuoteChar := '|'; + slRTL.Delimiter := '-'; + slRTL.StrictDelimiter := false; + slRTL.DelimitedText := 'Hello-|My World|'; + CheckEquals(2, slJCL.Count, 'TJclStringList.Count'); + CheckEquals(slRTL.Count, slJCL.Count, 'TJclStringList.Count'); + if slJCL.Count=2 then begin + CheckEquals('Hello', slJCL[0], 'TJclStringList[0]'); + CheckEquals(slRTL[0], slJCL[0], 'TJclStringList[0]'); + CheckEquals('My World', slJCL[1], 'TJclStringList[1]'); + CheckEquals(slRTL[1], slJCL[1], 'TJclStringList[1]'); + end; + finally + FreeAndNil(slJCL); + FreeAndNil(slRTL); + end; +end; + +procedure TJclStringListTest._SplitJoin; +var slJCL: IJclStringList; +begin + slJCL := TJclStringList.Create; + + CheckEquals(0, slJCL.Count); + slJcl.Add('111'); + slJcl.Add('222'); + CheckEquals(2, slJCL.Count); + slJcl.Split('1111f2222f3333f','f'); + CheckEquals(4, slJCL.Count); + CheckEquals(3, slJCL.LastIndex); + CheckEquals(0, Length(slJCL.Last)); + slJcl.Split('1111f2222f3333f','f', False); + CheckEquals(8, slJCL.Count); + CheckEquals(7, slJCL.LastIndex); + CheckEquals(0, Length(slJCL.Last)); + slJcl.Clear; + CheckEquals(0, slJCL.Count); + CheckEquals('', slJCL.Join('111')); + slJcl.Add('0000'); + CheckEquals('0000', slJCL.Join('222')); + slJcl.Split('1111f2222f3333f','f', False); + slJCL.Delete(slJCL.LastIndex); + CheckEquals('0000a1111a2222a3333', slJCL.Join('a')); +end; + +initialization + + RegisterTest('JCLStrings', TJclStringTransformation.Suite); + RegisterTest('JCLStrings', TJclStringManagment.Suite); + RegisterTest('JCLStrings', TJclStringSearchandReplace.Suite); + RegisterTest('JCLStrings', TJclStringCharacterTestRoutines.Suite); + RegisterTest('JCLStrings', TJclStringExtraction.Suite); + RegisterTest('JCLStrings', TJclStringTabSet.Suite); + RegisterTest('JCLStrings', TAnsiStringListTest.Suite); + RegisterTest('JCLStrings', TJCLStringListTest.Suite); + +// History: +// +// $Log$ +// Revision 1.3 2004/12/05 15:55:32 rrossmair +// - restored D5 compatibility +// + +end. From 0cbdd4069219d5c7fd795f41f0cb3f07ffc93e7a Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Mon, 18 Feb 2013 11:51:33 +0400 Subject: [PATCH 10/12] StrSmartCase now may ensure overall string lowercasing. --- jcl/source/common/JclAnsiStrings.pas | 6 +++--- jcl/source/common/JclStrings.pas | 12 ++++++------ qa/automated/dunit/units/TestJclStrings.pas | 7 +++++++ 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/jcl/source/common/JclAnsiStrings.pas b/jcl/source/common/JclAnsiStrings.pas index 5f5f0c525b..e4f2fd90aa 100644 --- a/jcl/source/common/JclAnsiStrings.pas +++ b/jcl/source/common/JclAnsiStrings.pas @@ -360,7 +360,7 @@ procedure StrReverseInPlace(var S: AnsiString); function StrSingleQuote(const S: AnsiString): AnsiString; procedure StrSkipChars(var S: PAnsiChar; const Chars: TSysCharSet); overload; procedure StrSkipChars(const S: AnsiString; var Index: SizeInt; const Chars: TSysCharSet); overload; -function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString; +function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet; const LowerRest: boolean = false): AnsiString; overload; // overloading due to JclStrings "string" variants function StrStringToEscaped(const S: AnsiString): AnsiString; function StrStripNonNumberChars(const S: AnsiString): AnsiString; function StrToHex(const Source: AnsiString): AnsiString; @@ -2103,7 +2103,7 @@ procedure StrSkipChars(const S: AnsiString; var Index: SizeInt; const Chars: TSy Inc(Index); end; -function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString; +function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet; const LowerRest: boolean): AnsiString; var Source, Dest: PAnsiChar; Index, Len: SizeInt; @@ -2114,7 +2114,7 @@ function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString; if S <> '' then begin - Result := S; + if LowerRest then Result := AnsiLowerCase(S) else Result := S; UniqueString(Result); Len := Length(S); diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 0a35bd473b..34bc96ba8b 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -239,8 +239,8 @@ procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; -function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; +function StrSmartCase(const S: string; const Delimiters: TCharValidator = nil; const LowerRest: boolean = false): string; overload; +function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean = false): string; overload; function StrStringToEscaped(const S: string): string; function StrStripNonNumberChars(const S: string): string; function StrToHex(const Source: string): AnsiString; @@ -1823,7 +1823,7 @@ procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array o Inc(Index); end; -function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; +function StrSmartCase(const S: string; const Delimiters: TCharValidator; const LowerRest: boolean): string; var Source, Dest: PChar; Index, Len: SizeInt; @@ -1837,7 +1837,7 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator): string if S <> '' then begin - Result := S; + if LowerRest then Result := AnsiLowerCase(S) else Result := S; UniqueString(Result); Len := Length(S); @@ -1856,7 +1856,7 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator): string end; end; -function StrSmartCase(const S: string; const Delimiters: array of Char): string; +function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean): string; var Source, Dest: PChar; Index, Len: SizeInt; @@ -1865,7 +1865,7 @@ function StrSmartCase(const S: string; const Delimiters: array of Char): string; if S <> '' then begin - Result := S; + if LowerRest then Result := AnsiLowerCase(S) else Result := S; UniqueString(Result); Len := Length(S); diff --git a/qa/automated/dunit/units/TestJclStrings.pas b/qa/automated/dunit/units/TestJclStrings.pas index b3f60154d8..e82533eea4 100644 --- a/qa/automated/dunit/units/TestJclStrings.pas +++ b/qa/automated/dunit/units/TestJclStrings.pas @@ -1220,6 +1220,13 @@ procedure TJclStringTransformation._StrSmartCase; CheckEquals('XxxxxAx', StrSmartCase('xxxxxAx', [' ','x']), 'StrSmartCase6'); // test 7: delimiters followed by the another delimiter will not force an upper case on the second delimiter CheckEquals('Xxx xAx', StrSmartCase('xxx xAx', [' ','x']), 'StrSmartCase7'); + + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi ', nil), 'StrSmartCase8'); + CheckEquals(' Project Jedi ', StrSmartCase(' project jedi '), 'StrSmartCase9'); + + CheckEquals(' Project J.E.D.I.', StrSmartCase(' project J.E.D.I.', [' ']), 'StrSmartCase10'); + CheckEquals(' Project J.e.d.i.', StrSmartCase(' project J.E.D.I.', [' '], true), 'StrSmartCase11'); + end; //-------------------------------------------------------------------------------------------------- From e57d59048a05d02d56aba6cd3accddc40835951b Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Mon, 18 Feb 2013 17:25:51 +0400 Subject: [PATCH 11/12] StrSmartCase: 1) shrinking copy-paste 2) adding delimiters as string --- jcl/source/common/JclStrings.pas | 141 +++++++++++++++----- qa/automated/dunit/units/TestJclStrings.pas | 2 + 2 files changed, 113 insertions(+), 30 deletions(-) diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 34bc96ba8b..63e5fcc445 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -241,6 +241,7 @@ procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharVa procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; function StrSmartCase(const S: string; const Delimiters: TCharValidator = nil; const LowerRest: boolean = false): string; overload; function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean = false): string; overload; +function StrSmartCase(const S: string; const Delimiters: string; const LowerRest: boolean = false): string; overload; function StrStringToEscaped(const S: string): string; function StrStripNonNumberChars(const S: string): string; function StrToHex(const Source: string): AnsiString; @@ -1823,19 +1824,25 @@ procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array o Inc(Index); end; -function StrSmartCase(const S: string; const Delimiters: TCharValidator; const LowerRest: boolean): string; +type StrSmartCase_DataFrame = record + S: string; + LowerRest: boolean; + + Delimiters_S: string; // don't want variant record here, so that compiler could Finalize it + Delimiters_F: TCharValidator; + +// need var-param due to http://qc.embarcadero.com/wc/qcmain.aspx?d=112789 + CharCheck: function (const Ch: Char; var Fr: StrSmartCase_DataFrame): boolean; +end; + +function StrSmartCase(var Frame: StrSmartCase_DataFrame): string; overload; var Source, Dest: PChar; Index, Len: SizeInt; - InternalDelimiters: TCharValidator; begin Result := ''; - if Assigned(Delimiters) then - InternalDelimiters := Delimiters - else - InternalDelimiters := CharIsSpace; - if S <> '' then + with Frame do if S <> '' then begin if LowerRest then Result := AnsiLowerCase(S) else Result := S; UniqueString(Result); @@ -1847,7 +1854,7 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator; const L for Index := 2 to Len do begin - if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then + if CharCheck(Source^, Frame) and not CharCheck(Dest^, Frame) then Dest^ := CharUpper(Dest^); Inc(Dest); Inc(Source); @@ -1856,32 +1863,106 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator; const L end; end; -function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean): string; -var - Source, Dest: PChar; - Index, Len: SizeInt; +function StrSmartCase_Str(const Ch: Char; var Fr: StrSmartCase_DataFrame): boolean; begin - Result := ''; + Result := CharPos(Fr.Delimiters_S, Ch) > 0; +end; +function StrSmartCase_Func(const Ch: Char; var Fr: StrSmartCase_DataFrame): boolean; +begin + Result := Fr.Delimiters_F(Ch); +end; - if S <> '' then - begin - if LowerRest then Result := AnsiLowerCase(S) else Result := S; - UniqueString(Result); +function StrSmartCase(const S: string; const Delimiters: string; const LowerRest: boolean): string; +var Fr: StrSmartCase_DataFrame; +begin + Fr.S := S; + Fr.LowerRest := LowerRest; + Fr.Delimiters_S := Delimiters; + Fr.CharCheck := StrSmartCase_Str; - Len := Length(S); - Source := PChar(S); - Dest := PChar(Result); - Inc(Dest); + Result := StrSmartCase(Fr); +end; - for Index := 2 to Len do - begin - if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then - Dest^ := CharUpper(Dest^); - Inc(Dest); - Inc(Source); - end; - Result[1] := CharUpper(Result[1]); - end; +function StrSmartCase(const S: string; const Delimiters: TCharValidator; const LowerRest: boolean): string; +var Fr: StrSmartCase_DataFrame; +begin + Fr.S := S; + Fr.LowerRest := LowerRest; + if Assigned(Delimiters) + then Fr.Delimiters_F := Delimiters + else Fr.Delimiters_F := CharIsSpace; + Fr.CharCheck := StrSmartCase_Func; + + Result := StrSmartCase(Fr); +//var +// Source, Dest: PChar; +// Index, Len: SizeInt; +// InternalDelimiters: TCharValidator; +//begin +// Result := ''; +// if Assigned(Delimiters) then +// InternalDelimiters := Delimiters +// else +// InternalDelimiters := CharIsSpace; +// +// if S <> '' then +// begin +// if LowerRest then Result := AnsiLowerCase(S) else Result := S; +// UniqueString(Result); +// +// Len := Length(S); +// Source := PChar(S); +// Dest := PChar(Result); +// Inc(Dest); +// +// for Index := 2 to Len do +// begin +// if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then +// Dest^ := CharUpper(Dest^); +// Inc(Dest); +// Inc(Source); +// end; +// Result[1] := CharUpper(Result[1]); +// end; +end; + +function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean): string; +var Fr: StrSmartCase_DataFrame; +begin + Fr.S := S; + Fr.LowerRest := LowerRest; +// if Length(Delimiters) = 0 // dynarray can not be assigned from open array => string +// then Fr.Delimiters_S := EmptyStr +// else SetString(Fr.Delimiters_S, @Delimiters[0], Length(Delimiters)); + Fr.Delimiters_S := Delimiters; + Fr.CharCheck := StrSmartCase_Str; + + Result := StrSmartCase(Fr); +//var +// Source, Dest: PChar; +// Index, Len: SizeInt; +//begin +// Result := ''; +// +// if S <> '' then +// begin +// if LowerRest then Result := AnsiLowerCase(S) else Result := S; +// UniqueString(Result); +// +// Len := Length(S); +// Source := PChar(S); +// Dest := PChar(Result); +// Inc(Dest); +// +// for Index := 2 to Len do +// begin +// if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then +// Dest^ := CharUpper(Dest^); +// Inc(Dest); +// Inc(Source); +// end; +// Result[1] := CharUpper(Result[1]); +// end; end; function StrStringToEscaped(const S: string): string; diff --git a/qa/automated/dunit/units/TestJclStrings.pas b/qa/automated/dunit/units/TestJclStrings.pas index e82533eea4..f3c47b5874 100644 --- a/qa/automated/dunit/units/TestJclStrings.pas +++ b/qa/automated/dunit/units/TestJclStrings.pas @@ -1227,6 +1227,8 @@ procedure TJclStringTransformation._StrSmartCase; CheckEquals(' Project J.E.D.I.', StrSmartCase(' project J.E.D.I.', [' ']), 'StrSmartCase10'); CheckEquals(' Project J.e.d.i.', StrSmartCase(' project J.E.D.I.', [' '], true), 'StrSmartCase11'); + CheckEquals(' Project J.E.D.I.', StrSmartCase(' project J.e.d.i.', [' ', '.']), 'StrSmartCase12'); + CheckEquals(' Project J.E.D.I.', StrSmartCase(' project J.e.d.i.', '. '), 'StrSmartCase13'); end; //-------------------------------------------------------------------------------------------------- From 5227658b88fee3d3f42450482b7d6e26a1ceaf65 Mon Sep 17 00:00:00 2001 From: the-Arioch Date: Mon, 18 Feb 2013 17:28:52 +0400 Subject: [PATCH 12/12] cleaning legacy code after DUnit passed --- jcl/source/common/JclStrings.pas | 56 +------------------------------- 1 file changed, 1 insertion(+), 55 deletions(-) diff --git a/jcl/source/common/JclStrings.pas b/jcl/source/common/JclStrings.pas index 63e5fcc445..281edd58cc 100644 --- a/jcl/source/common/JclStrings.pas +++ b/jcl/source/common/JclStrings.pas @@ -1867,6 +1867,7 @@ function StrSmartCase_Str(const Ch: Char; var Fr: StrSmartCase_DataFrame): boole begin Result := CharPos(Fr.Delimiters_S, Ch) > 0; end; + function StrSmartCase_Func(const Ch: Char; var Fr: StrSmartCase_DataFrame): boolean; begin Result := Fr.Delimiters_F(Ch); @@ -1894,36 +1895,6 @@ function StrSmartCase(const S: string; const Delimiters: TCharValidator; const L Fr.CharCheck := StrSmartCase_Func; Result := StrSmartCase(Fr); -//var -// Source, Dest: PChar; -// Index, Len: SizeInt; -// InternalDelimiters: TCharValidator; -//begin -// Result := ''; -// if Assigned(Delimiters) then -// InternalDelimiters := Delimiters -// else -// InternalDelimiters := CharIsSpace; -// -// if S <> '' then -// begin -// if LowerRest then Result := AnsiLowerCase(S) else Result := S; -// UniqueString(Result); -// -// Len := Length(S); -// Source := PChar(S); -// Dest := PChar(Result); -// Inc(Dest); -// -// for Index := 2 to Len do -// begin -// if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then -// Dest^ := CharUpper(Dest^); -// Inc(Dest); -// Inc(Source); -// end; -// Result[1] := CharUpper(Result[1]); -// end; end; function StrSmartCase(const S: string; const Delimiters: array of Char; const LowerRest: boolean): string; @@ -1938,31 +1909,6 @@ function StrSmartCase(const S: string; const Delimiters: array of Char; const Lo Fr.CharCheck := StrSmartCase_Str; Result := StrSmartCase(Fr); -//var -// Source, Dest: PChar; -// Index, Len: SizeInt; -//begin -// Result := ''; -// -// if S <> '' then -// begin -// if LowerRest then Result := AnsiLowerCase(S) else Result := S; -// UniqueString(Result); -// -// Len := Length(S); -// Source := PChar(S); -// Dest := PChar(Result); -// Inc(Dest); -// -// for Index := 2 to Len do -// begin -// if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then -// Dest^ := CharUpper(Dest^); -// Inc(Dest); -// Inc(Source); -// end; -// Result[1] := CharUpper(Result[1]); -// end; end; function StrStringToEscaped(const S: string): string;