Archivado/Componentes.Terceros.jvcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
b40ce04eb4
Componentes.Terceros.jvcl/official/3.32/run/JvStrings.pas

2229 lines
61 KiB
ObjectPascal
Raw Blame History

{-----------------------------------------------------------------------------
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/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvStrings.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Known Issues:
Should be merged with JCL
-----------------------------------------------------------------------------}
// $Id: JvStrings.pas 10612 2006-05-19 19:04:09Z jfudickar $
unit JvStrings;
{$I jvcl.inc}
{$I crossplatform.inc}
interface
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
{$IFDEF HAS_UNIT_LIBC}
Libc,
{$ENDIF HAS_UNIT_LIBC}
Graphics,
SysUtils, Classes;
{regular expressions}
{template functions}
function ReplaceFirst(const SourceStr, FindStr, ReplaceStr: string): string;
function ReplaceLast(const SourceStr, FindStr, ReplaceStr: string): string;
function InsertLastBlock(var SourceStr: string; BlockStr: string): Boolean;
function RemoveMasterBlocks(const SourceStr: string): string;
function RemoveFields(const SourceStr: string): string;
{http functions}
function URLEncode(const Value: string): string; // Converts string To A URLEncoded string
function URLDecode(const Value: string): string; // Converts string From A URLEncoded string
{set functions}
procedure SplitSet(AText: string; AList: TStringList);
function JoinSet(AList: TStringList): string;
function FirstOfSet(const AText: string): string;
function LastOfSet(const AText: string): string;
function CountOfSet(const AText: string): Integer;
function SetRotateRight(const AText: string): string;
function SetRotateLeft(const AText: string): string;
function SetPick(const AText: string; AIndex: Integer): string;
function SetSort(const AText: string): string;
function SetUnion(const Set1, Set2: string): string;
function SetIntersect(const Set1, Set2: string): string;
function SetExclude(const Set1, Set2: string): string;
{replace any <,> etc by &lt; &gt;}
function XMLSafe(const AText: string): string;
{simple hash, Result can be used in Encrypt}
function Hash(const AText: string): Integer;
{ Base64 encode and decode a string }
function B64Encode(const S: string): string;
function B64Decode(const S: string): string;
{Basic encryption from a Borland Example}
function Encrypt(const InString: string; StartKey, MultKey, AddKey: Integer): string;
function Decrypt(const InString: string; StartKey, MultKey, AddKey: Integer): string;
{Using Encrypt and Decrypt in combination with B64Encode and B64Decode}
function EncryptB64(const InString: string; StartKey, MultKey, AddKey: Integer): string;
function DecryptB64(const InString: string; StartKey, MultKey, AddKey: Integer): string;
procedure CSVToTags(Src, Dst: TStringList);
// converts a csv list to a tagged string list
procedure TagsToCSV(Src, Dst: TStringList);
// converts a tagged string list to a csv list
// only fieldnames from the first record are scanned ib the other records
procedure ListSelect(Src, Dst: TStringList; const AKey, AValue: string);
{selects akey=avalue from Src and returns recordset in Dst}
procedure ListFilter(Src: TStringList; const AKey, AValue: string);
{filters Src for akey=avalue}
procedure ListOrderBy(Src: TStringList; const AKey: string; Numeric: Boolean);
{orders a tagged Src list by akey}
function PosStr(const FindString, SourceString: string;
StartPos: Integer = 1): Integer;
{ PosStr searches the first occurrence of a substring FindString in a string
given by SourceString with case sensitivity (upper and lower case characters
are differed). This function returns the index value of the first character
of a specified substring from which it occurs in a given string starting with
StartPos character index. If a specified substring is not found Q_PosStr
returns zero. The author of algorithm is Peter Morris (UK) (Faststrings unit
from www.torry.ru). }
function PosStrLast(const FindString, SourceString: string): Integer;
{finds the last occurance}
function LastPosChar(const FindChar: Char; SourceString: string): Integer;
function PosText(const FindString, SourceString: string;
StartPos: Integer = 1): Integer;
{ PosText searches the first occurrence of a substring FindString in a string
given by SourceString without case sensitivity (upper and lower case
characters are not differed). This function returns the index value of the
first character of a specified substring from which it occurs in a given
string starting with StartPos character index. If a specified substring is
not found Q_PosStr returns zero. The author of algorithm is Peter Morris
(UK) (Faststrings unit from www.torry.ru). }
function PosTextLast(const FindString, SourceString: string): Integer;
{finds the last occurance}
function NameValuesToXML(const AText: string): string;
{$IFDEF MSWINDOWS}
procedure LoadResourceFile(AFile: string; MemStream: TMemoryStream);
{$ENDIF MSWINDOWS}
procedure DirFiles(const ADir, AMask: string; AFileList: TStringList);
procedure RecurseDirFiles(const ADir: string; var AFileList: TStringList);
procedure RecurseDirProgs(const ADir: string; var AFileList: TStringList);
procedure SaveString(const AFile, AText: string);
function LoadString(const AFile: string): string;
function HexToColor(const AText: string): TColor;
function UppercaseHTMLTags(const AText: string): string;
function LowercaseHTMLTags(const AText: string): string;
procedure GetHTMLAnchors(const AFile: string; AList: TStringList);
function RelativePath(const ASrc, ADst: string): string;
function GetToken(var Start: Integer; const SourceText: string): string;
function PosNonSpace(Start: Integer; const SourceText: string): Integer;
function PosEscaped(Start: Integer; const SourceText, FindText: string; EscapeChar: Char): Integer;
function DeleteEscaped(const SourceText: string; EscapeChar: Char): string;
function BeginOfAttribute(Start: Integer; const SourceText: string): Integer;
// parses the beginning of an attribute: space + alpha character
function ParseAttribute(var Start: Integer; const SourceText: string; var AName, AValue: string): Boolean;
// parses a name="value" attribute from Start; returns 0 when not found or else the position behind the attribute
procedure ParseAttributes(const SourceText: string; Attributes: TStrings);
// parses all name=value attributes to the attributes TStringList
function HasStrValue(const AText, AName: string; var AValue: string): Boolean;
// checks if a name="value" pair exists and returns any value
function GetStrValue(const AText, AName, ADefault: string): string;
// retrieves string value from a line like:
// name="jan verhoeven" email="jan1 dott verhoeven att wxs dott nl"
// returns ADefault when not found
function GetHTMLColorValue(const AText, AName: string; ADefault: TColor): TColor;
// same for a color
function GetIntValue(const AText, AName: string; ADefault: Integer): Integer;
// same for an Integer
function GetFloatValue(const AText, AName: string; ADefault: Extended): Extended;
// same for a float
function GetBoolValue(const AText, AName: string): Boolean;
// same for Boolean but without default
function GetValue(const AText, AName: string): string;
// retrieves string value from a line like:
// name="jan verhoeven" email="jan1 dott verhoeven att wxs dott nl"
procedure SetValue(var AText: string; const AName, AValue: string);
// sets a string value in a line
procedure DeleteValue(var AText: string; const AName: string);
// deletes a AName="value" pair from AText
procedure GetNames(AText: string; AList: TStringList);
// get a list of names from a string with name="value" pairs
function GetHTMLColor(AColor: TColor): string;
// converts a color value to the HTML hex value
function BackPosStr(Start: Integer; const FindString, SourceString: string): Integer;
// finds a string backward case sensitive
function BackPosText(Start: Integer; const FindString, SourceString: string): Integer;
// finds a string backward case insensitive
function PosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
// finds a text range, e.g. <TD>....</TD> case sensitive
function PosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
// finds a text range, e.g. <TD>....</td> case insensitive
function BackPosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
// finds a text range backward, e.g. <TD>....</TD> case sensitive
function BackPosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
// finds a text range backward, e.g. <TD>....</td> case insensitive
function PosTag(Start: Integer; SourceString: string; var RangeBegin: Integer;
var RangeEnd: Integer): Boolean;
// finds a HTML or XML tag: <....>
function InnerTag(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
// finds the innertext between opening and closing tags
function Easter(NYear: Integer): TDateTime;
// returns the easter date of a year.
function GetWeekNumber(Today: TDateTime): string;
//gets a datecode. Returns year and weeknumber in format: YYWW
function ParseNumber(const S: string): Integer;
// parse number returns the last position, starting from 1
function ParseDate(const S: string): Integer;
// parse a SQL style data string from positions 1,
// starts and ends with #
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvStrings.pas $';
Revision: '$Revision: 10612 $';
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
LogPath: 'JVCL\run'
);
{$ENDIF UNITVERSIONING}
implementation
uses
JvConsts, JvResources, JvTypes;
const
B64Table = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
ValidURLChars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$-_@.&+-!*"''(),;/#?:';
ToUpperChars: array [0..255] of Char =
(#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F,
#$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F,
#$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F,
#$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F,
#$40, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F,
#$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$5B, #$5C, #$5D, #$5E, #$5F,
#$60, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F,
#$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$7B, #$7C, #$7D, #$7E, #$7F,
#$80, #$81, #$82, #$81, #$84, #$85, #$86, #$87, #$88, #$89, #$8A, #$8B, #$8C, #$8D, #$8E, #$8F,
#$80, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$8A, #$9B, #$8C, #$8D, #$8E, #$8F,
#$A0, #$A1, #$A1, #$A3, #$A4, #$A5, #$A6, #$A7, #$A8, #$A9, #$AA, #$AB, #$AC, #$AD, #$AE, #$AF,
#$B0, #$B1, #$B2, #$B2, #$A5, #$B5, #$B6, #$B7, #$A8, #$B9, #$AA, #$BB, #$A3, #$BD, #$BD, #$AF,
#$C0, #$C1, #$C2, #$C3, #$C4, #$C5, #$C6, #$C7, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF,
#$D0, #$D1, #$D2, #$D3, #$D4, #$D5, #$D6, #$D7, #$D8, #$D9, #$DA, #$DB, #$DC, #$DD, #$DE, #$DF,
#$C0, #$C1, #$C2, #$C3, #$C4, #$C5, #$C6, #$C7, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF,
#$D0, #$D1, #$D2, #$D3, #$D4, #$D5, #$D6, #$D7, #$D8, #$D9, #$DA, #$DB, #$DC, #$DD, #$DE, #$DF);
(* make Delphi 5 compiler happy // andreas
ToLowerChars: array[0..255] of Char =
(#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F,
#$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F,
#$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F,
#$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F,
#$40, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F,
#$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$5B, #$5C, #$5D, #$5E, #$5F,
#$60, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F,
#$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$7B, #$7C, #$7D, #$7E, #$7F,
#$90, #$83, #$82, #$83, #$84, #$85, #$86, #$87, #$88, #$89, #$9A, #$8B, #$9C, #$9D, #$9E, #$9F,
#$90, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$9A, #$9B, #$9C, #$9D, #$9E, #$9F,
#$A0, #$A2, #$A2, #$BC, #$A4, #$B4, #$A6, #$A7, #$B8, #$A9, #$BA, #$AB, #$AC, #$AD, #$AE, #$BF,
#$B0, #$B1, #$B3, #$B3, #$B4, #$B5, #$B6, #$B7, #$B8, #$B9, #$BA, #$BB, #$BC, #$BE, #$BE, #$BF,
#$E0, #$E1, #$E2, #$E3, #$E4, #$E5, #$E6, #$E7, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF,
#$F0, #$F1, #$F2, #$F3, #$F4, #$F5, #$F6, #$F7, #$F8, #$F9, #$FA, #$FB, #$FC, #$FD, #$FE, #$FF,
#$E0, #$E1, #$E2, #$E3, #$E4, #$E5, #$E6, #$E7, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF,
#$F0, #$F1, #$F2, #$F3, #$F4, #$F5, #$F6, #$F7, #$F8, #$F9, #$FA, #$FB, #$FC, #$FD, #$FE, #$FF);
*)
procedure SaveString(const AFile, AText: string);
begin
with TFileStream.Create(AFile, fmCreate) do
try
WriteBuffer(AText[1], Length(AText));
finally
Free;
end;
end;
function LoadString(const AFile: string): string;
var
S: string;
begin
with TFileStream.Create(AFile, fmOpenRead) do
try
SetLength(S, Size);
ReadBuffer(S[1], Size);
finally
Free;
end;
Result := S;
end;
procedure DeleteValue(var AText: string; const AName: string);
var
P, P2, L: Integer;
begin
L := Length(AName) + 2;
P := PosText(AName + '="', AText);
if P = 0 then
Exit;
P2 := PosStr('"', AText, P + L);
if P2 = 0 then
Exit;
if P > 1 then
Dec(P); // include the preceding space if not the first one
Delete(AText, P, P2 - P + 1);
end;
function GetValue(const AText, AName: string): string;
var
P, P2, L: Integer;
begin
Result := '';
L := Length(AName) + 2;
P := PosText(AName + '="', AText);
if P = 0 then
Exit;
P2 := PosStr('"', AText, P + L);
if P2 = 0 then
Exit;
Result := Copy(AText, P + L, P2 - (P + L));
Result := StringReplace(Result, '~~', Cr, [rfReplaceAll]);
end;
function HasStrValue(const AText, AName: string; var AValue: string): Boolean;
var
P, P2, L: Integer;
S: string;
begin
Result := False;
L := Length(AName) + 2;
P := PosText(AName + '="', AText);
if P = 0 then
Exit;
P2 := PosStr('"', AText, P + L);
if P2 = 0 then
Exit;
S := Copy(AText, P + L, P2 - (P + L));
AValue := StringReplace(S, '~~', Cr, [rfReplaceAll]);
Result := False;
end;
function GetStrValue(const AText, AName, ADefault: string): string;
var
S: string;
begin
S := '';
if HasStrValue(AText, AName, S) then
Result := S
else
Result := ADefault;
end;
function GetIntValue(const AText, AName: string; ADefault: Integer): Integer;
var
S: string;
begin
S := GetValue(AText, AName);
try
Result := StrToInt(S);
except
Result := ADefault;
end;
end;
function GetFloatValue(const AText, AName: string; ADefault: Extended): Extended;
var
S: string;
begin
S := '';
if HasStrValue(AText, AName, S) then
try
Result := StrToFloat(S);
except
Result := ADefault;
end
else
Result := ADefault;
end;
function GetHTMLColorValue(const AText, AName: string; ADefault: TColor): TColor;
var
S: string;
begin
S := '';
if HasStrValue(AText, AName, S) then
begin
if Copy(S, 1, 1) = '#' then
S := '$' + Copy(S, 6, 2) + Copy(S, 4, 2) + Copy(S, 2, 2)
else
S := 'cl' + S;
try
Result := StringToColor(S);
except
Result := ADefault;
end;
end
else
Result := ADefault;
end;
procedure SetValue(var AText: string; const AName, AValue: string);
var
P, P2, L: Integer;
begin
L := Length(AName) + 2;
if AText = '' then
AText := AName + '="' + AValue + '"'
else
begin
P := PosText(AName + '="', AText);
if P = 0 then
AText := AText + ' ' + AName + '="' + AValue + '"'
else
begin
P2 := PosStr('"', AText, P + L);
if P2 = 0 then
Exit;
Delete(AText, P + L, P2 - (P + L));
Insert(AValue, AText, P + L);
end;
end;
end;
function GetHTMLColor(AColor: TColor): string;
begin
Result := Format('%6.6x', [ColorToRGB(AColor)]);
Result := '="#' + Copy(Result, 5, 2) + Copy(Result, 3, 2) + Copy(Result, 1, 2) + '"';
end;
function BackPosStr(Start: Integer; const FindString, SourceString: string): Integer;
var
P, L: Integer;
begin
Result := 0;
L := Length(FindString);
if (L = 0) or (SourceString = '') or (Start < 2) then
Exit;
Start := Start - L;
if Start < 1 then
Exit;
repeat
P := PosStr(FindString, SourceString, Start);
if P < Start then
begin
Result := P;
Exit;
end;
Start := Start - L;
until Start < 1;
end;
function BackPosText(Start: Integer; const FindString, SourceString: string): Integer;
var
P, L, From: Integer;
begin
Result := 0;
L := Length(FindString);
if (L = 0) or (SourceString = '') or (Start < 2) then
Exit;
From := Start - L;
if From < 1 then
Exit;
repeat
P := PosText(FindString, SourceString, From);
if P < Start then
begin
Result := P;
Exit;
end;
From := From - L;
until From < 1;
end;
function PosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
Result := False;
RangeBegin := PosStr(HeadString, SourceString, Start);
if RangeBegin = 0 then
Exit;
RangeEnd := PosStr(TailString, SourceString, RangeBegin + Length(HeadString));
if RangeEnd = 0 then
Exit;
RangeEnd := RangeEnd + Length(TailString) - 1;
Result := True;
end;
function PosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
Result := False;
RangeBegin := PosText(HeadString, SourceString, Start);
if RangeBegin = 0 then
Exit;
RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));
if RangeEnd = 0 then
Exit;
RangeEnd := RangeEnd + Length(TailString) - 1;
Result := True;
end;
function InnerTag(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
Result := False;
RangeBegin := PosText(HeadString, SourceString, Start);
if RangeBegin = 0 then
Exit;
RangeBegin := RangeBegin + Length(HeadString);
RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));
if RangeEnd = 0 then
Exit;
RangeEnd := RangeEnd - 1;
Result := True;
end;
function PosTag(Start: Integer; SourceString: string; var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
Result := PosRangeStr(Start, '<', '>', SourceString, RangeBegin, RangeEnd);
end;
function BackPosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
var
L: Integer;
begin
// finds a text range backward, e.g. <TD>....</TD> case sensitive
Result := False;
L := Length(HeadString);
if (L = 0) or (Start < 2) then
Exit;
Start := Start - L;
if Start < 1 then
Exit;
repeat
if not PosRangeStr(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then
Exit;
if RangeBegin < Start then
begin
Result := True;
Exit;
end;
Start := Start - L;
until Start < 1;
end;
function BackPosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
var
L: Integer;
begin
// finds a text range backward, e.g. <TD>....</TD> case insensitive
Result := False;
L := Length(HeadString);
if (L = 0) or (Start < 2) then
Exit;
Start := Start - L;
if Start < 1 then
Exit;
repeat
if not PosRangeText(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then
Exit;
if RangeBegin < Start then
begin
Result := True;
Exit;
end;
Start := Start - L;
until Start < 1;
end;
function PosNonSpace(Start: Integer; const SourceText: string): Integer;
var
P, L: Integer;
begin
Result := 0;
L := Length(SourceText);
P := Start;
if L = 0 then
Exit;
while (P < L) and (SourceText[P] = ' ') do
Inc(P);
if SourceText[P] <> ' ' then
Result := P;
end;
function BeginOfAttribute(Start: Integer; const SourceText: string): Integer;
var
P, L: Integer;
begin
// parses the beginning of an attribute: space + alpha character
Result := 0;
L := Length(SourceText);
if L = 0 then
Exit;
P := PosStr(' ', SourceText, Start);
if P = 0 then
Exit;
P := PosNonSpace(P, SourceText);
if P = 0 then
Exit;
if SourceText[P] in ['a'..'z', 'A'..'Z'] then
Result := P;
end;
function ParseAttribute(var Start: Integer; const SourceText: string;
var AName, AValue: string): Boolean;
var
PN, PV, P: Integer;
begin
// parses a name="value" attribute from Start; returns 0 when not found or else the position behind the attribute
Result := False;
PN := BeginOfAttribute(Start, SourceText);
if PN = 0 then
Exit;
P := PosStr('="', SourceText, PN);
if P = 0 then
Exit;
AName := Trim(Copy(SourceText, PN, P - PN));
PV := P + 2;
P := PosStr('"', SourceText, PV);
if P = 0 then
Exit;
AValue := Copy(SourceText, PV, P - PV);
Start := P + 1;
Result := True;
end;
procedure ParseAttributes(const SourceText: string; Attributes: TStrings);
var
Name, Value: string;
Start: Integer;
begin
Attributes.BeginUpdate;
try
Attributes.Clear;
Start := 1;
while ParseAttribute(Start, SourceText, Name, Value) do
Attributes.Add(Name + '=' + Value);
finally
Attributes.EndUpdate;
end;
end;
function GetToken(var Start: Integer; const SourceText: string): string;
var
P1, P2: Integer;
begin
Result := '';
if Start > Length(SourceText) then
Exit;
P1 := PosNonSpace(Start, SourceText);
if P1 = 0 then
Exit;
if SourceText[P1] = '"' then
begin // quoted token
P2 := PosStr('"', SourceText, P1 + 1);
if P2 = 0 then
Exit;
Result := Copy(SourceText, P1 + 1, P2 - P1 - 1);
Start := P2 + 1;
end
else
begin
P2 := PosStr(' ', SourceText, P1 + 1);
if P2 = 0 then
P2 := Length(SourceText) + 1;
Result := Copy(SourceText, P1, P2 - P1);
Start := P2;
end;
end;
function Easter(NYear: Integer): TDateTime;
var
NMonth, NDay, NMoon, NEpact, NSunday, NGold, NCent, NCorX, NCorZ: Integer;
begin
{ The Golden Number of the year in the 19 year Metonic Cycle }
NGold := ((NYear mod 19) + 1);
{ Calculate the Century }
NCent := ((NYear div 100) + 1);
{ No. of Years in which leap year was dropped in order to keep in step
with the sun }
NCorX := ((3 * NCent) div 4 - 12);
{ Special Correction to Syncronize Easter with the moon's orbit }
NCorZ := ((8 * NCent + 5) div 25 - 5);
{ Find Sunday }
NSunday := ((5 * NYear) div 4 - NCorX - 10);
{ Set Epact (specifies occurance of full moon }
NEpact := ((11 * NGold + 20 + NCorZ - NCorX) mod 30);
if (NEpact < 0) then
NEpact := NEpact + 30;
if ((NEpact = 25) and (NGold > 11)) or (NEpact = 24) then
NEpact := NEpact + 1;
{ Find Full Moon }
NMoon := 44 - NEpact;
if (NMoon < 21) then
NMoon := NMoon + 30;
{ Advance to Sunday }
NMoon := (NMoon + 7 - ((NSunday + NMoon) mod 7));
if (NMoon > 31) then
begin
NMonth := 4;
NDay := (NMoon - 31);
end
else
begin
NMonth := 3;
NDay := NMoon;
end;
Result := EncodeDate(NYear, NMonth, NDay);
end;
//gets a datecode. Returns year and weeknumber in format: YYWW
{DayOfWeek function returns Integer 1..7 equivalent to Sunday..Saturday.
ISO 8601 weeks Start with Monday and the first week of a year is the one which
includes the first Thursday - Fiddle takes care of all this}
function GetWeekNumber(Today: TDateTime): string;
const
Fiddle: array [1..7] of Byte = (6, 7, 8, 9, 10, 4, 5);
var
Present, StartOfYear: TDateTime;
FirstDayOfYear, WeekNumber, NumberOfDays: Integer;
Year, Month, Day: Word;
YearNumber: string;
begin
Present := Trunc(Today); //truncate to remove hours, mins and secs
DecodeDate(Present, Year, Month, Day); //decode to find year
StartOfYear := EncodeDate(Year, 1, 1); //encode 1st Jan of the year
//find what day of week 1st Jan is, then add days according to rule
FirstDayOfYear := Fiddle[DayOfWeek(StartOfYear)];
//calc number of days since beginning of year + additional according to rule
NumberOfDays := Trunc(Present - StartOfYear) + FirstDayOfYear;
//calc number of weeks
WeekNumber := Trunc(NumberOfDays / 7);
//Format year, needed to prevent millenium bug and keep the Fluffy Spangle happy
YearNumber := FormatDateTime('yyyy', Present);
YearNumber := YearNumber + 'W';
if WeekNumber < 10 then
YearNumber := YearNumber + '0'; //add leading zero for week
//create datecode string
Result := YearNumber + IntToStr(WeekNumber);
if WeekNumber = 0 then //recursive call for year begin/end...
//see if previous year end was week 52 or 53
Result := GetWeekNumber(EncodeDate(Year - 1, 12, 31))
else
if WeekNumber = 53 then
//if 31st December less than Thursday then must be week 01 of next year
if DayOfWeek(EncodeDate(Year, 12, 31)) < 5 then
begin
YearNumber := FormatDateTime('yyyy', EncodeDate(Year + 1, 1, 1));
Result := YearNumber + 'W01';
end;
end;
function RelativePath(const ASrc, ADst: string): string;
var
Doc, SDoc, ParDoc, Img, SImg, ParImg, Rel: string;
PDoc, PImg: Integer;
begin
Doc := ASrc;
Img := ADst;
repeat
PDoc := Pos('\', Doc);
if PDoc > 0 then
begin
ParDoc := Copy(Doc, 1, PDoc);
ParDoc[Length(ParDoc)] := '/';
SDoc := SDoc + ParDoc;
Delete(Doc, 1, PDoc);
end;
PImg := Pos('\', Img);
if PImg > 0 then
begin
ParImg := Copy(Img, 1, PImg);
ParImg[Length(ParImg)] := '/';
SImg := SImg + ParImg;
Delete(Img, 1, PImg);
end;
if (PDoc > 0) and (PImg > 0) and (SDoc <> SImg) then
Rel := '../' + Rel + ParImg;
if (PDoc = 0) and (PImg <> 0) then
begin
Rel := Rel + ParImg + Img;
if Pos(':', Rel) > 0 then
Rel := '';
Result := Rel;
Exit;
end;
if (PDoc > 0) and (PImg = 0) then
begin
Rel := '../' + Rel;
end;
until (PDoc = 0) and (PImg = 0);
Rel := Rel + ExtractFileName(Img);
if Pos(':', Rel) > 0 then
Rel := '';
Result := Rel;
end;
procedure GetHTMLAnchors(const AFile: string; AList: TStringList);
var
S, SA: string;
P1, P2: Integer;
begin
S := LoadString(AFile);
P1 := 1;
repeat
P1 := PosText('<a name="', S, P1);
if P1 <> 0 then
begin
P2 := PosText('"', S, P1 + 9);
if P2 <> 0 then
begin
SA := Copy(S, P1 + 9, P2 - P1 - 9);
AList.Add(SA);
P1 := P2;
end
else
P1 := 0;
end;
until P1 = 0;
end;
function UppercaseHTMLTags(const AText: string): string;
var
P, P2: Integer;
begin
Result := '';
P2 := 1;
repeat
P := PosStr('<', AText, P2);
if P > 0 then
begin
Result := Result + Copy(AText, P2, P - P2);
P2 := P;
if Copy(AText, P, 4) = '<!--' then
begin
P := PosStr('-->', AText, P);
if P > 0 then
begin
Result := Result + Copy(AText, P2, P + 3 - P2);
P2 := P + 3;
end
else
Result := Result + Copy(AText, P2, Length(AText));
end
else
begin
P := PosStr('>', AText, P);
if P > 0 then
begin
Result := Result + UpperCase(Copy(AText, P2, P - P2 + 1));
P2 := P + 1;
end
else
Result := Result + Copy(AText, P2, Length(AText));
end;
end
else
begin
Result := Result + Copy(AText, P2, Length(AText));
end;
until P = 0;
end;
function LowercaseHTMLTags(const AText: string): string;
var
P, P2: Integer;
begin
Result := '';
P2 := 1;
repeat
P := PosStr('<', AText, P2);
if P > 0 then
begin
Result := Result + Copy(AText, P2, P - P2);
P2 := P;
// now check for comments
if Copy(AText, P, 4) = '<!--' then
begin
P := PosStr('-->', AText, P);
if P > 0 then
begin
Result := Result + Copy(AText, P2, P + 3 - P2);
P2 := P + 3;
end
else
Result := Result + Copy(AText, P2, Length(AText));
end
else
begin
P := PosStr('>', AText, P);
if P > 0 then
begin
Result := Result + LowerCase(Copy(AText, P2, P - P2 + 1));
P2 := P + 1;
end
else
Result := Result + Copy(AText, P2, Length(AText));
end;
end
else
begin
Result := Result + Copy(AText, P2, Length(AText));
end;
until P = 0;
end;
function HexToColor(const AText: string): TColor;
begin
Result := clBlack;
if Length(AText) <> 7 then
Exit;
if AText[1] <> '#' then
Exit;
try
Result := StringToColor('$' + Copy(AText, 6, 2) + Copy(AText, 4, 2) + Copy(AText, 2, 2));
except
Result := clBlack;
end;
end;
function PosEscaped(Start: Integer; const SourceText, FindText: string; EscapeChar: Char): Integer;
begin
Result := PosText(FindText, SourceText, Start);
if Result = 0 then
Exit;
if Result = 1 then
Exit;
if SourceText[Result - 1] <> EscapeChar then
Exit;
repeat
Result := PosText(FindText, SourceText, Result + 1);
if Result = 0 then
Exit;
until SourceText[Result - 1] <> EscapeChar;
end;
function DeleteEscaped(const SourceText: string; EscapeChar: Char): string;
var
I: Integer;
RealLen: Integer;
begin
RealLen := 0;
SetLength(Result, Length(SourceText));
for I := 1 to Length(SourceText) do
if SourceText[I] <> EscapeChar then
begin
Inc(RealLen);
Result[RealLen] := SourceText[I];
end;
SetLength(Result, RealLen);
end;
procedure RecurseDirFiles(const ADir: string; var AFileList: TStringList);
var
SR: TSearchRec;
FileAttrs: Integer;
begin
FileAttrs := faAnyFile or faDirectory;
if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then
while FindNext(SR) = 0 do
if (SR.Attr and faDirectory) <> 0 then
begin
if (SR.Name <> '.') and (SR.Name <> '..') then
RecurseDirFiles(ADir + PathDelim + SR.Name, AFileList);
end
else
AFileList.Add(ADir + PathDelim + SR.Name);
FindClose(SR);
end;
procedure RecurseDirProgs(const ADir: string; var AFileList: TStringList);
var
SR: TSearchRec;
FileAttrs: Integer;
E: string;
{$IFDEF UNIX}
ST: TStatBuf;
{$ENDIF UNIX}
begin
FileAttrs := faAnyFile or faDirectory;
if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then
while FindNext(SR) = 0 do
begin
if (SR.Attr and faDirectory) <> 0 then
begin
if (SR.Name <> '.') and (SR.Name <> '..') then
RecurseDirProgs(ADir + PathDelim + SR.Name, AFileList);
end
{$IFDEF MSWINDOWS}
else
begin
E := LowerCase(ExtractFileExt(SR.Name));
if E = '.exe' then
AFileList.Add(ADir + PathDelim + SR.Name);
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
else
begin
if stat(PChar(ADir + PathDelim + SR.Name), ST) = 0 then
begin
if ST.st_mode and (S_IXUSR or S_IXGRP or S_IXOTH) <> 0 then
AFileList.Add(ADir + PathDelim + SR.Name);
end;
end;
{$ENDIF UNIX}
end;
FindClose(SR);
end;
procedure LoadResourceFile(AFile: string; MemStream: TMemoryStream);
var
HResInfo: HRSRC;
HGlobal: THandle;
Buffer, GoodType: PChar;
Ext: string;
begin
Ext := UpperCase(ExtractFileExt(AFile));
Ext := Copy(Ext, 2, Length(Ext));
if Ext = 'HTM' then
Ext := 'HTML';
GoodType := PChar(Ext);
AFile := ChangeFileExt(AFile, '');
HResInfo := FindResource(HInstance, PChar(AFile), GoodType);
HGlobal := LoadResource(HInstance, HResInfo);
if HGlobal = 0 then
raise EResNotFound.CreateResFmt(@RsECannotLoadResource, [AFile]);
Buffer := LockResource(HGlobal);
MemStream.Clear;
MemStream.WriteBuffer(Buffer[0], SizeOfResource(HInstance, HResInfo));
MemStream.Seek(0, 0);
UnlockResource(HGlobal);
FreeResource(HGlobal);
end;
procedure GetNames(AText: string; AList: TStringList);
var
P: Integer;
S: string;
begin
AList.Clear;
repeat
AText := Trim(AText);
P := Pos('="', AText);
if P > 0 then
begin
S := Copy(AText, 1, P - 1);
AList.Add(S);
Delete(AText, 1, P + 1);
P := Pos('"', AText);
if P > 0 then
Delete(AText, 1, P);
end;
until P = 0;
end;
function NameValuesToXML(const AText: string): string;
var
AList: TStringList;
I, C: Integer;
IName, IValue, Xml: string;
begin
Result := '';
if AText = '' then
Exit;
AList := TStringList.Create;
GetNames(AText, AList);
C := AList.Count;
if C = 0 then
begin
AList.Free;
Exit
end;
Xml := '<accountdata>' + Cr;
for I := 0 to C - 1 do
begin
IName := AList[I];
IValue := GetValue(AText, IName);
IValue := StringReplace(IValue, '~~', Cr, [rfReplaceAll]);
Xml := Xml + '<' + IName + '>' + Cr;
Xml := Xml + ' ' + IValue + Cr;
Xml := Xml + '</' + IName + '>' + Cr;
end;
Xml := Xml + '</accountdata>' + Cr;
AList.Free;
Result := Xml;
end;
function LastPosChar(const FindChar: Char; SourceString: string): Integer;
var
I: Integer;
begin
I := Length(SourceString);
while (I > 0) and (SourceString[I] <> FindChar) do
Dec(I);
Result := I;
end;
function PosStr(const FindString, SourceString: string; StartPos: Integer): Integer;
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EDX
TEST EAX,EAX
JE @@qt
TEST EDX,EDX
JE @@qt0
MOV ESI,EAX
MOV EDI,EDX
MOV EAX,[EAX-4]
MOV EDX,[EDX-4]
DEC EAX
SUB EDX,EAX
DEC ECX
SUB EDX,ECX
JNG @@qt0
MOV EBX,EAX
XCHG EAX,EDX
NOP
ADD EDI,ECX
MOV ECX,EAX
MOV AL,BYTE PTR [ESI]
@@lp1: CMP AL,BYTE PTR [EDI]
JE @@uu
@@fr: INC EDI
DEC ECX
JNZ @@lp1
@@qt0: XOR EAX,EAX
JMP @@qt
@@ms: MOV AL,BYTE PTR [ESI]
MOV EBX,EDX
JMP @@fr
@@uu: TEST EDX,EDX
JE @@fd
@@lp2: MOV AL,BYTE PTR [ESI+EBX]
XOR AL,BYTE PTR [EDI+EBX]
JNE @@ms
DEC EBX
JNE @@lp2
@@fd: LEA EAX,[EDI+1]
SUB EAX,[ESP]
@@qt: POP ECX
POP EBX
POP EDI
POP ESI
end;
function PosText(const FindString, SourceString: string; StartPos: Integer): Integer;
asm
PUSH ESI
PUSH EDI
PUSH EBX
NOP
TEST EAX,EAX
JE @@qt
TEST EDX,EDX
JE @@qt0
MOV ESI,EAX
MOV EDI,EDX
PUSH EDX
MOV EAX,[EAX-4]
MOV EDX,[EDX-4]
DEC EAX
SUB EDX,EAX
DEC ECX
PUSH EAX
SUB EDX,ECX
JNG @@qtx
ADD EDI,ECX
MOV ECX,EDX
MOV EDX,EAX
MOVZX EBX,BYTE PTR [ESI]
MOV AL,BYTE PTR [EBX+ToUpperChars]
@@lp1: MOVZX EBX,BYTE PTR [EDI]
CMP AL,BYTE PTR [EBX+ToUpperChars]
JE @@uu
@@fr: INC EDI
DEC ECX
JNE @@lp1
@@qtx: ADD ESP,$08
@@qt0: XOR EAX,EAX
JMP @@qt
@@ms: MOVZX EBX,BYTE PTR [ESI]
MOV AL,BYTE PTR [EBX+ToUpperChars]
MOV EDX,[ESP]
JMP @@fr
NOP
@@uu: TEST EDX,EDX
JE @@fd
@@lp2: MOV BL,BYTE PTR [ESI+EDX]
MOV AH,BYTE PTR [EDI+EDX]
CMP BL,AH
JE @@eq
MOV AL,BYTE PTR [EBX+ToUpperChars]
MOVZX EBX,AH
XOR AL,BYTE PTR [EBX+ToUpperChars]
JNE @@ms
@@eq: DEC EDX
JNZ @@lp2
@@fd: LEA EAX,[EDI+1]
POP ECX
SUB EAX,[ESP]
POP ECX
@@qt: POP EBX
POP EDI
POP ESI
end;
function GetBoolValue(const AText, AName: string): Boolean;
begin
Result := LowerCase(GetValue(AText, AName)) = 'yes';
end;
procedure ListSelect(Src, Dst: TStringList; const AKey, AValue: string);
var
I: Integer;
begin
Dst.Clear;
for I := 0 to Src.Count - 1 do
begin
if GetValue(Src[I], AKey) = AValue then
Dst.Add(Src[I]);
end;
end;
procedure ListFilter(Src: TStringList; const AKey, AValue: string);
var
I: Integer;
Dst: TStringList;
begin
Dst := TStringList.Create;
for I := 0 to Src.Count - 1 do
begin
if GetValue(Src[I], AKey) = AValue then
Dst.Add(Src[I]);
end;
Src.Assign(Dst);
Dst.Free;
end;
procedure ListOrderBy(Src: TStringList; const AKey: string; Numeric: Boolean);
var
I, Index: Integer;
Lit, Dst: TStringList;
S: string;
IValue: Integer;
begin
if Src.Count < 2 then
Exit; // nothing to sort
Lit := TStringList.Create;
Dst := TStringList.Create;
for I := 0 to Src.Count - 1 do
begin
S := GetValue(Src[I], AKey);
if Numeric then
try
IValue := StrToInt(S);
// format to 5 decimal places for correct string sorting
// e.g. 5 becomes 00005
S := Format('%5.5d', [IValue]);
except
// just use the unformatted value
end;
Lit.AddObject(S, TObject(I));
end;
Lit.Sort;
for I := 0 to Src.Count - 1 do
begin
Index := Integer(Lit.Objects[I]);
Dst.Add(Src[Index]);
end;
Lit.Free;
Src.Assign(Dst);
Dst.Free;
end;
// converts a csv list to a tagged string list
procedure CSVToTags(Src, Dst: TStringList);
var
I, FI, FC: Integer;
Names: TStringList;
Rec: TStringList;
S: string;
begin
Dst.Clear;
if Src.Count < 2 then
Exit;
Names := TStringList.Create;
Rec := TStringList.Create;
try
Names.CommaText := Src[0];
FC := Names.Count;
if FC > 0 then
for I := 1 to Src.Count - 1 do
begin
Rec.CommaText := Src[I];
S := '';
for FI := 0 to FC - 1 do
S := S + Names[FI] + '="' + Rec[FI] + '" ';
Dst.Add(S);
end;
finally
Rec.Free;
Names.Free;
end;
end;
// converts a tagged string list to a csv list
// only fieldnames from the first record are scanned ib the other records
procedure TagsToCSV(Src, Dst: TStringList);
var
I, FI, FC: Integer;
Names: TStringList;
Rec: TStringList;
S: string;
begin
Dst.Clear;
if Src.Count < 1 then
Exit;
Names := TStringList.Create;
Rec := TStringList.Create;
try
GetNames(Src[0], Names);
FC := Names.Count;
if FC > 0 then
begin
Dst.Add(Names.CommaText);
for I := 0 to Src.Count - 1 do
begin
S := '';
Rec.Clear;
for FI := 0 to FC - 1 do
Rec.Add(GetValue(Src[I], Names[FI]));
Dst.Add(Rec.CommaText);
end;
end;
finally
Rec.Free;
Names.Free;
end;
end;
function B64Encode;
var
I: Integer;
InBuf: array [0..2] of Byte;
OutBuf: array [0..3] of Char;
begin
SetLength(Result, ((Length(S) + 2) div 3) * 4);
for I := 1 to ((Length(S) + 2) div 3) do
begin
if Length(S) < (I * 3) then
Move(S[(I - 1) * 3 + 1], InBuf, Length(S) - (I - 1) * 3)
else
Move(S[(I - 1) * 3 + 1], InBuf, 3);
OutBuf[0] := B64Table[((InBuf[0] and $FC) shr 2) + 1];
OutBuf[1] := B64Table[(((InBuf[0] and $03) shl 4) or ((InBuf[1] and $F0) shr 4)) + 1];
OutBuf[2] := B64Table[(((InBuf[1] and $0F) shl 2) or ((InBuf[2] and $C0) shr 6)) + 1];
OutBuf[3] := B64Table[(InBuf[2] and $3F) + 1];
Move(OutBuf, Result[(I - 1) * 4 + 1], 4);
end;
if (Length(S) mod 3) = 1 then
begin
Result[Length(Result) - 1] := '=';
Result[Length(Result)] := '=';
end
else
if (Length(S) mod 3) = 2 then
Result[Length(Result)] := '=';
end;
function B64Decode(const S: string): string;
var
I: Integer;
InBuf: array [0..3] of Byte;
OutBuf: array [0..2] of Byte;
RetValue: string;
begin
if ((Length(S) mod 4) <> 0) or (S = '') then
raise EJVCLException.CreateRes(@RsEIncorrectStringFormat);
SetLength(RetValue, ((Length(S) div 4) - 1) * 3);
for I := 1 to ((Length(S) div 4) - 1) do
begin
Move(S[(I - 1) * 4 + 1], InBuf, 4);
if (InBuf[0] > 64) and (InBuf[0] < 91) then
Dec(InBuf[0], 65)
else
if (InBuf[0] > 96) and (InBuf[0] < 123) then
Dec(InBuf[0], 71)
else
if (InBuf[0] > 47) and (InBuf[0] < 58) then
Inc(InBuf[0], 4)
else
if InBuf[0] = 43 then
InBuf[0] := 62
else
InBuf[0] := 63;
if (InBuf[1] > 64) and (InBuf[1] < 91) then
Dec(InBuf[1], 65)
else
if (InBuf[1] > 96) and (InBuf[1] < 123) then
Dec(InBuf[1], 71)
else
if (InBuf[1] > 47) and (InBuf[1] < 58) then
Inc(InBuf[1], 4)
else
if InBuf[1] = 43 then
InBuf[1] := 62
else
InBuf[1] := 63;
if (InBuf[2] > 64) and (InBuf[2] < 91) then
Dec(InBuf[2], 65)
else
if (InBuf[2] > 96) and (InBuf[2] < 123) then
Dec(InBuf[2], 71)
else
if (InBuf[2] > 47) and (InBuf[2] < 58) then
Inc(InBuf[2], 4)
else
if InBuf[2] = 43 then
InBuf[2] := 62
else
InBuf[2] := 63;
if (InBuf[3] > 64) and (InBuf[3] < 91) then
Dec(InBuf[3], 65)
else
if (InBuf[3] > 96) and (InBuf[3] < 123) then
Dec(InBuf[3], 71)
else
if (InBuf[3] > 47) and (InBuf[3] < 58) then
Inc(InBuf[3], 4)
else
if InBuf[3] = 43 then
InBuf[3] := 62
else
InBuf[3] := 63;
OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
OutBuf[2] := (InBuf[2] shl 6) or (InBuf[3] and $3F);
Move(OutBuf, RetValue[(I - 1) * 3 + 1], 3);
end;
if S <> '' then
begin
Move(S[Length(S) - 3], InBuf, 4);
if InBuf[2] = 61 then
begin
if (InBuf[0] > 64) and (InBuf[0] < 91) then
Dec(InBuf[0], 65)
else
if (InBuf[0] > 96) and (InBuf[0] < 123) then
Dec(InBuf[0], 71)
else
if (InBuf[0] > 47) and (InBuf[0] < 58) then
Inc(InBuf[0], 4)
else
if InBuf[0] = 43 then
InBuf[0] := 62
else
InBuf[0] := 63;
if (InBuf[1] > 64) and (InBuf[1] < 91) then
Dec(InBuf[1], 65)
else
if (InBuf[1] > 96) and (InBuf[1] < 123) then
Dec(InBuf[1], 71)
else
if (InBuf[1] > 47) and (InBuf[1] < 58) then
Inc(InBuf[1], 4)
else
if InBuf[1] = 43 then
InBuf[1] := 62
else
InBuf[1] := 63;
OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
RetValue := RetValue + Char(OutBuf[0]);
end
else
if InBuf[3] = 61 then
begin
if (InBuf[0] > 64) and (InBuf[0] < 91) then
Dec(InBuf[0], 65)
else
if (InBuf[0] > 96) and (InBuf[0] < 123) then
Dec(InBuf[0], 71)
else
if (InBuf[0] > 47) and (InBuf[0] < 58) then
Inc(InBuf[0], 4)
else
if InBuf[0] = 43 then
InBuf[0] := 62
else
InBuf[0] := 63;
if (InBuf[1] > 64) and (InBuf[1] < 91) then
Dec(InBuf[1], 65)
else
if (InBuf[1] > 96) and (InBuf[1] < 123) then
Dec(InBuf[1], 71)
else
if (InBuf[1] > 47) and (InBuf[1] < 58) then
Inc(InBuf[1], 4)
else
if InBuf[1] = 43 then
InBuf[1] := 62
else
InBuf[1] := 63;
if (InBuf[2] > 64) and (InBuf[2] < 91) then
Dec(InBuf[2], 65)
else
if (InBuf[2] > 96) and (InBuf[2] < 123) then
Dec(InBuf[2], 71)
else
if (InBuf[2] > 47) and (InBuf[2] < 58) then
Inc(InBuf[2], 4)
else
if InBuf[2] = 43 then
InBuf[2] := 62
else
InBuf[2] := 63;
OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
RetValue := RetValue + Char(OutBuf[0]) + Char(OutBuf[1]);
end
else
begin
if (InBuf[0] > 64) and (InBuf[0] < 91) then
Dec(InBuf[0], 65)
else
if (InBuf[0] > 96) and (InBuf[0] < 123) then
Dec(InBuf[0], 71)
else
if (InBuf[0] > 47) and (InBuf[0] < 58) then
Inc(InBuf[0], 4)
else
if InBuf[0] = 43 then
InBuf[0] := 62
else
InBuf[0] := 63;
if (InBuf[1] > 64) and (InBuf[1] < 91) then
Dec(InBuf[1], 65)
else
if (InBuf[1] > 96) and (InBuf[1] < 123) then
Dec(InBuf[1], 71)
else
if (InBuf[1] > 47) and (InBuf[1] < 58) then
Inc(InBuf[1], 4)
else
if InBuf[1] = 43 then
InBuf[1] := 62
else
InBuf[1] := 63;
if (InBuf[2] > 64) and (InBuf[2] < 91) then
Dec(InBuf[2], 65)
else
if (InBuf[2] > 96) and (InBuf[2] < 123) then
Dec(InBuf[2], 71)
else
if (InBuf[2] > 47) and (InBuf[2] < 58) then
Inc(InBuf[2], 4)
else
if InBuf[2] = 43 then
InBuf[2] := 62
else
InBuf[2] := 63;
if (InBuf[3] > 64) and (InBuf[3] < 91) then
Dec(InBuf[3], 65)
else
if (InBuf[3] > 96) and (InBuf[3] < 123) then
Dec(InBuf[3], 71)
else
if (InBuf[3] > 47) and (InBuf[3] < 58) then
Inc(InBuf[3], 4)
else
if InBuf[3] = 43 then
InBuf[3] := 62
else
InBuf[3] := 63;
OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
OutBuf[2] := (InBuf[2] shl 6) or (InBuf[3] and $3F);
RetValue := RetValue + Char(OutBuf[0]) + Char(OutBuf[1]) + Char(OutBuf[2]);
end;
end;
Result := RetValue;
end;
{*******************************************************
* Standard Encryption algorithm - Copied from Borland *
*******************************************************}
function Encrypt(const InString: string; StartKey, MultKey, AddKey: Integer): string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + Char(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(Result[I]) + StartKey) * MultKey + AddKey;
end;
end;
{*******************************************************
* Standard Decryption algorithm - Copied from Borland *
*******************************************************}
function Decrypt(const InString: string; StartKey, MultKey, AddKey: Integer): string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + Char(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;
end;
end;
function EncryptB64(const InString: string; StartKey, MultKey, AddKey: Integer): string;
begin
Result := B64Encode(Encrypt(InString, StartKey, MultKey, AddKey));
end;
function DecryptB64(const InString: string; StartKey, MultKey, AddKey: Integer): string;
begin
Result := Decrypt(B64Decode(InString), StartKey, MultKey, AddKey);
end;
function Hash(const AText: string): Integer;
var
I: Integer;
begin
Result := 0;
if AText = '' then
Exit;
Result := Ord(AText[1]);
for I := 2 to Length(AText) do
Result := (Result * Ord(AText[I])) xor Result;
end;
{replace any <,> etc by &lt; &gt;}
function XMLSafe(const AText: string): string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(AText) do
if AText[I] = '<' then
Result := Result + '&lt;'
else
if AText[I] = '>' then
Result := Result + '&gt;'
else
if AText[I] = '&' then
Result := Result + '&amp;'
else
if (Ord(AText[I]) >= 32) and (Ord(AText[I]) < 128) then
Result := Result + AText[I]
else
if Ord(AText[I]) > 127 then
Result := Result + '&#' + IntToStr(Ord(AText[I])) + ';'
else
Result := Result + ' ';
end;
function FirstOfSet(const AText: string): string;
var
P: Integer;
begin
Result := Trim(AText);
if Result = '' then
Exit;
if Result[1] = '"' then
begin
P := PosStr('"', Result, 2);
Result := Copy(Result, 2, P - 2);
end
else
begin
P := Pos(' ', Result);
Result := Copy(Result, 1, P - 1);
end;
end;
function LastOfSet(const AText: string): string;
var
C: Integer;
begin
Result := Trim(AText);
if Result = '' then
Exit;
C := Length(Result);
if Result[C] = '"' then
begin
while (C > 1) and (Result[C - 1] <> '"') do
Dec(C);
Result := Copy(Result, C, Length(Result) - C);
end
else
begin
while (C > 1) and (Result[C - 1] <> ' ') do
Dec(C);
Result := Copy(Result, C, Length(Result));
end;
end;
function CountOfSet(const AText: string): Integer;
var
Lit: TStringList;
begin
Lit := TStringList.Create;
SplitSet(AText, Lit);
Result := Lit.Count;
Lit.Free;
end;
function SetRotateRight(const AText: string): string;
var
Lit: TStringList;
C: Integer;
begin
Lit := TStringList.Create;
SplitSet(AText, Lit);
C := Lit.Count;
if C > 0 then
begin
Lit.Move(C - 1, 0);
Result := JoinSet(Lit);
end
else
Result := '';
Lit.Free;
end;
function SetRotateLeft(const AText: string): string;
var
Lit: TStringList;
C: Integer;
begin
Lit := TStringList.Create;
SplitSet(AText, Lit);
C := Lit.Count;
if C > 0 then
begin
Lit.Move(0, C - 1);
Result := JoinSet(Lit);
end
else
Result := '';
Lit.Free;
end;
procedure SplitSet(AText: string; AList: TStringList);
var
P: Integer;
begin
AList.Clear;
if AText = '' then
Exit;
AText := Trim(AText);
while AText <> '' do
begin
if AText[1] = '"' then
begin
Delete(AText, 1, 1);
P := Pos('"', AText);
if P <> 0 then
begin
AList.Add(Copy(AText, 1, P - 1));
Delete(AText, 1, P);
end;
end
else
begin
P := Pos(' ', AText);
if P = 0 then
begin
AList.Add(AText);
AText := '';
end
else
begin
AList.Add(Copy(AText, 1, P - 1));
Delete(AText, 1, P);
end;
end;
AText := Trim(AText);
end;
end;
function JoinSet(AList: TStringList): string;
var
I: Integer;
begin
Result := '';
for I := 0 to AList.Count - 1 do
Result := Result + AList[I] + ' ';
Delete(Result, Length(Result), 1);
end;
function SetPick(const AText: string; AIndex: Integer): string;
var
Lit: TStringList;
C: Integer;
begin
Lit := TStringList.Create;
SplitSet(AText, Lit);
C := Lit.Count;
if (C > 0) and (AIndex < C) then
Result := Lit[AIndex]
else
Result := '';
Lit.Free;
end;
function SetSort(const AText: string): string;
var
Lit: TStringList;
begin
Lit := TStringList.Create;
SplitSet(AText, Lit);
if Lit.Count > 0 then
begin
Lit.Sort;
Result := JoinSet(Lit);
end
else
Result := '';
Lit.Free;
end;
function SetUnion(const Set1, Set2: string): string;
var
Lit1, Lit2, Lit3: TStringList;
I, C: Integer;
begin
Lit1 := TStringList.Create;
Lit2 := TStringList.Create;
Lit3 := TStringList.Create;
SplitSet(Set1, Lit1);
SplitSet(Set2, Lit2);
C := Lit2.Count;
if C <> 0 then
begin
Lit2.Addstrings(Lit1);
for I := 0 to Lit2.Count - 1 do
if Lit3.IndexOf(Lit2[I]) = -1 then
Lit3.Add(Lit2[I]);
Result := JoinSet(Lit3);
end
else
begin
Result := JoinSet(Lit1);
end;
Lit1.Free;
Lit2.Free;
Lit3.Free;
end;
function SetIntersect(const Set1, Set2: string): string;
var
Lit1, Lit2, Lit3: TStringList;
I: Integer;
begin
Lit1 := TStringList.Create;
Lit2 := TStringList.Create;
Lit3 := TStringList.Create;
SplitSet(Set1, Lit1);
SplitSet(Set2, Lit2);
if Lit2.Count <> 0 then
begin
for I := 0 to Lit2.Count - 1 do
if Lit1.IndexOf(Lit2[I]) <> -1 then
Lit3.Add(Lit2[I]);
Result := JoinSet(Lit3);
end
else
Result := '';
Lit1.Free;
Lit2.Free;
Lit3.Free;
end;
function SetExclude(const Set1, Set2: string): string;
var
Lit1, Lit2: TStringList;
I, Index: Integer;
begin
Lit1 := TStringList.Create;
Lit2 := TStringList.Create;
SplitSet(Set1, Lit1);
SplitSet(Set2, Lit2);
if Lit2.Count <> 0 then
begin
for I := 0 to Lit2.Count - 1 do
begin
Index := Lit1.IndexOf(Lit2[I]);
if Index <> -1 then
Lit1.Delete(Index);
end;
Result := JoinSet(Lit1);
end
else
Result := JoinSet(Lit1);
Lit1.Free;
Lit2.Free;
end;
// This function converts a string into a RFC 1630 compliant URL
function URLEncode(const Value: string): string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(Value) do
if Pos(UpperCase(Value[I]), ValidURLChars) > 0 then
Result := Result + Value[I]
else
begin
if Value[I] = ' ' then
Result := Result + '+'
else
begin
Result := Result + '%';
Result := Result + IntToHex(Byte(Value[I]), 2);
end;
end;
end;
function URLDecode(const Value: string): string;
const
HexChars = '0123456789ABCDEF';
var
I: Integer;
Ch, H1, H2: Char;
Len: Integer;
begin
Result := '';
Len := Length(Value);
I := 1;
while I <= Len do
begin
Ch := Value[I];
case Ch of
'%':
begin
H1 := Value[I + 1];
H2 := Value[I + 2];
Inc(I, 2);
Result := Result + Chr(((Pos(H1, HexChars) - 1) * 16) + (Pos(H2, HexChars) - 1));
end;
'+':
Result := Result + ' ';
'&':
Result := Result + CrLf;
else
Result := Result + Ch;
end;
Inc(I);
end;
end;
{template functions}
function ReplaceFirst(const SourceStr, FindStr, ReplaceStr: string): string;
var
P: Integer;
begin
Result := SourceStr;
P := PosText(FindStr, SourceStr, 1);
if P <> 0 then
Result := Copy(SourceStr, 1, P - 1) + ReplaceStr + Copy(SourceStr, P + Length(FindStr), Length(SourceStr));
end;
function ReplaceLast(const SourceStr, FindStr, ReplaceStr: string): string;
var
P: Integer;
begin
Result := SourceStr;
P := PosTextLast(FindStr, SourceStr);
if P <> 0 then
Result := Copy(SourceStr, 1, P - 1) + ReplaceStr + Copy(SourceStr, P + Length(FindStr), Length(SourceStr));
end;
// insert a block template
// the last occurance of {block:aBlockname}
// the block template is marked with {begin:aBlockname} and {end:aBlockname}
function InsertLastBlock(var SourceStr: string; BlockStr: string): Boolean;
var
// phead: Integer;
PBlock, PE, PB: Integer;
SBB, SBE, SB, SBR: string;
SBBL, SBEL: Integer;
begin
Result := False;
// phead:= PosStr('</head>',SourceStr,1);
// If phead = 0 Then Exit;
// phead:= phead + 7;
SB := '{block:' + BlockStr + '}';
// sbL:=Length(SB);
SBB := '{begin:' + BlockStr + '}';
SBBL := Length(SBB);
SBE := '{end:' + BlockStr + '}';
SBEL := Length(SBE);
PBlock := PosTextLast(SB, SourceStr);
if PBlock = 0 then
Exit;
PB := PosText(SBB, SourceStr, 1);
if PB = 0 then
Exit;
PE := PosText(SBE, SourceStr, PB);
if PE = 0 then
Exit;
PE := PE + SBEL - 1;
// now replace
SBR := Copy(SourceStr, PB + SBBL, PE - PB - SBBL - SBEL + 1);
SourceStr := Copy(SourceStr, 1, PBlock - 1) + SBR + Copy(SourceStr, PBlock, Length(SourceStr));
Result := True;
end;
// removes all {begin:somefield} to {end:somefield} from ASource
function RemoveMasterBlocks(const SourceStr: string): string;
var
S, Src: string;
PB: Integer;
PE: Integer;
PEE: Integer;
begin
S := '';
Src := SourceStr;
repeat
PB := PosText('{begin:', Src);
if PB > 0 then
begin
PE := PosText('{end:', Src, PB);
if PE > 0 then
begin
PEE := PosStr('}', Src, PE);
if PEE > 0 then
begin
S := S + Copy(Src, 1, PB - 1);
Delete(Src, 1, PEE);
end;
end;
end;
until PB = 0;
Result := S + Src;
end;
// removes all {field} entries in a template
function RemoveFields(const SourceStr: string): string;
var
Src, S: string;
PB: Integer;
PE: Integer;
begin
S := '';
Src := SourceStr;
repeat
PB := Pos('{', Src);
if PB > 0 then
begin
PE := Pos('}', Src);
if PE > 0 then
begin
S := S + Copy(Src, 1, PB - 1);
Delete(Src, 1, PE);
end;
end;
until PB = 0;
Result := S + Src;
end;
{finds the last occurance}
function PosStrLast(const FindString, SourceString: string): Integer;
var
I, L: Integer;
begin
Result := 0;
L := Length(FindString);
if L = 0 then
Exit;
I := Length(SourceString);
if I = 0 then
Exit;
I := I - L + 1;
while I > 0 do
begin
Result := PosStr(FindString, SourceString, I);
if Result > 0 then
Exit;
I := I - L;
end;
end;
{finds the last occurance}
function PosTextLast(const FindString, SourceString: string): Integer;
var
I, L: Integer;
begin
Result := 0;
L := Length(FindString);
if L = 0 then
Exit;
I := Length(SourceString);
if I = 0 then
Exit;
I := I - L + 1;
while I > 0 do
begin
Result := PosText(FindString, SourceString, I);
if Result > 0 then
Exit;
I := I - L;
end;
end;
procedure DirFiles(const ADir, AMask: string; AFileList: TStringList);
var
SR: TSearchRec;
FileAttrs: Integer;
begin
FileAttrs := faArchive + faDirectory;
if FindFirst(ADir + AMask, FileAttrs, SR) = 0 then
while FindNext(SR) = 0 do
if (SR.Attr and faArchive) <> 0 then
AFileList.Add(ADir + SR.Name);
FindClose(SR);
end;
// parse number returns the last position, starting from 1
function ParseNumber(const S: string): Integer;
var
I, E, E2, C: Integer;
begin
Result := 0;
I := 0;
C := Length(S);
if C = 0 then
Exit;
while (I + 1 <= C) and (S[I + 1] in (DigitChars + [',', '.'])) do
Inc(I);
if (I + 1 <= C) and (S[I + 1] in ['e', 'E']) then
begin
E := I;
Inc(I);
if (I + 1 <= C) and (S[I + 1] in ['+', '-']) then
Inc(I);
E2 := I;
while (I + 1 <= C) and (S[I + 1] in DigitChars) do
Inc(I);
if I = E2 then
I := E;
end;
Result := I;
end;
// parse a SQL style data string from positions 1,
// starts and ends with #
function ParseDate(const S: string): Integer;
var
P: Integer;
begin
Result := 0;
if Length(S) < 2 then
Exit;
P := PosStr('#', S, 2);
if P <> 0 then
try
StrToDate(Copy(S, 2, P - 2));
Result := P;
except
Result := 0;
end;
end;
{$IFDEF UNITVERSIONING}
initialization
RegisterUnitVersion(HInstance, UnitVersioning);
finalization
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
end.
Reference in New Issue View Git Blame Copy Permalink