Archivado/Componentes.Terceros.RemObjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
e4d0fcb01d
Componentes.Terceros.RemObj.../internal/5.0.23.613/1/RemObjects SDK for Delphi/Source/RODX/uRODXString.pas
david 2824855ea7 - Modificación del paquete RemObjects_Core_D10 para que sea un paquete de runtime/designtime (antes era designtime sólo) 
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10
- Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10

git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
2007-09-10 14:06:19 +00:00

2859 lines
78 KiB
ObjectPascal
Raw Blame History

{$I uRODXFree.def}
unit uRODXString;
interface
///////////////////////////////////////////////////////////////////////////////
// Unit: DXString
// Author: G.E. Ozz Nixon Jr. (onixon@dxsock.com)
// Assembly: Pete Morris and Ozz Nixon {all asm by Ozz is denoted!}
// ========================================================================
// Source Owner: DX, Inc. 1995-2002
// Copyright: All code is the property of DX, Inc. Licensed for
// resell by Brain Patchwork DX (tm) and part of the
// DX (r) product lines, which are (c) 1999-2002
// DX, Inc. Source may not be distributed without
// written permission from both Brain Patchwork DX,
// and DX, Inc.
// License: (Reminder), None of this code can be added to other
// developer products without permission. This includes
// but not limited to DCU's, DCP's, DLL's, OCX's, or
// any other form of merging our technologies. All of
// your products released to a public consumer be it
// shareware, freeware, commercial, etc. must contain a
// license notification somewhere visible in the
// application.
// Example is Internet Explorer - Help->About screen
// shows the licensed code contained in the application.
// Code Version: (3rd Generation Code)
// ========================================================================
// Description:
// ========================================================================
///////////////////////////////////////////////////////////////////////////////
Uses
{$IFNDEF LINUX}
Windows,
{$ENDIF}
Classes,
SyncObjs,
SysUtils;
// DO NOT CHANGE THIS ONE
// BRAIN PATCHWORK DX ONLY CHANGES THIS
// IT IS USED FOR TECHNICAL SUPPORT (VERSION CONTROLS)
CONST BPDX_RELEASE_DATE='2002-09-01'; {YYYY-MM-DD}
///////////////////////////////////////////////////////////////////////////////
// Brain Patchwork - Just so you can verify which release you have at run-time.
///////////////////////////////////////////////////////////////////////////////
Type
TDXCritical = Class(TObject)
private
{$IFDEF VER100}
Synchronizer:TCriticalSection;
{$ELSE}
// Borland has screwed the pooch on TMultiReadExclusiveWriteSynchronizer
// so bad that we will not support it!
Synchronizer:TCriticalSection;// TMultiReadExclusiveWriteSynchronizer;
{$ENDIF}
public
constructor Create;
destructor Destroy; override;
procedure StartingRead;
procedure FinishedRead;
procedure StartingWrite;
procedure FinishedWrite;
End;
{$IFDEF OBJECTS_ONLY}
TDXComponent = Class(TObject)
{$ELSE}
TDXComponent = Class(TComponent)
{$ENDIF}
private
procedure SetReleaseDate(value: string);
Function GetReleaseDate:String;
public
MyCriticalSection:TDXCritical;
constructor Create(AOwner: TComponent); {$IFNDEF OBJECTS_ONLY} override; {$ENDIF}
destructor Destroy; override;
published
property ReleaseDate:String Read GetReleaseDate write SetReleaseDate;
End;
///////////////////////////////////////////////////////////////////////////////
// Routines to centralize "Windows" calls
///////////////////////////////////////////////////////////////////////////////
{$IFDEF LINUX}
Type
DWord=LongWord;
TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest, pTimeCritical);
{$ELSE}
Type
PInteger = Windows.PInteger;
DWORD = Windows.DWord;
{$ENDIF}
// LINUX:
Function LocalTimeZoneBias:Integer;
// WINDOWS:
Procedure ProcessWindowsMessageQueue;
function HiByteOfWord(Const W:Word):Byte;
function MakeBytesToWord(Const A,B:Byte):Word;
function WindowsWriteFile(hFile:THandle;
const Buffer;nNumberOfBytesToWrite:DWORD;
var lpNumberOfBytesWritten:DWORD):Boolean;
Procedure ShowMessageWindow(Const Caption,Message:String);
Procedure DoSleepEX(Const Interval:DWord);
{$IFNDEF LINUX}
Function GetRegistryString(Const Key:HKey;Const SubKey:string):string;
Function SetRegistryString(Const Key:HKey;SubKey,Value:string):Boolean;
function RegistryStringGet(Const Key:HKey;SubKey:string):String;
function RegistryStringSet(Const Key:HKey;SubKey,Value:string):Boolean; //2.0.12
Function LaunchWebBrowser(Const URL:string;Const WindowState:Integer):Boolean;
{$ENDIF}
{$IFNDEF VER90} // Nothing like this in D2???
Function MakeUUID:String;
Function RawUUID:String;
Function MakeUUIDPacked:String;
{$ENDIF}
///////////////////////////////////////////////////////////////////////////////
// Numeric Routines
///////////////////////////////////////////////////////////////////////////////
Function IsCharAlphaNumeric(Const c:char):Boolean; // 2.3 const and asm
Function IsCharAlpha(Const c:Char):Boolean; // 2.3 const and asm
Function IsNumeric(Const c:char):Boolean; // 2.3 asm
Function isNumericString(Const S:string):Boolean;
Function Min(Const I1,I2:Integer):Integer; // 2.3 asm
Function Max(Const I1,I2:Integer):Integer; // 2.3 asm
Function StringToInteger(Const S:String):Integer;
Procedure SwapMove(Source:Word;Var Dest);
Function IntToCommaStr(Const Number:Integer):String; // 2.3 const
Function BinaryToString(Const Number:Byte):String; // 2.3 const
Function StringToBinary(S:String):Byte;
function LRot16(X:Word;c:longint):Word;
function RRot16(X:Word;c:longint):Word;
function LRot32(X:DWord;c:longint):DWord;
function RRot32(X:DWord;c:longint):DWord;
function SwapDWord(X:DWord):DWord;
///////////////////////////////////////////////////////////////////////////////
// String Routines
///////////////////////////////////////////////////////////////////////////////
Function QuickPos(const aFindString,aSourceString:String):integer;
Function CharPos(const C: Char; const aSource : String) : Integer;
Function Fetch(var S:String;Const Sub:String;Const IgnoreCase:Boolean):String;
Function FetchByChar(var S:String;Const Sub:Char;Const IgnoreCase:Boolean):String;
Function Uppercase(Const S:String):String;
Function Lowercase(Const S:String):String; // 2.3 asm
Function ProperCase(Const S:String):String;
Function Trim(const S:string):string;
Function NoCRLF(Const S:String):String;
Function NoAngleBrackets(Const S:string):string;
Function InStrArray(const SearchStr:string;Const KnownCommands:Array of String):Integer; // 2.3 String instead of MySmallString
Procedure InverseString(Var S:String;Count:Integer);
Function HexDump(Const S:String):String; // 2.3 Const and rewrote to optimize for BIG strings!!
function ReplaceChar(const Source:string;Const OldChar,NewChar:Char):string;
function ExtractLeft(const aSourceString:String;Const Size:Integer):String; // 2.3 const
function ExtractRight(const aSourceString:String;Const Size:Integer):String; // 2.3 const
Function ExtractWordAt(const Text:String;Position:Integer):String; // 2.3 const
Function LeftJustify(Const S:String;Const MaxLength:Integer):String;
Function RightJustify(Const S:String;Const MaxLength:Integer):String;
Function CleanChar(Const InChar:Char):Char; // 2.3 const
Function CleanStr(Const InStr:String):String; // 2.3 const
Function PosLastChar(Const Ch:Char;Const S:String):Integer; // 2.3 const
Function AsciiToOem(Const ax:String):String; // 2.3 const & fixed
Function OemToAscii(Const ax:String):String; // 2.3 const & fixed
Function WordCount(const S:string):Integer; // 2.3 const
Function CRC32ByChar(const Ch:Char;const starting_crc:LONGINT):LONGINT; // 2.3 const
Function CRC32ByString(const S:String;const starting_crc:LONGINT):LONGINT; // 2.3 const
Function CRC16ByChar(const Ch:Char;const starting_crc:word):word;
Function CRC16ByString(const S:String;const starting_crc:word):word;
Function CRCARCByChar(const Ch:Char;const starting_crc:word):word;
Function CRCARCByString(const S:String;const starting_crc:word):word;
Procedure SetLongBit(Var L:LongInt;const Bit:Byte;const Setting:Boolean); // 2.3 const
Function GetLongBit(const L:LongInt;const Bit:Byte):Boolean; // 2.3 const
Procedure SetWordBit(Var L:Word;const Bit:Byte;const Setting:Boolean); // 2.3 const
Function GetWordBit(const L:Word;const Bit:Byte):Boolean; // 2.3 const
Procedure SetByteBit(Var L:Byte;const Bit:Byte;const Setting:Boolean); // 2.3 const
Function GetByteBit(const L:Byte;const Bit:Byte):Boolean; // 2.3 const
Function Replicate(const Source:String;NumberOfTimes:Integer):String; // const and fixed
Function IsWildCard(const Source:String):Boolean;
function PCharLen(Str:PChar):integer; // 2.3 *NEW* (3.8times faster than strlen!)
// new 8-20-2002
function WildCompare(LookingFor,SourceStr:String):Boolean;
///////////////////////////////////////////////////////////////////////////////
// Internet Routines
///////////////////////////////////////////////////////////////////////////////
Function GetIndex(Const c:char):Integer;
Function Base64ToString(Const S:String):String;
Function StringToBase64(Const S1:String):String;
function FixDottedIP(Const S:string):string;
Function IPStringFormated(S:String):String;
Function IPAddressFormatted(Const I1,I2,I3,I4:Integer):String;
Function EscapeDecode(Const S:String):String;
Function EscapeEncode(Const S:String):String;
Function EncodeDomain(S:String):String;
Function EncodeAddress(S:String):String;
Function DecodeDomain(S:String):String;
Function GetActualEmailAddress(Parm,Command:String):String;
///////////////////////////////////////////////////////////////////////////////
// Date and/or Time Routines
///////////////////////////////////////////////////////////////////////////////
Function TimeZone:String;
Function TimeZoneBias:String;
Function ShortTimeZone:String;
Function DateTimeToGMTRFC822(Const DT:TDateTime):String;
Function DateTimeToGMTRFC850(Const DT:TDateTime):String;
Function DateTimeToRFC850(Const DT:TDateTime):String;
Function DateTimeToRFC850Bias(Const DT:TDateTime):String;
Function RFCToDateTime(S:String):TDateTime;
Procedure Unpacktime(Const P:Longint;Var DT:TDatetime);
Procedure Packtime(Var DT:TDatetime;VAR P:Longint);
Function GetDosDate:LongInt;
Function GetDOW:Word;
Function TimeOut(Const MyTime:DWord):Boolean;
Function TimeCounter:DWord;
Function IsLeapYear(Const Year:Word):Boolean;
Function DateTimeToGMT(const DT:TDateTime):TDateTime;
Function DateTimeToLocal(const DT:TDateTime):TDateTime;
Function IsTimeAM(const DT:TDateTime):Boolean;
Function IsTimePM(const DT:TDateTime):Boolean;
Function IsTimeNoon(const DT:TDateTime):Boolean;
Function IsTimeMidnight(const DT:TDateTime):Boolean;
Function DaysThisMonth(const DT:TDateTime):Integer;
Function DaysLeftThisMonth(const DT:TDateTime):Integer;
Function DayOfTheYear(const DT:TDateTime):Integer;
Function DaysLeftThisYear(const DT:TDateTime):Integer;
///////////////////////////////////////////////////////////////////////////////
// File/Disk Routines
///////////////////////////////////////////////////////////////////////////////
Function AddBackSlash(Const S:String):String;
Function NoBackSlash(Const S:String):String;
Function ToOSSlashes(Const S:String):String; // 2.3
Function ToUnixSlashes(Const S:String):String;
Function ToDOSSlashes(Const S:String):String;
Function ChangeDir(Const S,RP:String):String;
{$IFDEF VER100}
type
TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);
Function StringReplace(const S, OldPattern, NewPattern: string;
Flags: TReplaceFlags): string;
procedure FreeAndNil(var Obj);
{$ELSE}
{$ENDIF}
{$IFDEF LINUX}
Function CoCreateGuid(var GUID:TGUID):HResult;
{$ELSE}
{$IFDEF VER90} // DELPHI2 does not have a TGuid
Function CoCreateGuid(var guid:Pointer): HResult; stdcall;
{$ELSE}
Function CoCreateGuid(var guid: TGUID): HResult; stdcall;
{$ENDIF}
{$ENDIF}
///////////////////////////////////////////////////////////////////////////////
// DXSock 3.0 Additions
///////////////////////////////////////////////////////////////////////////////
Type
CharSet=set of Char;
Function Center(S:String;MaxWidth:Integer):String;
Function LeftJustifyCh(Const S:String;Const Ch:Char;Const MaxLength:Integer):String;
Function RightJustifyCh(Const S:String;Const Ch:Char;Const MaxLength:Integer):String;
Function EncodeTabs(S:string;TabSize:Byte):string;
Function DecodeTabs(S:string;TabSize:Byte):string;
Function Filter(S:String;CS:CharSet):String;
Function SoundEx(S:String):String;
//procedure register;
implementation
{$IFDEF LINUX}
Uses
Libc,
{$IFDEF FPC} Forms, Dialogs
{$ELSE} QForms,QDialogs
{$ENDIF}
;
{$ELSE}
Uses
Registry; {to avoid Win2K security issue!}
{$ENDIF}
Const
Alphabet='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
AlphabetLength = 64; //Needed in GetIndex
{$IFDEF VER100} // D3 Windows.PAS is missing these:
TIME_ZONE_ID_STANDARD = 1;
TIME_ZONE_ID_DAYLIGHT = 2;
{$ENDIF}
{$IFNDEF VER90}
ole32='ole32.dll';
{$ENDIF}
{$WARNINGS OFF}
crc_32_tab: ARRAY[0..255] OF LONGINT = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
$0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
$1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
$3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
$26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
$2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
$76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
$7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
$6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
$65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
$4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
$5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
$edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
$e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
$f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
$fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
$cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
$c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
$9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
$86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
$88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
$a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
$aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
$b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d);
crc_arc_tab: Array[0..$FF] of Word =
($00000, $0C0C1, $0C181, $00140, $0C301, $003C0, $00280, $0C241,
$0C601, $006C0, $00780, $0C741, $00500, $0C5C1, $0C481, $00440,
$0CC01, $00CC0, $00D80, $0CD41, $00F00, $0CFC1, $0CE81, $00E40,
$00A00, $0CAC1, $0CB81, $00B40, $0C901, $009C0, $00880, $0C841,
$0D801, $018C0, $01980, $0D941, $01B00, $0DBC1, $0DA81, $01A40,
$01E00, $0DEC1, $0DF81, $01F40, $0DD01, $01DC0, $01C80, $0DC41,
$01400, $0D4C1, $0D581, $01540, $0D701, $017C0, $01680, $0D641,
$0D201, $012C0, $01380, $0D341, $01100, $0D1C1, $0D081, $01040,
$0F001, $030C0, $03180, $0F141, $03300, $0F3C1, $0F281, $03240,
$03600, $0F6C1, $0F781, $03740, $0F501, $035C0, $03480, $0F441,
$03C00, $0FCC1, $0FD81, $03D40, $0FF01, $03FC0, $03E80, $0FE41,
$0FA01, $03AC0, $03B80, $0FB41, $03900, $0F9C1, $0F881, $03840,
$02800, $0E8C1, $0E981, $02940, $0EB01, $02BC0, $02A80, $0EA41,
$0EE01, $02EC0, $02F80, $0EF41, $02D00, $0EDC1, $0EC81, $02C40,
$0E401, $024C0, $02580, $0E541, $02700, $0E7C1, $0E681, $02640,
$02200, $0E2C1, $0E381, $02340, $0E101, $021C0, $02080, $0E041,
$0A001, $060C0, $06180, $0A141, $06300, $0A3C1, $0A281, $06240,
$06600, $0A6C1, $0A781, $06740, $0A501, $065C0, $06480, $0A441,
$06C00, $0ACC1, $0AD81, $06D40, $0AF01, $06FC0, $06E80, $0AE41,
$0AA01, $06AC0, $06B80, $0AB41, $06900, $0A9C1, $0A881, $06840,
$07800, $0B8C1, $0B981, $07940, $0BB01, $07BC0, $07A80, $0BA41,
$0BE01, $07EC0, $07F80, $0BF41, $07D00, $0BDC1, $0BC81, $07C40,
$0B401, $074C0, $07580, $0B541, $07700, $0B7C1, $0B681, $07640,
$07200, $0B2C1, $0B381, $07340, $0B101, $071C0, $07080, $0B041,
$05000, $090C1, $09181, $05140, $09301, $053C0, $05280, $09241,
$09601, $056C0, $05780, $09741, $05500, $095C1, $09481, $05440,
$09C01, $05CC0, $05D80, $09D41, $05F00, $09FC1, $09E81, $05E40,
$05A00, $09AC1, $09B81, $05B40, $09901, $059C0, $05880, $09841,
$08801, $048C0, $04980, $08941, $04B00, $08BC1, $08A81, $04A40,
$04E00, $08EC1, $08F81, $04F40, $08D01, $04DC0, $04C80, $08C41,
$04400, $084C1, $08581, $04540, $08701, $047C0, $04680, $08641,
$08201, $042C0, $04380, $08341, $04100, $081C1, $08081, $04040);
crc_16_tab: Array[0..$FF] of Word =
($00000, $01021, $02042, $03063, $04084, $050a5, $060c6, $070e7,
$08108, $09129, $0a14a, $0b16b, $0c18c, $0d1ad, $0e1ce, $0f1ef,
$01231, $00210, $03273, $02252, $052b5, $04294, $072f7, $062d6,
$09339, $08318, $0b37b, $0a35a, $0d3bd, $0c39c, $0f3ff, $0e3de,
$02462, $03443, $00420, $01401, $064e6, $074c7, $044a4, $05485,
$0a56a, $0b54b, $08528, $09509, $0e5ee, $0f5cf, $0c5ac, $0d58d,
$03653, $02672, $01611, $00630, $076d7, $066f6, $05695, $046b4,
$0b75b, $0a77a, $09719, $08738, $0f7df, $0e7fe, $0d79d, $0c7bc,
$048c4, $058e5, $06886, $078a7, $00840, $01861, $02802, $03823,
$0c9cc, $0d9ed, $0e98e, $0f9af, $08948, $09969, $0a90a, $0b92b,
$05af5, $04ad4, $07ab7, $06a96, $01a71, $00a50, $03a33, $02a12,
$0dbfd, $0cbdc, $0fbbf, $0eb9e, $09b79, $08b58, $0bb3b, $0ab1a,
$06ca6, $07c87, $04ce4, $05cc5, $02c22, $03c03, $00c60, $01c41,
$0edae, $0fd8f, $0cdec, $0ddcd, $0ad2a, $0bd0b, $08d68, $09d49,
$07e97, $06eb6, $05ed5, $04ef4, $03e13, $02e32, $01e51, $00e70,
$0ff9f, $0efbe, $0dfdd, $0cffc, $0bf1b, $0af3a, $09f59, $08f78,
$09188, $081a9, $0b1ca, $0a1eb, $0d10c, $0c12d, $0f14e, $0e16f,
$01080, $000a1, $030c2, $020e3, $05004, $04025, $07046, $06067,
$083b9, $09398, $0a3fb, $0b3da, $0c33d, $0d31c, $0e37f, $0f35e,
$002b1, $01290, $022f3, $032d2, $04235, $05214, $06277, $07256,
$0b5ea, $0a5cb, $095a8, $08589, $0f56e, $0e54f, $0d52c, $0c50d,
$034e2, $024c3, $014a0, $00481, $07466, $06447, $05424, $04405,
$0a7db, $0b7fa, $08799, $097b8, $0e75f, $0f77e, $0c71d, $0d73c,
$026d3, $036f2, $00691, $016b0, $06657, $07676, $04615, $05634,
$0d94c, $0c96d, $0f90e, $0e92f, $099c8, $089e9, $0b98a, $0a9ab,
$05844, $04865, $07806, $06827, $018c0, $008e1, $03882, $028a3,
$0cb7d, $0db5c, $0eb3f, $0fb1e, $08bf9, $09bd8, $0abbb, $0bb9a,
$04a75, $05a54, $06a37, $07a16, $00af1, $01ad0, $02ab3, $03a92,
$0fd2e, $0ed0f, $0dd6c, $0cd4d, $0bdaa, $0ad8b, $09de8, $08dc9,
$07c26, $06c07, $05c64, $04c45, $03ca2, $02c83, $01ce0, $00cc1,
$0ef1f, $0ff3e, $0cf5d, $0df7c, $0af9b, $0bfba, $08fd9, $09ff8,
$06e17, $07e36, $04e55, $05e74, $02e93, $03eb2, $00ed1, $01ef0);
{$WARNINGS ON}
{
procedure register;
begin
RegisterComponents('BPDX Addons', [TDXComponent]);
end;
}
///////////////////////////////////////////////////////////////////////////////
// Internal Version Control Routines (used for DCU's mainly)
///////////////////////////////////////////////////////////////////////////////
procedure TDXComponent.SetReleaseDate(value: string);
Begin
End;
Function TDXComponent.GetReleaseDate:String;
Begin
Result:=BPDX_RELEASE_DATE;
End;
constructor TDXComponent.Create(AOwner: TComponent);
Begin
{$IFDEF OBJECTS_ONLY}
inherited create;
{$ELSE}
inherited create(AOwner);
{$ENDIF}
MyCriticalSection:=TDXCritical.Create;
End;
destructor TDXComponent.Destroy;
Begin
MyCriticalSection.Free;
MyCriticalSection:=Nil;
inherited;
End;
constructor TDXCritical.Create;
Begin
inherited;
{$IFDEF VER100}
Synchronizer:=TCriticalSection.Create;
{$ELSE}
Synchronizer:=TCriticalSection.Create;// TMultiReadExclusiveWriteSynchronizer.Create;
{$ENDIF}
End;
destructor TDXCritical.Destroy;
Begin
try
Synchronizer.Free;
except
end;
inherited;
End;
Procedure TDXCritical.StartingRead;
Begin
{$IFDEF VER100}
Synchronizer.Acquire;
{$ELSE}
Synchronizer.Acquire; //BeginRead;
{$ENDIF}
End;
Procedure TDXCritical.FinishedRead;
Begin
{$IFDEF VER100}
Synchronizer.Release;
{$ELSE}
Synchronizer.Release; //EndRead;
{$ENDIF}
End;
Procedure TDXCritical.StartingWrite;
Begin
{$IFDEF VER100}
Synchronizer.Acquire;
{$ELSE}
Synchronizer.Acquire; //BeginWrite;
{$ENDIF}
End;
Procedure TDXCritical.FinishedWrite;
Begin
{$IFDEF VER100}
Synchronizer.Release;
{$ELSE}
Synchronizer.Release; //EndWrite;
{$ENDIF}
End;
///////////////////////////////////////////////////////////////////////////////
// Windows/Operating System Routines
///////////////////////////////////////////////////////////////////////////////
Procedure ProcessWindowsMessageQueue;
{$IFDEF LINUX}
Begin
Application.ProcessMessages;
End;
{$ELSE}
Var
MsgRec:TMsg;
Begin
If Not IsConsole then
while PeekMessage(MsgRec,0,0,0,PM_REMOVE) do begin
TranslateMessage(MsgRec);
DispatchMessage(MsgRec)
end;
End;
{$ENDIF}
function HiByteOfWord(Const W:Word):Byte;
Begin
Result:=Hi(W);
End;
function MakeBytesToWord(Const A,B:Byte):Word;
Begin
Result:=(A shl 8) + B;
End;
function WindowsWriteFile(hFile:THandle;const Buffer;nNumberOfBytesToWrite:DWORD;
var lpNumberOfBytesWritten: DWORD):Boolean;
Begin
{$IFDEF LINUX}
lpNumberOfBytesWritten:=FileWrite(hFile,Buffer,nNumberOfBytesToWrite);
Result:=lpNumberOfBytesWritten=nNumberOfBytesToWrite;
{$ELSE}
Result:=WriteFile(hFile,Buffer,nNumberOfBytesToWrite,lpNumberOfBytesWritten,Nil);
{$ENDIF}
End;
Procedure ShowMessageWindow(Const Caption,Message:String);
Begin
{$IFDEF LINUX}
MessageDlg(Caption,Message,mtError,[mbOk],0);
{$ELSE}
MessageBox(0,PChar(Message),PChar(Caption),MB_ICONEXCLAMATION or MB_SYSTEMMODAL);
{$ENDIF}
End;
Procedure DoSleepEX(Const Interval:DWord);
Begin
{$IFDEF LINUX}
Sleep(Interval);
{$ELSE}
SleepEx(Interval,False{True});
{$ENDIF}
End;
{$IFNDEF LINUX}
function RegistryStringGet(Const Key:HKey;SubKey:string):String;
var
Reg:TRegistry;
lResult:string;
DValue:string;
begin
lResult:='';
DValue:=SubKey;
Delete(DValue,1,PosLastChar('\',SubKey));
Delete(SubKey,PosLastChar('\',SubKey),length(DValue)+1);
Reg:=TRegistry.Create;
try
Reg.RootKey:=Key;
if Reg.OpenKey(SubKey,True) then
lresult:=Reg.ReadString(DValue);
finally
Reg.CloseKey;
Reg.Free;
end;
result:=lresult;
end;
function RegistryStringSet(Const Key:HKey;SubKey,Value:string):Boolean;
var
Reg:TRegistry;
DValue:string;
begin
DValue:=SubKey;
Delete(DValue,1,PosLastChar('\',SubKey));
Delete(SubKey,PosLastChar('\',SubKey),length(DValue)+1);
Reg:=TRegistry.Create;
Result:=False;
try
Reg.RootKey:=Key;
if Reg.OpenKey(SubKey,True) then Begin
Reg.WriteString(DValue,Value);
Result:=True;
End;
finally
Reg.CloseKey;
Reg.Free;
end;
end;
function GetRegistryString(Const Key:HKey;Const SubKey:string):string;
begin
Result:=RegistryStringGet(Key,SubKey);
end;
function SetRegistryString(Const Key:HKey;SubKey,Value:string):Boolean;
begin
Result:=RegistryStringSet(Key,SubKey,Value);
end;
function LaunchWebBrowser(Const URL:string;Const WindowState:Integer):Boolean;
var
sLaunch: string;
iPos: integer;
begin
Result:=False;
sLaunch:=GetRegistryString(HKEY_CLASSES_ROOT,'.htm');
if sLaunch<>'' then begin
sLaunch:=sLaunch + '\shell\open\command';
sLaunch:=GetRegistryString(HKEY_CLASSES_ROOT,sLaunch);
if sLaunch<>'' then begin
iPos:=QuickPos('"%1"',sLaunch);
if iPos=0 then iPos:=QuickPos('%1',sLaunch);
if iPos<>0 then sLaunch:=Copy(sLaunch,1,iPos-1);
sLaunch:=sLaunch+#32+URL;
Result:=WinExec(PChar(sLaunch),WindowState)>31;
end;
end;
end;
{$ENDIF}
{$IFNDEF VER90}
///////////////////////////////////////////////////////////////////////////////
// References the external symbol to MS CoCreateGUID function which creates MS-style UUID's
///////////////////////////////////////////////////////////////////////////////
{$IFNDEF LINUX}
function CoCreateGuid; external ole32 name 'CoCreateGuid';
{$ENDIF}
Function MakeUUID:String;
Var
UUIDVar: TGUID;
UUID_String: String;
k:Integer;
Begin
CoCreateGuid(UUIDVar);
UUID_String:=IntToHex(UUIDVar.D1, 8)+'-'+
IntToHex(UUIDVar.D2, 4)+'-'+
IntToHex(UUIDVar.D3, 4)+'-';
for k := 0 to 1 do UUID_String:=UUID_String+IntToHex(UUIDVar.D4[k], 2);
UUID_String:=UUID_String+'-';
for k := 2 to 7 do UUID_String:=UUID_String+IntToHex(UUIDVar.D4[k], 2);
Result:=UUID_String;
End;
Function RawUUID:String;
Var
UUIDVar: TGUID;
UUID_String: String;
k:Integer;
Begin
CoCreateGuid(UUIDVar);
UUID_String:=IntToHex(UUIDVar.D1, 8)+
IntToHex(UUIDVar.D2, 4)+
IntToHex(UUIDVar.D3, 4);
for k := 0 to 1 do UUID_String:=UUID_String+IntToHex(UUIDVar.D4[k], 2);
for k := 2 to 7 do UUID_String:=UUID_String+IntToHex(UUIDVar.D4[k], 2);
Result:=UUID_String;
End;
Function MakeUUIDPacked:String;
Var
UUIDVar: TGUID;
Begin
CoCreateGuid(UUIDVar);
SetLength(Result,16);
Move(UUIDVar.D1,Result[1],4);
Move(UUIDVar.D2,Result[5],2);
Move(UUIDVar.D3,Result[7],2);
Move(UUIDVar.D4,Result[9],8);
End;
{$ENDIF}
{$IFDEF LINUX}
Function CoCreateGuid(var GUID:TGUID):HResult;
Begin
Result:=CreateGUID(GUID);
End;
{$ENDIF}
///////////////////////////////////////////////////////////////////////////////
// Numeric Routines
///////////////////////////////////////////////////////////////////////////////
Function IsCharAlphaNumeric(Const C:char):Boolean;
Begin
{$IFNDEF ASM8086}
Result:=C in ['0'..'9','A'..'Z','a'..'z'];
{$ELSE} // ASM CODE BY OZZ
asm
mov AL,C
cmp AL, $30 // 0
jl @NoMatch // it's before '0' so Result=False/Exit
cmp AL, $7A // z
jg @NoMatch // it's after 'z' so Result=False/Exit
cmp AL, $39 // 9
jg @TryAlpha // it's after '9' so see if it is Alpha now
jmp @Matched // it's 0..9 so Result=True/Exit
@TryAlpha:
cmp AL, $41 // A
jl @NoMatch // it's before 'A' so Result=False/Exit
cmp AL, $5A // Z
jg @TryLower // it's after 'Z' so see if it is lowecase Alpha
jmp @Matched // it's 'A'..'Z' so Result=True/Exit
@TryLower:
cmp AL, $61 // a
jl @NoMatch // it's before 'a' so Result=False/Exit
jmp @Matched // it's 'a'..'z' so Result=True/Exit
@NoMatch:
mov Result,0
jmp @TheEnd
@Matched:
mov Result,1
@TheEnd:
end {asm}
{$ENDIF}
End;
Function IsCharAlpha(Const c:Char):Boolean;
Begin
{$IFNDEF ASM8086}
Result:=C in ['A'..'Z','a'..'z'];
{$ELSE} // ASM BY OZZ
asm
mov AL,C
cmp AL, $41 // A
jl @NoMatch // it's before 'A' so Result=False/Exit
cmp AL, $7A // z
jg @NoMatch // it's after 'z' so Result=False/Exit
cmp AL, $5A // Z
jg @TryLower // it's after 'Z' so see if it is lower now
jmp @Matched // it's A..Z so Result=True/Exit
@TryLower:
cmp AL, $61 // a
jl @NoMatch // it's before 'a' so Result=False/Exit
jmp @Matched // it's 'a'..'z' so Result=True/Exit
@NoMatch:
mov Result,0
jmp @TheEnd
@Matched:
mov Result,1
@TheEnd:
end {asm}
{$ENDIF}
End;
Function IsNumeric(Const c:char):Boolean;
begin
{$IFNDEF ASM8086}
Result:=IsCharAlphaNumeric(c) and not IsCharAlpha(c);
{$ELSE} // ASM BY OZZ
asm
mov AL,C
cmp AL, $30 // 0
jl @NoMatch // it's before '0' so Result=False/Exit
cmp AL, $39 // 9
jg @NoMatch // it's after '9' so Result=False/Exit
jmp @Matched // it's 0..9 so Result=True/Exit
@NoMatch:
mov Result,0
jmp @TheEnd
@Matched:
mov Result,1
@TheEnd:
end {asm}
{$ENDIF}
end;
Function isNumericString(Const S:String):Boolean;
Var
Loop,MaxLoop:Integer;
begin
Result:=True;
MaxLoop:=Length(S);
Loop:=0;
While (Loop<MaxLoop) and (Result) do Begin
If S[Loop+1]<>'.' then
Result:=IsNumeric(S[Loop+1]);
Inc(Loop);
End;
end;
Function Min(Const I1,I2:Integer):Integer;
Begin
{$IFNDEF ASM8086}
If I1<I2 then Result:=I1
Else Result:=I2;
{$ELSE} // ASM BY OZZ
Result:=I1;
asm
mov ECX, I2 // Store I2 in ECX
mov EDX, I1 // Store I1 in EDX
cmp EDX, ECX // compare I2 to I1
jl @TheEnd // if I2<I1 then Exit {result already set}
@ItIsLess:
mov Result,ECX // result=I2/Exit
@TheEnd:
end; {asm}
{$ENDIF}
End;
Function Max(Const I1,I2:Integer):Integer;
Begin
{$IFDEF ASM8086}
If I1>I2 then Result:=I1
Else Result:=I2;
{$ELSE} // ASM BY OZZ
Result:=I1;
asm
mov ECX, I2 // Store I2 in ECX
mov EDX, I1 // Store I1 in EDX
cmp EDX, ECX // compare I2 to I1
jg @TheEnd // if I2>I1 then Exit {result already set}
@ItIsLess:
mov Result,ECX // result=I2/Exit
@TheEnd:
end; {asm}
{$ENDIF}
End;
Function StringToInteger(Const S:String):Integer;
var
E: Integer;
begin
Val(S,Result,E);
End;
Procedure SwapMove(Source:Word;Var Dest);
Begin
Source:=(HI(Source))+(LO(Source)*256);
Move(Source,Dest,2);
End;
Function IntToCommaStr(Const Number:Integer):String;
Var
StrPos:Integer;
Begin
Result:=IntToStr(Number);
StrPos:=Length(Result)-2;
While StrPos>1 Do Begin
Insert(',',Result,StrPos);
StrPos:=StrPos-3;
End;
End;
Function BinaryToString(Const Number:Byte):String;
Var
Temp2:Byte;
i:Word;
Begin
Setlength(Result,8);
FillChar(Result[1],8,'0');
Temp2:=$80;
For i := 1 to 8 Do Begin
If (Number and Temp2)<>0 Then Result[i]:='1';
Temp2:=Temp2 shr 1;
End;
End;
Function StringToBinary(S:String):Byte;
Var
i:Word;
Temp1:Byte;
Temp2:Byte;
Begin
S:=Trim(S);
While Length(S)<8 do S:='0'+S;
Temp1:=0;
Temp2:=$80;
For i := 1 to 8 Do Begin
If S[i]='1' Then Inc(Temp1,Temp2);
Temp2:=Temp2 shr 1;
End;
Result:=Temp1;
End;
///////////////////////////////////////////////////////////////////////////////
// String Routines
///////////////////////////////////////////////////////////////////////////////
function QuickPos(const aFindString,aSourceString:String):integer;
var
SourceLen,aSourceLen,aFindLen,StartPos:integer;
begin
{$IFNDEF ASM8086}
Result:=Pos(aFindString,aSourceString);
{$ELSE}
Result:=0;
aSourceLen:=Length(aSourceString);
If aSourceLen=0 then Exit;
aFindLen:=Length(aFindString);
If (aFindLen=0) or (aFindlen>AsourceLen) then Exit; {GSW FIX!}
StartPos:=1;
SourceLen:=aSourceLen-aFindLen;
SourceLen:=(SourceLen-StartPos)+2;
asm
push ESI
push EDI
push EBX
mov EDI, aSourceString
add EDI, StartPos
dec EDI
mov ESI, aFindString
mov ECX, SourceLen
mov Al, [ESI]
@ScaSB:
mov Ah, [EDI]
cmp Ah,Al
jne @NextChar
@CompareStrings:
mov EBX, aFindLen
dec EBX
jz @FullMatch
@CompareNext:
mov Al, [ESI+EBX]
mov Ah, [EDI+EBX]
cmp Al, Ah
jz @Matches
mov Al, [ESI]
jmp @NextChar
@Matches:
dec EBX
jnz @CompareNext
@FullMatch:
mov EAX, EDI
sub EAX, aSourceString
inc EAX
mov Result, EAX
jmp @TheEnd
@NextChar:
inc EDI
dec ECX
jnz @ScaSB
mov Result,0
@TheEnd:
pop EBX
pop EDI
pop ESI
end; {asm}
{$ENDIF}
end;
function CharPos(const C:Char;const aSource:String):Integer;
var
L : Integer;
begin
L := Length(aSource);
Result:=0;
if L = 0 then exit;
asm
PUSH EDI //Preserve this register
mov EDI, aSource //Point EDI at aSource
mov ECX, L //Make a note of how many chars to search through
mov AL, C //and which char we want
@Loop:
mov AH, [EDI]
inc EDI
xor AH, AL
jz @Found
dec ECX
jnz @Loop
jmp @NotFound
@Found:
sub EDI, aSource //EDI has been incremented, so EDI-OrigAdress = Char pos !
mov Result, EDI
jmp @TheEnd
@NotFound:
mov Result, 0 // fix (ozz)
@TheEnd:
POP EDI
end;
end;
Function Fetch(var S:String;Const Sub:String;Const IgnoreCase:Boolean):String;
var
P:Integer;
begin
If IgnoreCase then P:=QuickPos(Uppercase(Sub),Uppercase(S))
Else P:=QuickPos(Sub,S);
if (P=0) then Begin
Result:=S;
S:='';
End
Else Begin
Result:=Copy(S,1,P-1);
Delete(S,1,P+(Length(Sub)-1));
End;
end;
Function FetchByChar(var S:String;Const Sub:Char;Const IgnoreCase:Boolean):String;
var
P:Integer;
begin
If IgnoreCase then P:=CharPos(Upcase(Sub),Uppercase(S))
Else P:=CharPos(Sub,S);
if (P=0) then Begin
Result:=S;
S:='';
End
Else Begin
Result:=Copy(S,1,P-1);
Delete(S,1,P);
End;
end;
Function Uppercase(Const S:String):String;
{$IFNDEF ASM8086}
var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:=S;
MaxLoop:=Length(Result);
For Loop:=MaxLoop downto 1 do
If Result[Loop] in ['a'..'z'] then Dec(Result[Loop],32);
End;
{$ELSE} // Ozz: tweaked to use Pointer() which is faster than @string!
var
LenOfString:Integer;
FirstSource,FirstDest:Pointer;
begin
LenOfString:=Length(S);
If LenOfString=0 then Begin
Result:='';
Exit;
End;
SetLength(Result,LenOfString);
FirstSource:=Pointer(s);
FirstDest:=Pointer(Result);
asm
PUSH ESI //Firstly and most importantly
PUSH EDI //Delphi uses EBX, ESI, EDI extensively, so we need to
//push them onto the stack, and then pop them off after
mov ESI, FirstSource//Move the address of Result into ESI
mov EDI, FirstDest //ESI and EDI are 2 generic "data moving" registers
//ESI = Source, EDI = Destination
//MovSB (MoveString Byte, there is also, MovSW word and MovSD double)
//MovXX copy from EDI to ESI, and then INC *both* ESI and EDI
// and also DEC ECX (generic string length counter)
//But I will not use these as I need to Uppercase the results
mov ECX, LenOfString//ECX will contain a count of how many chars left to do
@NextChar:
mov AL, [ESI] //Move ESI^ into AL
// AL = Char, AX = Word, EAX = DWord, all different parts
// of the same register
cmp AL, $61
jl @NoUpper // < 'a' don't convert
cmp AL, $7A
jg @NoUpper // > 'z' don't convert
and AL, $DF // Convert to uppercase
@NoUpper:
mov [EDI], AL // Put AL back into EDI^ (That's what [] means)
Inc ESI //Point to next character
Inc EDI
Dec ECX //Decrement the count, if it reaches 0, the ZERO flag will be set
jnz @NextChar //"J"ump if "n"ot "z"ero to the next character
POP EDI
POP ESI
end; {asm}
end;
{$ENDIF}
Function Lowercase(Const S:String):String;
{$IFNDEF ASM8086}
var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:=S;
MaxLoop:=Length(Result);
For Loop:=MaxLoop downto 1 do
If Result[Loop] in ['A'..'Z'] then Inc(Result[Loop],32);
End;
{$ELSE} // Original ASM By Peter for UPPERCASE, Ozz added xor logic for LOWERCASE
var
LenOfString:Integer;
FirstSource,FirstDest:Pointer;
begin
LenOfString:=Length(S);
If LenOfString=0 then Begin
Result:='';
Exit;
End;
SetLength(Result,LenOfString);
FirstSource:=Pointer(S);
FirstDest:=Pointer(Result);
asm
PUSH ESI //Firstly and most importantly
PUSH EDI //Delphi uses EBX, ESI, EDI extensively, so we need to
//push them onto the stack, and then pop them off after
mov ESI, FirstSource//Move the address of Result into ESI
mov EDI, FirstDest //ESI and EDI are 2 generic "data moving" registers
//ESI = Source, EDI = Destination
//MovSB (MoveString Byte, there is also, MovSW word and MovSD double)
//MovXX copy from EDI to ESI, and then INC *both* ESI and EDI
// and also DEC ECX (generic string length counter)
//But I will not use these as I need to Uppercase the results
mov ECX, LenOfString//ECX will contain a count of how many chars left to do
@NextChar:
mov AL, [ESI] //Move ESI^ into AL
// AL = Char, AX = Word, EAX = DWord, all different parts
// of the same register
cmp AL, 'A'
jl @NoUpper // < 'a' don't convert
cmp AL, 'Z'
jg @NoUpper // > 'z' don't convert
xor AL, $20 // Convert to lowercase
@NoUpper:
mov [EDI], AL // Put AL back into EDI^ (That's what [] means)
Inc ESI //Point to next character
Inc EDI
Dec ECX //Decrement the count, if it reaches 0, the ZERO flag will be set
jnz @NextChar //"J"ump if "n"ot "z"ero to the next character
POP EDI
POP ESI
end; {asm}
end;
{$ENDIF}
Function ProperCase(Const S:String):String;
Var
Len:Integer;
MaxLen:Integer;
Begin
Len:=Length(S);
MaxLen:=Len;
SetLength(Result,Len);
Result:=Lowercase(S);
While Len>0 do Begin
If Not (Result[Len] in ['a'..'z']) and (Len<MaxLen) then
Result[Len+1]:=Upcase(Result[Len+1]);
Dec(Len);
End;
If (MaxLen>0) and (Result[1] in ['a'..'z']) then
Result[1]:=Upcase(Result[1]);
End;
Function Trim(const S:string):string;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] <= ' ') do Inc(I);
if I > L then Result := ''
else begin
while S[L] <= ' ' do Dec(L);
Result := Copy(S, I, L - I + 1);
end;
end;
Function NoCRLF(Const S:String):String;
Begin
Result:=StringReplace(S,#13#10,'',[rfReplaceAll]);
End;
Function NoAngleBrackets(Const S:string):string;
var
LenOfStr:Integer;
Begin
Result:=S;
LenOfStr:=Length(Result);
If LenOfStr>1 then
If (Result[1]='<') and (Result[LenOfStr]='>') then
Result:=Copy(Result,2,LenOfStr-2);
End;
// Known Commands should be a 0 based array!
// For testing Winshoes products against ours, this command is useless to our
// engine. We use a dynamic parser which provides a much more flexible
// development solution for you.
Function InStrArray(const SearchStr:string;Const KnownCommands:Array of String):Integer;
begin
for Result:=High(KnownCommands) downto Low(KnownCommands) do
if SearchStr=KnownCommands[Result] then Exit;
Result:=-1;
end;
Procedure InverseString(Var S:String;Count:Integer);
Var
TmpStr:String;
Ctr:Integer;
Ch:Char;
Begin
TmpStr:=Copy(S,1,Count);
Ctr:=0;
While Count>0 do Begin
Ch:=TmpStr[Count];
Dec(Count);
Move(Ch,S[Ctr+1],1);
Inc(Ctr);
End;
End;
Function HexDump(Const S:String):String;
var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:='';
Loop:=0;
MaxLoop:=Length(S);
While Loop<MaxLoop do Begin
Result:=Result+IntToHex(Ord(S[Loop+1]),2)+#32;
Inc(Loop);
End;
End;
Function ReplaceChar(const Source:string;Const OldChar,NewChar:Char):string;
var
Loop:Integer;
begin
Result:=Source;
if OldChar=NewChar then Exit;
Loop:=Length(Source);
While Loop>0 do Begin
if Result[Loop]=OldChar then Result[Loop]:=NewChar;
Dec(loop);
End;
end;
Function ExtractLeft(const aSourceString:String;Const Size:Integer):String;
begin
If Size>Length(aSourceString) then Result:=aSourceString
Else Begin
Setlength(Result,Size);
Move(aSourceString[1],Result[1],Size);
End;
end;
Function ExtractRight(const aSourceString:String;Const Size:Integer):String;
Var
Len:Integer;
begin
Len:=Length(aSourceString);
If Size>Len then Result:=aSourceString
Else Begin
Setlength(Result,Size);
Move(aSourceString[Len-Pred(Size)],Result[1],Size);
End;
end;
Function ExtractWordAt(Const Text:String;Position:Integer):String;
Var
Done:Boolean;
StartAt:Integer;
Len:Integer;
OrgPosition:Integer;
begin
Len:=Length(Text);
Result:='';
Done:=Not (UpCase(Text[Position]) in ['A'..'Z','0'..'9']);
If (Position>0) and (Position<=Len) and not Done then Begin
OrgPosition:=Position;
While (Position>0) and not Done do Begin
Done:=Not (UpCase(Text[Position]) in ['A'..'Z','0'..'9']);
If Not Done then Dec(Position);
End;
StartAt:=Position;
Position:=OrgPosition;
Done:=False;
While (Position<=Len) and not Done do Begin
Done:=Not (UpCase(Text[Position]) in ['A'..'Z','0'..'9']);
If Not Done then Inc(Position);
End;
Result:=Copy(Text,StartAt+1,Pred(Position)-StartAt);
End;
end;
Function LeftJustify(Const S:String;Const MaxLength:Integer):String;
Begin
Result:=LeftJustifyCh(S,#32,MaxLength);
End;
Function RightJustify(Const S:String;Const MaxLength:Integer):String;
Begin
Result:=RightJustifyCh(S,#32,MaxLength);
End;
Function CleanChar(Const InChar:Char):Char;
Const
CtlChars: String[32] = 'oooooooooXoollo><|!Pg*|^v><-^v';
HiChars: String[64] = 'CueaaaageeeiiiAAEaaooouuyOUcLYPfarounNao?--//!<>***|||||||||||||';
HiChars2: String[64]= '|--|-+||||=+|=++-=--==-||||*****abcnEduto0nd80En=+><fj/~oo.vn2* ';
Begin
Case InChar of
#0..#31:Result:=CtlChars[Ord(InChar)+1];
#128..#191:Result:=HiChars[Ord(InChar) - 127];
#192..#255:Result:=HiChars2[Ord(InChar) - 191];
Else
Result:=InChar;
End;
End;
Function CleanStr(Const InStr:String):String;
Begin
Result:='';
While Length(Result)<Length(InStr) do
Result:=Result+CleanChar(InStr[Length(Result)+1]);
End;
Function PosLastChar(Const Ch:Char;Const S:String):Integer;
Var
I:Integer;
Begin
i:=Length(S);
While ((i>0) and (s[i]<>ch)) Do Dec(i);
Result:=I;
End;
Function AsciiToOem(Const ax:String):String;
var
i:integer;
begin
Result:=AX;
for i:=Length(Result) downto 1 do begin
Case Ord(Result[i]) of
132:Result[i]:=Char(228);
142:Result[i]:=Char(196);
129:Result[i]:=Char(252);
154:Result[i]:=Char(220);
148:Result[i]:=Char(246);
153:Result[i]:=Char(214);
225:Result[i]:=Char(223);
end;
end;
end;
Function OemToAscii(const ax:String):String;
var
i:integer;
begin
Result:=AX;
for i:=Length(Result) downto 1 do begin
Case Ord(Result[i]) of
228:Result[i]:=Char(132);
196:Result[i]:=Char(142);
252:Result[i]:=Char(129);
220:Result[i]:=Char(154);
246:Result[i]:=Char(148);
214:Result[i]:=Char(153);
223:Result[i]:=Char(225);
end;
end;
end;
Function WordCount(Const S:string):Integer;
var
I,Len:Integer;
begin
Len:=Length(S);
Result:=0;
I:=1;
while I<=Len do begin
while (i<=len) and ((S[i]=#32) or (S[i]=#9) or (S[i]=';')) do inc(i);
if I<=len then inc(Result);
while (I<=len) and (S[i]<>#32) and (S[i]<>#9) and (S[i]<>';') do inc(i);
end;
End;
Function CRC32ByChar(const Ch:Char;const starting_crc:LONGINT):LONGINT;
Begin
Result:=crc_32_tab[BYTE(starting_crc XOR LONGINT(Ord(Ch)))] XOR ((starting_crc SHR 8) AND $00FFFFFF)
End;
Function CRC32ByString(Const S:String;Const starting_crc:LONGINT):LONGINT;
Var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:=starting_crc;
MaxLoop:=Length(S);
For Loop:=1 to MaxLoop do
Result:=CRC32ByChar(S[Loop],Result);
End;
Function CRC16ByChar(const Ch:Char;const starting_crc:word):word;
Begin
Result:=crc_16_tab[BYTE(starting_crc XOR Word(Ord(Ch)))] XOR ((starting_crc SHR 8) AND $00FF)
End;
Function CRC16ByString(const S:String;const starting_crc:word):word;
Var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:=starting_crc;
MaxLoop:=Length(S);
For Loop:=1 to MaxLoop do
Result:=CRC16ByChar(S[Loop],Result);
End;
Function CRCARCByChar(const Ch:Char;const starting_crc:word):word;
Begin
Result:=crc_arc_tab[BYTE(starting_crc XOR Word(Ord(Ch)))] XOR ((starting_crc SHR 8) AND $00FF)
End;
Function CRCARCByString(const S:String;const starting_crc:word):word;
Var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:=starting_crc;
MaxLoop:=Length(S);
For Loop:=1 to MaxLoop do
Result:=CRCARCByChar(S[Loop],Result);
End;
Procedure SetLongBit(Var L:LongInt;Const Bit:Byte;Const Setting:Boolean);
Var
Mask:LongInt;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
If Setting Then L:=L or Mask
Else L:=(L and (Not Mask));
End;
Function GetLongBit(const L:LongInt;const Bit:Byte):Boolean;
Var
Mask:LongInt;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
Result:=(L and Mask)<>0;
End;
Procedure SetWordBit(Var L:Word;const Bit:Byte;const Setting:Boolean);
Var
Mask:Word;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
If Setting Then L:=L or Mask
Else L:=(L and (Not Mask));
End;
Function GetWordBit(const L:Word;const Bit:Byte):Boolean;
Var
Mask:Word;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
Result:=(L and Mask)<>0;
End;
Procedure SetByteBit(Var L:Byte;const Bit:Byte;const Setting:Boolean);
Var
Mask:Byte;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
If Setting Then L:=L or Mask
Else L:=(L and (Not Mask));
End;
Function GetByteBit(const L:Byte;const Bit:Byte):Boolean;
Var
Mask:Byte;
Begin
Mask:=1;
Mask:=Mask Shl (Bit-1);
Result:=(L and Mask)<>0;
End;
Function Replicate(const Source:String;NumberOfTimes:Integer):String;
Var
SourceLength:Integer;
Dest:Integer;
Begin
// designed this way, for BIG strings!
Dest:=1;
SourceLength:=Length(Source);
SetLength(Result,SourceLength * NumberOfTimes);
While NumberOfTimes>0 do Begin
Move(Source[1],Result[Dest],SourceLength);
Inc(Dest,SourceLength);
Dec(NumberOfTimes);
End;
End;
Function IsWildCard(const Source:String):Boolean;
Begin
Result:=CharPos('*',Source)+CharPos('?',Source)+CharPos('%',Source)>0;
End;
///////////////////////////////////////////////////////////////////////////////
// Internet Routines
///////////////////////////////////////////////////////////////////////////////
Function GetIndex(Const c:char):Integer;
var
i:Integer;
{$IFDEF ASM8086}
S:String;
{$ENDIF}
begin
{$IFNDEF ASM8086}
i:=CharPos(c,Alphabet); //overkill for just 1 character
{$ELSE}
S := Alphabet;
asm
PUSH EDI //Preserve this register
mov EDI, S //Point EDI at Alphabet string
mov ECX, AlphaBetLength //Tell CPU how big Alphabet is
mov AL, C //and which char we want
RepNE ScaSB //"Rep"eat while "N"ot "E"qual
//this is the same as
//While (EDI^ <> AL) and (ECX>0) do begin
// Inc(EDI);
// Dec(ECX);
//end;
jnz @NotFound //Zero flag will be set if there was a match
sub EDI, S //EDI has been incremented, so EDI-OrigAdress = Char pos !
mov I, EDI
@NotFound:
POP EDI
end;
{$ENDIF}
if (i>0) then Dec(i);
result:=i;
end;
//gsw and ozz
function DecodeUnit(Const InStr:String):ShortString;
var
a,b,c,d:Byte;
begin
a:=GetIndex(InStr[1]);
b:=GetIndex(InStr[2]);
If InStr[3]='=' then Begin
SetLength(Result,1);
result[1]:=chr((a shl 2) or (b shr 4));
end
Else If InStr[4]='=' then Begin
SetLength(Result,2);
c:=GetIndex(InStr[3]);
result[1]:=chr((a shl 2) or (b shr 4));
result[2]:=chr((b shl 4) or (c shr 2));
End
Else Begin
c:=GetIndex(InStr[3]);
d:=GetIndex(InStr[4]);
SetLength(result,3);
result[1]:=chr((a shl 2) or (b shr 4));
result[2]:=chr((b shl 4) or (c shr 2));
result[3]:=chr((c shl 6) or d);
End;
end;
Function Base64ToString(Const S:String):String;
var
i:Integer;
begin
Result:='';
for i:=((Length(s) div 4)-1) downto 0 do
Result:=DecodeUnit(Copy(s,i*4+1,4))+Result;
end;
Function StringToBase64(Const S1:String):String;
Const
Table:String='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
I,K,L: Word;
S: String;
begin
L := Length(S1);
if L mod 3 <> 0 then Inc(L, 3);
SetLength(S,(L div 3) * 4);
FillChar(S[1], Length(S), '=');
I := 0;
K := 1;
while I < Length(S1) do
begin
S[K] := Table[1+(Ord(S1[I+1]) shr 2)];
S[K+1] := Table[1+(((Ord(S1[I+1]) and $03) shl 4) or (Ord(S1[I+2]) shr 4))];
if I+1 >= Length(S1) then Break;
S[K+2] := Table[1+(((Ord(S1[I+2]) and $0F) shl 2) or (Ord(S1[I+3]) shr 6))];
if I+2 >= Length(S1) then Break;
S[K+3] := Table[1+(Ord(S1[I+3]) and $3F)];
Inc(I, 3);
Inc(K, 4);
end;
Result := S;
End;
{Function StringToBase64(Const S1:String):String;
Const
Table:String='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
B:Array[0..65000] of Byte;
I,K,L: Word;
S: String;
begin
FillChar(B, SizeOf(B), 0);
Move(S1[1], B, Length(S1));
L := Length(S1);
if L mod 3 <> 0 then Inc(L, 3);
// S[0] := Char((L div 3) * 4);
SetLength(S,(L div 3) * 4);
FillChar(S[1], Length(S), '=');
I := 0;
K := 1;
while I < Length(S1) do
begin
S[K] := Table[1+(B[I] shr 2)];
S[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
if I+1 >= Length(S1) then Break;
S[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
if I+2 >= Length(S1) then Break;
S[K+3] := Table[1+(B[I+2] and $3F)];
Inc(I, 3); Inc(K, 4);
end;
Result := S;
End;}
function FixDottedIP(Const S:string):string;
var
n:Cardinal;
begin
Result:='.'+S;
n:=QuickPos('.0',Result);
while n>0 do begin
Delete(Result,n+1,1);
n:=QuickPos('.0',Result);
end;
n:=QuickPos('..',Result);
While N>0 do begin
Insert('0',Result,n+1);
n:=QuickPos('..',Result);
End;
If Result[Length(Result)]='.' then Result:=Result+'0';
Delete(Result,1,1);
end;
Function IPStringFormated(S:String):String;
Var
n1,n2,n3,n4:Integer;
Begin
N1:=StrToInt(Copy(S,1,CharPos('.',S)-1));
Delete(S,1,CharPos('.',S));
N2:=StrToInt(Copy(S,1,CharPos('.',S)-1));
Delete(S,1,CharPos('.',S));
N3:=StrToInt(Copy(S,1,CharPos('.',S)-1));
Delete(S,1,CharPos('.',S));
N4:=StringToInteger(S);
Result:=IPAddressFormatted(N1,N2,N3,N4);
End;
Function IPAddressFormatted(Const I1,I2,I3,I4:Integer):String;
Begin
Result:=IntToStr(I4);
While Length(Result)<3 do Result:='0'+Result;
Result:=IntToStr(I3)+'.'+Result;
While Length(Result)<7 do Result:='0'+Result;
Result:=IntToStr(I2)+'.'+Result;
While Length(Result)<11 do Result:='0'+Result;
Result:=IntToStr(I1)+'.'+Result;
While Length(Result)<15 do Result:='0'+Result;
End;
function EscapeDecode(Const S:String):String;
var
ch:Char;
val:String;
I:Integer;
begin
Result:=S;
I:=CharPos('%',Result);
While I>0 do Begin
Val:='$'+Copy(Result,I+1,2);
try
Ch:=Char(StrToInt(Val));
except
Ch:='a'; // 2.0.12
end;
Result:=Copy(Result,1,I-1)+Ch+Copy(Result,I+3,Length(Result));
I:=CharPos('%',Result);
End;
I:=CharPos('+',Result);
While I>0 do Begin
Result:=Copy(Result,1,I-1)+#32+Copy(Result,I+1,Length(Result));
I:=CharPos('+',Result);
End;
end;
Function EscapeEncode(Const S:String):String;
Var
Loop:Integer;
MaxLoop:Integer;
Begin
Result:='';
MaxLoop:=Length(S);
For Loop:=1 to MaxLoop do
If S[Loop] in ['0'..'9','.','-'] then Result:=Result+S[Loop] // 2.0.12
Else
If S[Loop]=#32 then Result:=Result+'+' //2.0.12 RC2
Else
If (S[Loop]<#21) or // 2.0.12 RC2
(S[Loop]>#127)
then Result:=Result+'%'+IntToHex(Ord(S[Loop]),2)
Else Result:=Result+S[Loop]
End;
Function EncodeDomain(S:String):String;
Var
Dot:Integer;
Begin
Result:='';
While (S<>'') do Begin
Dot:=CharPos('.',S);
Case Dot of
0:Begin
Result:=Result+Chr(Length(S))+S;
S:='';
End;
Else Begin
Result:=Result+Chr(Dot-1)+Copy(S,1,Dot-1);
Delete(S,1,Dot);
End;
End;
End;
Result:=Result+#0;
End;
Function EncodeAddress(S:String):String;
Var
Dot:Integer;
Begin
Result:='';
While (S<>'') do Begin
Dot:=Pos('.',S);
Case Dot of
0:Begin
Result:=Result+Chr(Length(S))+S;
S:='';
End;
Else Begin
Result:=Result+Chr(Dot-1)+Copy(S,1,Dot-1);
Delete(S,1,Dot);
End;
End;
End;
Result:=Result+#7'in-addr'#4'arpa'#0;
End;
Function DecodeDomain(S:String):String;
Var
L:Integer;
Begin
Result:='';
While Length(S)>0 do Begin
L:=Ord(S[1]);
If L>Length(S) then Begin
Result:='';
Exit;
End;
Result:=Result+Copy(S,2,L)+'.';
Delete(S,1,L+1);
End;
If Copy(Result,Length(Result),1)='.'Then Delete(Result,Length(Result),1);
End;
Function GetActualEmailAddress(Parm,Command:String):String;
Var
Colon,Quote:Integer;
begin
// posibilities are:
// [cmd]:<mailadrress>
// [cmd] :<mailadrress>
// [cmd]: <mailadrress>
// [cmd] : <mailadrress>
// [cmd] <mailadrress>
// [cmd]<mailadrress>
// you can also have "firstname lastname" in there also
Quote:=CharPos('"',Parm);
If Quote>0 then Begin
If CharPos('>',Parm)>Quote then Begin
Delete(Parm,1,Quote);
Delete(Parm,1,CharPos('"',Parm));
End
Else Begin // 2.3
Colon:=PosLastChar('"',Parm);
Delete(Parm,Quote,Colon-Pred(Quote));
End;
End;
// check if space, if so let remove everything before
Trim(Parm);
// ok now possibilities are:
// [cmd]:<mailadrress>
// :<mailadrress>
// : <mailadrress>
// [cmd]<mailadrress>
Colon:=CharPos(':',Parm);
// check if colon, if so let remove everything before
If Colon>0 then
Delete(Parm,1,Colon);
// ok now possibilities are:
// <mailadrress>
// [cmd]<mailadrress>
// now let check if we have a command
if lowercase(copy(parm,1,length(command)))=lowercase(command) then
delete(Parm,1,length(command));
// we trim to make sure we dont have any space left in there
Parm:=Trim(Parm);
// and return the result with no brackets
Result:=NoAngleBrackets(Parm);
End;
///////////////////////////////////////////////////////////////////////////////
// Date and/or Time Routines
///////////////////////////////////////////////////////////////////////////////
Function DayOfTheYear(const DT:TDateTime):Integer;
Var
J,Y:Word;
begin
DecodeDate(DT,Y,J,J);
Result:=Trunc(DT)-Trunc(EncodeDate(Y,1,1))+1;
end;
{$WARNINGS OFF}
Function DaysLeftThisYear(const DT:TDateTime):Integer;
Var
J,Y:Word;
begin
DecodeDate(DT,Y,J,J);
Case IsLeapYear(Y) of
True:Result:=366-DayOfTheYear(DT);
False:Result:=365-DayOfTheYear(DT);
End;
end;
{$WARNINGS ON}
Function DaysThisMonth(const DT:TDateTime):Integer;
Var
J,M,Y:Word;
begin
DecodeDate(DT,Y,M,J);
Case M of
2:If IsLeapYear(Y) then Result:=29
Else Result:=28;
4,6,9,11:Result:=30;
Else Result:=31;
End;
end;
Function DaysLeftThisMonth(const DT:TDateTime):Integer;
Var
J,M,Y:Word;
begin
DecodeDate(DT,Y,M,J);
Case M of
2:If IsLeapYear(Y) then Result:=29
Else Result:=28;
4,6,9,11:Result:=30;
Else Result:=31;
End;
Result:=Result-J;
end;
Function IsTimeAM(const DT:TDateTime):Boolean;
begin
Result:=Frac(DT)<0.5;
end;
Function IsTimePM(const DT:TDateTime):Boolean;
begin
Result:=Frac(DT)>0.5;
end;
Function IsTimeNoon(const DT:TDateTime):Boolean;
begin
Result:=Frac(DT)=0.5;
end;
Function IsTimeMidnight(const DT:TDateTime):Boolean;
begin
Result:=Frac(DT)=0.0;
end;
Function DateTimeToGMT(const DT:TDateTime):TDateTime;
begin
Result:=DT+LocalTimeZoneBias/1440;
end;
Function DateTimeToLocal(const DT:TDateTime):TDateTime;
begin
Result:=DT-LocalTimeZoneBias/1440;
end;
Function IsLeapYear(Const Year:Word):Boolean;
begin
Result:=((Year and 3)=0) and ((Year mod 100>0) or (Year mod 400=0));
end;
Function LocalTimeZoneBias:Integer;
{$IFDEF LINUX}
Var
TV:TTimeval;
TZ:TTimezone;
Begin
gettimeofday(TV,TZ);
Result:=TZ.tz_minuteswest;
End;
{$ELSE}
var
TimeZoneInformation:TTimeZoneInformation;
Bias:Longint;
begin
case GetTimeZoneInformation(TimeZoneInformation) of
TIME_ZONE_ID_STANDARD:Bias:=TimeZoneInformation.Bias+TimeZoneInformation.StandardBias;
TIME_ZONE_ID_DAYLIGHT:Bias:=TimeZoneInformation.Bias+((TimeZoneInformation.DaylightBias div 60)*-100);
else Bias:=TimeZoneInformation.Bias;
End;
Result:=Bias;
End;
{$ENDIF}
Function TimeZone:String;
{$IFDEF LINUX}
Begin
Result:=ShortTimeZone;
End;
{$ELSE}
var
lpTimeZoneInfo:TTimeZoneInformation;
Begin
Result:='';
If GetTimeZoneInformation(lpTimeZoneInfo)=TIME_ZONE_ID_STANDARD then
{$IFDEF VER90}
Result:=WideCharToString({@}Pointer(lpTimeZoneInfo.StandardName))
{$ELSE}
Result:=lpTimeZoneInfo.StandardName
{$ENDIF}
Else
If GetTimeZoneInformation(lpTimeZoneInfo)=TIME_ZONE_ID_DAYLIGHT then
{$IFDEF VER90}
Result:=WideCharToString({@}Pointer(lpTimeZoneInfo.DaylightName));
{$ELSE}
Result:=lpTimeZoneInfo.DaylightName;
{$ENDIF}
End;
{$ENDIF}
Function ShortTimeZone:String;
{$IFDEF LINUX}
var
T: TTime_T;
UT: TUnixTime;
begin
__time(@T);
localtime_r(@T, {$IFDEF FPC}@{$ENDIF}UT);
Result:=PChar(UT.__tm_zone);
End;
{$ELSE}
Var
TPos:Integer;
Begin
Result:=TimeZone;
TPos:=1;
While TPos<=Length(Result) do
If Not (Result[TPos] in ['A'..'Z']) then Delete(Result,TPos,1)
Else Inc(TPos);
End;
{$ENDIF}
Function TimeZoneBias:String; // this correct? 2.0.12
Begin
Result:=IntToStr(LocalTimeZoneBIAS);
While Length(Result)<4 do Result:='0'+Result;
If IsNumeric(Result[1]) then Result:='-'+Result;
End;
Function ToUnixSlashes(Const S:String):String;
{.$IFNDEF ASM8086}
var
Loop:Integer;
MaxLoop:Integer;
begin
Result:=S;
MaxLoop:=Length(Result);
For Loop:=1 to MaxLoop do If Result[Loop]='\' then Result[Loop]:='/';
end;
(*
{$ElSE}
Var
LenOfResult:Integer;
FirstChar:Pointer;
Begin
Result:=S;
LenOfResult:=Length(Result);
If LenOfResult<1 then Exit; //2.4
FirstChar:=Pointer(Result);
asm
push ESI
mov ESI, FirstChar;
mov ECX, LenOfResult
@Loop:
mov Al, [ESI]
cmp Al, '\'
jne @NoChange
mov Al, '/'
mov [ESI], Al
@NoChange:
Inc ESI
Dec ECX
jnz @Loop
pop ESI
end;
End;
{$ENDIF}
*)
Function ToDOSSlashes(Const S:String):String;
{.$IFNDEF ASM8086}
var
Loop:Integer;
MaxLoop:Integer;
begin
Result:=S;
MaxLoop:=Length(Result);
For Loop:=1 to MaxLoop do If Result[Loop]='/' then Result[Loop]:='\';
end;
(*
{$ElSE}
Var
LenOfResult:Integer;
FirstChar:Pointer;
Begin
Result:=S;
LenOfResult:=Length(Result);
If LenOfResult<1 then Exit; //2.0.12 RC2
FirstChar:=Pointer(Result);
asm
push ESI
mov ESI, FirstChar;
mov ECX, LenOfResult
@Loop:
mov Al, [ESI]
cmp Al, '/'
jne @NoChange
mov Al, '\'
mov [ESI], Al
@NoChange:
Inc ESI
Dec ECX
jnz @Loop
pop ESI
end;
End;
{$ENDIF}
*)
Function ToOSSlashes(Const S:String):String; // 2.3
Begin
{$IFDEF LINUX}
Result:=ToUnixSlashes(S);
{$ELSE}
Result:=ToDOSSlashes(S);
{$ENDIF}
End;
(******************************************************************************
CHANGEDIR: {Rewritten to call Windows.API for the result!}
The GetFullPathName function merges the name of the current drive and
directory with the specified filename to determine the full path and
filename of the specified file. It also calculates the address of the
filename portion of the full path and filename. This function does not
verify that the resulting path and filename are valid or that they
refer to an existing file on the associated volume.
******************************************************************************)
Function ChangeDir(Const S,RP:String):String;
{$IFDEF LINUX}
Begin
Result:=''; // redesign
End;
{$ELSE}
var
FileName:String;
FName: PChar;
Buffer: array[0..MAX_PATH - 1] of Char;
begin
FileName:=ToDOSSlashes(S+RP);
SetString(Result,Buffer,GetFullPathName(PChar(FileName),SizeOf(Buffer),
Buffer,FName));
End;
{$ENDIF}
Function DateTimeToGMTRFC822(Const DT:TDateTime):String;
Begin
Result:=FormatDateTime('ddd, dd mmm yyyy hh:nn:ss',DateTimeToGMT(DT))+' GMT';
End;
Function DateTimeToGMTRFC850(Const DT:TDateTime):String;
Begin
Result:=FormatDateTime('dddd, dd-mmm-yy hh:nn:ss',DateTimeToGMT(DT))+' GMT';
End;
Function DateTimeToRFC850(Const DT:TDateTime):String;
Begin
Result:=FormatDateTime('dddd, dd-mmm-yy hh:nn:ss',DT)+#32+ShortTimeZone;
End;
Function DateTimeToRFC850Bias(Const DT:TDateTime):String;
Begin
Result:=FormatDateTime('ddd, dd mmm yyyy hh:nn:ss',DT)+#32+TimeZoneBias;
End;
Function RFCToDateTime(S:String):TDateTime;
Var
M,D,Y:Word;
H,N,Sc,T:Word;
Ch,CHtag:Char;
Ts:String;
PosCh:integer;
Begin
// added bu gsw
posch:=CharPos(';',S);
if posch>0 then
delete(s,posCH,length(s)-posCh+1);
//
T:=0;
// Figure out which format S is...
Ch:=S[3];
S:=Uppercase(S);
If Ch=#32 then Begin // ANSI C ASCTIME()
Delete(S,1,4); {remove DDD#32}
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS));
S:=Trim(S);
M:=QuickPos(TS,#32#32'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC') div 3;
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
D:=StrToInt(TS);
except
D:=1;
end;
Ch:=S[3];
If Ch<>':' then Begin {timestamp was not where we expected it, so it must be YEAR}
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Y:=StrToInt(TS);
except
DecodeDate(Now,Y,T,T);
T:=0;
end;
End;
Ts:=Copy(S,1,CharPos(':',S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
H:=StrToInt(TS);
Except
H:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
N:=StrToInt(TS);
Except
N:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Sc:=StrToInt(TS);
Except
Sc:=0;
End;
If S<>'' then Begin {just insase it is setup wrong}
Ch:=S[1];
If Ch in ['0'..'9'] then Begin
try
Y:=StrToInt(S);
except
DecodeDate(Now,Y,T,T);
T:=0;
end;
End;
End;
End
Else if Ch=',' then Begin // RFC 822 or RFC 1123
Delete(S,1,CharPos(#32,S));
S:=Trim(S);
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
D:=StrToInt(TS);
except
D:=1;
end;
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
M:=QuickPos(TS,#32#32'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC') div 3;
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Y:=StrToInt(TS);
except
DecodeDate(Now,Y,T,T);
T:=0;
end;
Ts:=Copy(S,1,CharPos(':',S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
H:=StrToInt(TS);
Except
H:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
N:=StrToInt(TS);
Except
N:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Sc:=StrToInt(TS);
Except
Sc:=0;
End;
End
Else
Begin // RFC 850 or RFC 1036
Delete(S,1,CharPos(#32,S));
S:=Trim(S);
// added by Gsw
chtag:='-';
posCh:=charpos(chtag,S);
if (posCH>0) and (posCh<5) then
chtag:='-'
else
chtag:=' ';
//
Ts:=Copy(S,1,CharPos(chtag,S)-1); // mod by gsw
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
D:=StrToInt(TS);
except
D:=1;
end;
Ts:=Copy(S,1,CharPos(chtag,S)-1); // mod by gsw
Delete(S,1,Length(TS)+1);
S:=Trim(S);
M:=QuickPos(TS,#32#32'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC') div 3;
Ts:=Copy(S,1,CharPos(#32,S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Y:=StrToInt(TS);
except
DecodeDate(Now,Y,T,T);
T:=0;
end;
Ts:=Copy(S,1,CharPos(':',S)-1);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
H:=StrToInt(TS);
Except
H:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
N:=StrToInt(TS);
Except
N:=0;
End;
Ts:=Copy(S,1,2);
Delete(S,1,Length(TS)+1);
S:=Trim(S);
try
Sc:=StrToInt(TS);
Except
Sc:=0;
End;
End;
// Clean up non-century type timestamps.
If Y<100 then Begin
DecodeDate(Now,Y,T,T);
{ If Y>1999 then Y:=Y+2000
Else Y:=Y+1900;} {2.0.h}
End;
try // added by gsw
Result:=EncodeDate(Y,M,D)+EncodeTime(H,N,Sc,T);
except
result:=now;
end;
End;
PROCEDURE UNPACKTIME(Const P:LONGINT;VAR DT:TDATETIME);
BEGIN
DT:=FILEDATETODATETIME(P);
END;
PROCEDURE PACKTIME(VAR DT:TDATETIME;VAR P:LONGINT);
BEGIN
P:=DATETIMETOFILEDATE(DT);
END;
Function GetDosDate: LongInt;
Begin
Result:=DATETIMETOFILEDATE(Now);
End;
Function GetDOW:Word;
Begin
Result:=DayOfWeek(Now);
End;
Function TimeOut(Const MyTime:DWord):Boolean;
Begin
Result:=MyTime<=TimeCounter;
End;
Function TimeCounter:DWord;
{$IFDEF LINUX}
Var
TV:TTimeval;
Begin
gettimeofday(TV,nil);
Result:=(TV.tv_sec*1000)+(TV.tv_usec div 1000);
End;
(* the following code returns EPOCH
var
T: TTime_T;
begin
__time(@T);
Result:=T;
end;
//*)
{$ELSE}
Var
lpSystemTimeAsFileTime:TFileTime;
X:Cardinal;
Begin
GetSystemTimeAsFileTime(lpSystemTimeAsFileTime);
{$WARNINGS OFF}
If lpSystemTimeAsFileTime.dwLowDateTime<0 then X:=lpSystemTimeAsFileTime.dwLowDateTime shr 1
{$WARNINGS ON}
Else X:=lpSystemTimeAsFileTime.dwLowDateTime;
Result:=(((lpSystemTimeAsFileTime.dwHighDateTime mod 1000)*1000000)+
X div 10000);
// Result:=GetTickCount;
End;
{$ENDIF}
Function AddBackSlash(Const S:String):String;
Begin
Result:=S;
If Copy(Result,Length(Result),1)<>'\' then Result:=Result+'\';
End;
Function NoBackSlash(Const S:String):String;
Var
I:Integer;
Begin
Result:=S;
I:=Length(S);
If I>0 then
If Result[I]='\' then Delete(Result,Length(Result),1);
End;
{$IFDEF VER100} // Delphi3 code
function StringReplace(const S, OldPattern, NewPattern: string;
Flags: TReplaceFlags): string;
var
SearchStr, Patt, NewStr: string;
Offset: Integer;
begin
if rfIgnoreCase in Flags then
begin
SearchStr := AnsiUpperCase(S);
Patt := AnsiUpperCase(OldPattern);
end else
begin
SearchStr := S;
Patt := OldPattern;
end;
NewStr := S;
Result := '';
while SearchStr <> '' do
begin
{$IFDEF VER90}
Offset := Pos(Patt, SearchStr);
{$ELSE}
Offset := AnsiPos(Patt, SearchStr);
{$ENDIF}
if Offset = 0 then
begin
Result := Result + NewStr;
Break;
end;
Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
if not (rfReplaceAll in Flags) then
begin
Result := Result + NewStr;
Break;
end;
SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
end;
end;
procedure FreeAndNil(var Obj);
var
Temp:TObject;
begin
Temp:=TObject(Obj);
Pointer(Obj):=nil;
Temp.Free;
end;
{$ENDIF}
function PCharLen(Str:PChar):integer; // both the pas and asm are 3.8 times faster than SysUtil StrLen!!
{$IFDEF ASM8086}
asm
MOV EDX,7
ADD EDX,EAX { pointer+7 used in the end }
PUSH EBX { is necessary; even in your version}
MOV EBX,[EAX] { read first 4 bytes}
ADD EAX,4 { increment pointer}
@L1: LEA ECX,[EBX-$01010101] { subtract 1 from each byte}
XOR EBX,-1 { invert all bytes}
AND ECX,EBX { and these two}
MOV EBX,[EAX] { read next 4 bytes}
ADD EAX,4 { increment pointer}
AND ECX,80808080H { test all sign bits}
JZ @L1 { no zero bytes, continue loop}
TEST ECX,00008080H { test first two bytes}
JNZ @L2 { *was JNZ SHORT @L2*}
SHR ECX,16 { not in the first 2 bytes}
ADD EAX,2
@L2: SHL CL,1 { use carry flag to avoid a branch}
POP EBX { Likewise; see above}
SBB EAX,EDX { compute length}
end;
{$ELSE}
var
p:^cardinal;
q:pchar;
bytes,r1,r2:cardinal;
begin
p:=pointer(tStr);
repeat
q:=pchar(p^);
r2:=cardinal({@}Pointer(q[-$01010101]));
r1:=cardinal(q) xor $FFFFFFFF;
bytes:=r1 and r2;
inc(p);
until (bytes and $80808080)<>0;
result:=integer(p)-integer(tStr)-4;
if (bytes and $00008080)=0 then
begin
bytes:=bytes shr 16;
inc(result,2);
end;
if (bytes and $80)=0 then
inc(result);
end;
{$ENDIF}
{$IFDEF ASM8086}
function LRot16(X: Word; c: longint): Word; assembler;
asm
mov ecx,&c
mov ax,&X
rol ax,cl
mov &Result,ax
end;
function RRot16(X: Word; c: longint): Word; assembler;
asm
mov ecx,&c
mov ax,&X
ror ax,cl
mov &Result,ax
end;
function LRot32(X: DWord; c: longint): DWord; register; assembler;
asm
mov ecx, edx
rol eax, cl
end;
function RRot32(X: DWord; c: longint): DWord; register; assembler;
asm
mov ecx, edx
ror eax, cl
end;
function SwapDWord(X: DWord): DWord; register; assembler;
asm
xchg al,ah
rol eax,16
xchg al,ah
end;
{$ELSE}
function LRot16(X: Word; c: longint): Word;
begin
LRot16:= (X shl c) or (X shr (16 - c));
end;
function RRot16(X: Word; c: longint): Word;
begin
RRot16:= (X shr c) or (X shl (16 - c));
end;
function LRot32(X: DWord; c: longint): DWord;
begin
LRot32:= (X shl c) or (X shr (32 - c));
end;
function RRot32(X: DWord; c: longint): DWord;
begin
RRot32:= (X shr c) or (X shl (32 - c));
end;
function SwapDWord(X: DWord): DWord;
begin
Result:= (X shr 24) or ((X shr 8) and $FF00) or ((X shl 8) and $FF0000) or (X shl 24);
end;
{$ENDIF}
///////////////////////////////////////////////////////////////////////////////
// DXSock 3.0 Additions
///////////////////////////////////////////////////////////////////////////////
Function Center(S:String;MaxWidth:Integer):String;
Var
I:Integer;
Ws:String;
Begin
If Length(S) mod 2=0 then Result:=S
Else Result:=S+#32;
If Length(Result)>=MaxWidth then Exit;
I:=MaxWidth-Length(Result);
If I mod 2<>0 then Begin
Result:=Result+#32;
Dec(I);
End;
If I>0 then Begin
SetLength(Ws,I div 2);
FillChar(Ws[1],I div 2,#32);
Result:=Ws+Result+Ws;
End;
End;
Function LeftJustifyCh(Const S:String;Const Ch:Char;Const MaxLength:Integer):String;
Begin
If MaxLength<Length(S) then Begin //2.4
Result:=Copy(S,1,MaxLength);
Exit;
End;
SetLength(Result,MaxLength);
FillChar(Result[1],MaxLength,Ch);
Move(S[1],Result[1],Min(MaxLength,Length(S)));
End;
Function RightJustifyCh(Const S:String;Const Ch:Char;Const MaxLength:Integer):String;
Begin
If MaxLength<Length(S) then Begin //2.4
Result:=Copy(S,1,MaxLength);
Exit;
End;
SetLength(Result,MaxLength);
FillChar(Result[1],MaxLength,Ch);
Move(S[1],Result[MaxLength-Pred(Length(S))],Min(MaxLength,Length(S)));
End;
Function EncodeTabs(S:string;TabSize:Byte):string;
Var
Ws:String;
Begin
Setlength(Ws,Tabsize);
FillChar(Ws[1],TabSize,#32);
Result:=StringReplace(S,Ws,#9,[rfReplaceAll]);
End;
Function DecodeTabs(S:string;TabSize:Byte):string;
Var
Ws:String;
Begin
Setlength(Ws,Tabsize);
FillChar(Ws[1],TabSize,#32);
Result:=StringReplace(S,#9,Ws,[rfReplaceAll]);
End;
function Filter(S:String;CS:CharSet):String;
Var
Loop:Integer;
Begin
Result:='';
for Loop:=1 to Length(S) do Begin
If not(S[Loop] in CS) then begin
Result:=Result+S[Loop];
end;
end;
End;
Function SoundEx(S:String):String;
Const
Table:Array[1..26] Of Char='.123.12..22455.12623.1.2.2';
Var
SoundString:String[255];
I1 : Integer;
I2 : Integer;
isNum : boolean;
Ch:Char;
Begin
Result:=S;
If S='' then Exit;
isNum:=true;
Repeat
Ch:=UpCase(S[1]);
if Ch>#64 then isNum:=false
else Delete(S,1,1);
until (isNum=false) or (S='');
Result:=S;
If S='' then Exit;
SoundString[0]:=#255;
FillChar(SoundString[1],255,'0');
// Step 1: ASCII to Soundex
For I1:=1 to Length(S)-1 Do Begin
I2:=Ord(UpCase(S[I1+1]))-64;
If ((I2<1) Or (I2>26)) Then I2:=1;
SoundString[I1]:=Table[I2];
End;
// Initialize for second pass
I1 := 1;
Repeat
While(SoundString[I1]='.') Do Delete(SoundString,I1,1);
While((SoundString[I1]=SoundString[I1+1]) And (SoundString[I1]<>'0')) Do Delete(SoundString, I1, 1);
Inc(I1);
Until(SoundString[I1]='0');
Result:=Ch+Copy(SoundString,1,3);
End;
function WildCompare(LookingFor,SourceStr:String):Boolean;
Var
Ws:String;
MaxInputWord:Integer;
MaxWild:Integer;
cInput:Integer;
cWild:Integer;
HelpWild:String;
LengthHelpWild:Integer;
Q:Integer;
function FindPart(helpwilds,input_word:string):integer;
Var
Q1,Q2,Q3:Integer;
// Between:Integer;
Diff:Integer;
begin
Q1:=CharPos('?',helpwilds);
if Q1=0 then Result:=QuickPos(helpwilds,input_word)
else Begin
Q3:=Length(helpwilds);
Diff:=Length(input_word)-Q3;
If Diff<0 then begin
Result:=0;
Exit;
end;
// Between:=0;
for Q1:=0 to Diff do begin
for Q2:=1 to Q3 do begin
If (input_word[Q1+Q2]=helpwilds[Q2]) or
(helpwilds[Q2]='?') then begin
if Q2=Q3 then Begin
Result:=Q1+1;
Exit;
end;
End
else Break;
End;
End;
Result:=0;
end;
end;
function SearchNext(Var WildS:String):Integer;
Begin
Result:=CharPos('*',WildS);
If Result<>0 then WildS:=Copy(WildS,1,Result-1);
End;
Begin
Ws:=LookingFor;
While CharPos('%',Ws)>0 do Ws[CharPos('%',Ws)]:='*';
While QuickPos('**',Ws)>0 do Delete(Ws,QuickPos('**',Ws),1);
MaxInputWord:=Length(SourceStr);
MaxWild:=Length(Ws);
cInput:=1;
cWild:=1;
Result:=True;
Repeat
if SourceStr[cInput]=Ws[cWild] then Begin
inc(cWild);
inc(cInput);
continue;
end
else if Ws[cWild]='?' then begin
inc(cWild);
inc(cInput);
continue;
end
else if Ws[cWild]='*' then Begin
HelpWild:=Copy(Ws,cWild+1,MaxWild);
q:=SearchNext(HelpWild);
LengthHelpWild:=Length(HelpWild);
If Q=0 then begin
If HelpWild='' then Exit;
For Q:=0 to LengthHelpWild-1 do
If (HelpWild[LengthHelpWild-Q]<>SourceStr[MaxInputWord-Q]) and
(HelpWild[LengthHelpWild-Q]<>'?') then Begin
Result:=False;
Exit;
End;
Exit;
End;
Inc(cWild,1+LengthHelpWild);
Q:=FindPart(HelpWild,Copy(SourceStr,cInput,Length(SourceStr)));
If Q=0 then Begin
Result:=False;
Exit;
End;
cInput:=Q+LengthHelpWild;
Continue;
End;
Result:=False;
Exit;
Until (cInput>MaxInputWord) or (cWild>MaxWild);
If cInput<=MaxInputWord then Result:=False
Else If cWild<=MaxWild then Result:=False;
End;
end.
Reference in New Issue View Git Blame Copy Permalink