5483e65197
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6119 8e941d3f-bd1b-0410-a28a-d453659cc2b4
494 lines
14 KiB
ObjectPascal
494 lines
14 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
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/NPL/NPL-1_1Final.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: janSQLStrings.pas, released March 24, 2002.
|
|
|
|
The Initial Developer of the Original Code is Jan Verhoeven
|
|
(jan1.verhoeven@wxs.nl or http://jansfreeware.com).
|
|
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
|
|
All Rights Reserved.
|
|
|
|
Contributor(s): ___________________.
|
|
|
|
Last Modified: 24-mar-2002
|
|
Current Version: 1.0
|
|
|
|
Notes: A set of string routines that are just usefull with janSQL
|
|
|
|
Known Issues:
|
|
|
|
|
|
History:
|
|
1.1 25-mar-2002
|
|
added functions for section strings
|
|
1.0 24-mar-2002 : original release
|
|
|
|
-----------------------------------------------------------------------------}
|
|
|
|
{$ifdef fpc}
|
|
{$mode delphi} {$H+}
|
|
{$endif}
|
|
|
|
|
|
unit janSQLStrings;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNIX} clocale, cwstring,{$ENDIF}
|
|
Classes,sysUtils{,qstrings};
|
|
|
|
function PosStr(const FindString, SourceString: string;
|
|
StartPos: Integer = 1): Integer;
|
|
function PosText(const FindString, SourceString: string;
|
|
StartPos: Integer = 1): Integer;
|
|
function Contains(const value:variant;const aset:string):boolean;
|
|
function Soundex(source : string) : integer;
|
|
procedure SaveString(aFile, aText:string);
|
|
function LoadString(aFile:string):string;
|
|
procedure ListSections(atext:string;list:TStrings);
|
|
function GetSection(atext,asection:string):string;
|
|
function Easter( nYear: Integer ): TDateTime;
|
|
function DateToSQLString(adate:TDateTime):string;
|
|
function SQLStringToDate(atext:string):TDateTime;
|
|
function Date2Year (const DT: TDateTime): Word;
|
|
function GetFirstDayOfYear (const Year: Word): TDateTime;
|
|
function StartOfWeek (const DT: TDateTime): TDateTime;
|
|
function DaysApart (const DT1, DT2: TDateTime): LongInt;
|
|
function Date2WeekNo (const DT: TDateTime): Integer;
|
|
|
|
implementation
|
|
|
|
uses strutils;
|
|
|
|
const
|
|
cr = chr(13)+chr(10);
|
|
tab = chr(9);
|
|
|
|
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);
|
|
|
|
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);
|
|
|
|
|
|
function PosStr(const FindString, SourceString: string; StartPos: Integer): Integer;
|
|
begin
|
|
Result := PosEx(FindString, SourceString, StartPos);
|
|
end;
|
|
|
|
(*
|
|
|
|
{$asmmode intel}
|
|
|
|
function PosStr(const FindString, SourceString: string; StartPos: Integer): Integer; assembler;
|
|
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;
|
|
begin
|
|
Result := PosEx(FindString, SourceString, StartPos);
|
|
end;
|
|
|
|
|
|
(*
|
|
function PosText(const FindString, SourceString: string; StartPos: Integer): Integer; assembler;
|
|
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 Contains(const value:variant;const aset:string):boolean;
|
|
var
|
|
s:string;
|
|
p1,p2,L:integer;
|
|
begin
|
|
result:=false;
|
|
s:=value;
|
|
L:=length(aset);
|
|
p1:=postext(s,aset);
|
|
if p1=0 then exit;
|
|
// check before
|
|
p2:=p1+length(s);
|
|
if p1>1 then begin
|
|
if aset[p1-1]<>'''' then begin
|
|
while (p1>0) and (aset[p1]=' ') do
|
|
dec(p1);
|
|
if (p1>0) then
|
|
if aset[p1]<>',' then exit;
|
|
end
|
|
end;
|
|
// check after
|
|
if (p2<=L) then begin
|
|
if aset[p2]<>'''' then begin
|
|
while (p2<=L) and (aset[p2]=' ') do
|
|
inc(p2);
|
|
if (p2<=L) then
|
|
if aset[p2]<>',' then exit;
|
|
end;
|
|
end;
|
|
result:=true;
|
|
end;
|
|
|
|
procedure SaveString(aFile, aText:string);
|
|
begin
|
|
with TFileStream.Create(aFile, fmCreate) do try
|
|
writeBuffer(aText[1],length(aText));
|
|
finally free; end;
|
|
end;
|
|
|
|
function LoadString(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;
|
|
|
|
function Soundex(source:string) : integer;
|
|
Const
|
|
{This table gives the SoundEX SCORE for all characters Upper and Lower Case
|
|
hence no need to convert. This is faster than doing an UpCase on the whole input string
|
|
The 5 NON Chars in middle are just given 0}
|
|
|
|
SoundExTable : Array[65..122] Of Byte
|
|
//A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ / ] ^ _ '
|
|
=(0,1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2,0,0,0,0,0,0,
|
|
//a b c d e f g h i j k l m n o p q r s t u v w x y z
|
|
0,1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2);
|
|
|
|
Var
|
|
i, l, s, SO, x : Byte;
|
|
Multiple : Word;
|
|
Name : PChar;
|
|
begin
|
|
If source<>'' //do nothing if nothing is passed
|
|
then begin
|
|
name:=pchar(source);
|
|
Result := Ord(UpCase(Name[0])); //initialise to first character
|
|
SO := 0; //initialise last char as 0
|
|
Multiple := 26; //initialise to 26 char of alphabet
|
|
l := Pred(StrLen(Name)); //get into var to save repeating function
|
|
For i := 1 to l do //for each char of input str
|
|
begin
|
|
s := Ord(name[i]); //*
|
|
If (s > 64) and (s < 123) //see notes * below
|
|
then begin
|
|
x := SoundExTable[s]; //get soundex value
|
|
If (x > 0) //it is a scoring char
|
|
AND (x <> SO) //is different from previous char
|
|
then begin
|
|
Result := Result + (x * Multiple); //avoid use of POW as it needs maths unit
|
|
If (Multiple = 26 * 6 * 6) //we have done enough (NB compiles to a const
|
|
then break; //We have done, so leave loop
|
|
Multiple := Multiple * 6;
|
|
SO := x; //save for next round
|
|
end; // of if a scoring char
|
|
end; //of if in range of SoundEx table
|
|
end; //of for loop
|
|
end else result := 0;
|
|
end; //of function SoundBts
|
|
|
|
procedure ListSections(atext:string;list:TStrings);
|
|
var
|
|
p1,p2:integer;
|
|
begin
|
|
list.clear;
|
|
p1:=1;
|
|
repeat
|
|
p1:=posstr('[',atext,p1);
|
|
if p1>0 then begin
|
|
p2:=posstr(']',atext,p1);
|
|
if p2=0 then
|
|
p1:=0
|
|
else begin
|
|
list.append(copy(atext,p1+1,p2-(p1+1)));
|
|
p1:=p2;
|
|
end;
|
|
end;
|
|
until p1=0;
|
|
end;
|
|
|
|
function GetSection(atext,asection:string):string;
|
|
var
|
|
p1,p2:integer;
|
|
begin
|
|
result:='';
|
|
p1:=postext('['+asection+']',atext);
|
|
if p1=0 then exit;
|
|
p1:=p1+length('['+asection+']');
|
|
p2:=posstr('[',atext,p1);
|
|
if p2=0 then
|
|
result:=trim(copy(atext,p1,maxint))
|
|
else
|
|
result:=trim(copy(atext,p1,p2-p1));
|
|
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;
|
|
|
|
function DateToSQLString(adate:TDateTime):string;
|
|
var
|
|
ayear,amonth,aday:word;
|
|
begin
|
|
decodedate(adate,ayear,amonth,aday);
|
|
result:=format('%.4d',[ayear])+'-'+format('%.2d',[amonth])+'-'+format('%.2d',[aday]);
|
|
end;
|
|
|
|
function SQLStringToDate(atext:string):TDateTime;
|
|
begin
|
|
result:=0;
|
|
try
|
|
result:=encodedate(strtoint(copy(atext,1,4)),strtoint(copy(atext,6,2)),strtoint(copy(atext,9,2)));
|
|
except
|
|
end;
|
|
end;
|
|
|
|
function Date2Year (const DT: TDateTime): Word;
|
|
var
|
|
D, M: Word;
|
|
begin
|
|
DecodeDate (DT, Result, M, D);
|
|
end;
|
|
|
|
|
|
function GetFirstDayOfYear (const Year: Word): TDateTime;
|
|
begin
|
|
Result := EncodeDate (Year, 1, 1);
|
|
end;
|
|
|
|
function StartOfWeek (const DT: TDateTime): TDateTime;
|
|
begin
|
|
Result := DT - DayOfWeek (DT) + 1;
|
|
end;
|
|
|
|
function DaysApart (const DT1, DT2: TDateTime): LongInt;
|
|
begin
|
|
Result := Trunc (DT2) - Trunc (DT1);
|
|
end;
|
|
|
|
function Date2WeekNo (const DT: TDateTime): Integer;
|
|
var
|
|
Year: Word;
|
|
FirstSunday, StartYear: TDateTime;
|
|
WeekOfs: Byte;
|
|
begin
|
|
Year := Date2Year (DT);
|
|
StartYear := GetFirstDayOfYear (Year);
|
|
if DayOfWeek (StartYear) = 0 then
|
|
begin
|
|
FirstSunday := StartYear;
|
|
WeekOfs := 1;
|
|
end
|
|
else
|
|
begin
|
|
FirstSunday := StartOfWeek (StartYear) + 7;
|
|
WeekOfs := 2;
|
|
if DT < FirstSunday then
|
|
begin
|
|
Result := 1;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := DaysApart (FirstSunday, StartofWeek (DT)) div 7 + WeekOfs;
|
|
end;
|
|
|
|
|
|
|
|
end.
|