jvqstrings.pas

East make Tray Icon in delphi

{******************************************************************************}
{* WARNING:  JEDI VCL To CLX Converter generated unit.                        *}
{*           Manual modifications will be lost on next release.               *}
{******************************************************************************}

{-----------------------------------------------------------------------------
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: JvQStrings.pas,v 1.18 2004/09/11 21:07:04 asnepvangers Exp $

unit JvQStrings;

{$I jvcl.inc}
{$I crossplatform.inc}

interface

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  {$IFDEF HAS_UNIT_LIBC}
  Libc,
  {$ENDIF HAS_UNIT_LIBC}
  QGraphics,
  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 #

implementation

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  JvQConsts, JvQResources, JvQTypes;

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]);
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;