home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kompon / d456 / JANSQL.ZIP / janSQLDemo / components / janSQLStrings.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-04-01  |  14.5 KB  |  468 lines
  1. {-----------------------------------------------------------------------------
  2. The contents of this file are subject to the Mozilla Public License Version
  3. 1.1 (the "License"); you may not use this file except in compliance with the
  4. License. You may obtain a copy of the License at
  5. http://www.mozilla.org/NPL/NPL-1_1Final.html
  6.  
  7. Software distributed under the License is distributed on an "AS IS" basis,
  8. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  9. the specific language governing rights and limitations under the License.
  10.  
  11. The Original Code is: janSQLStrings.pas, released March 24, 2002.
  12.  
  13. The Initial Developer of the Original Code is Jan Verhoeven
  14. (jan1.verhoeven@wxs.nl or http://jansfreeware.com).
  15. Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
  16. All Rights Reserved.
  17.  
  18. Contributor(s): ___________________.
  19.  
  20. Last Modified: 24-mar-2002
  21. Current Version: 1.0
  22.  
  23. Notes: A set of string routines that are just usefull with janSQL
  24.  
  25. Known Issues:
  26.  
  27.  
  28. History:
  29.   1.1 25-mar-2002
  30.       added functions for section strings
  31.   1.0 24-mar-2002 : original release
  32.  
  33. -----------------------------------------------------------------------------}
  34.  
  35. unit janSQLStrings;
  36.  
  37. interface
  38.  
  39. uses
  40.   Classes,sysUtils,qstrings;
  41.  
  42.   function PosStr(const FindString, SourceString: string;
  43.     StartPos: Integer = 1): Integer;
  44.   function PosText(const FindString, SourceString: string;
  45.     StartPos: Integer = 1): Integer;
  46.   function Contains(const value:variant;const aset:string):boolean;
  47.   function Soundex(source : string) : integer;
  48.   procedure SaveString(aFile, aText:string);
  49.   function  LoadString(aFile:string):string;
  50.   procedure ListSections(atext:string;list:TStrings);
  51.   function GetSection(atext,asection:string):string;
  52.   function Easter( nYear: Integer ): TDateTime;
  53.   function DateToSQLString(adate:TDateTime):string;
  54.   function SQLStringToDate(atext:string):TDateTime;
  55.   function Date2Year (const DT: TDateTime): Word;
  56.   function GetFirstDayOfYear (const Year: Word): TDateTime;
  57.   function StartOfWeek (const DT: TDateTime): TDateTime;
  58.   function DaysApart (const DT1, DT2: TDateTime): LongInt;
  59.   function Date2WeekNo (const DT: TDateTime): Integer;
  60.  
  61. implementation
  62.  
  63. const
  64.   cr = chr(13)+chr(10);
  65.   tab = chr(9);
  66.  
  67.   ToUpperChars: array[0..255] of Char =
  68.     (#$00,#$01,#$02,#$03,#$04,#$05,#$06,#$07,#$08,#$09,#$0A,#$0B,#$0C,#$0D,#$0E,#$0F,
  69.      #$10,#$11,#$12,#$13,#$14,#$15,#$16,#$17,#$18,#$19,#$1A,#$1B,#$1C,#$1D,#$1E,#$1F,
  70.      #$20,#$21,#$22,#$23,#$24,#$25,#$26,#$27,#$28,#$29,#$2A,#$2B,#$2C,#$2D,#$2E,#$2F,
  71.      #$30,#$31,#$32,#$33,#$34,#$35,#$36,#$37,#$38,#$39,#$3A,#$3B,#$3C,#$3D,#$3E,#$3F,
  72.      #$40,#$41,#$42,#$43,#$44,#$45,#$46,#$47,#$48,#$49,#$4A,#$4B,#$4C,#$4D,#$4E,#$4F,
  73.      #$50,#$51,#$52,#$53,#$54,#$55,#$56,#$57,#$58,#$59,#$5A,#$5B,#$5C,#$5D,#$5E,#$5F,
  74.      #$60,#$41,#$42,#$43,#$44,#$45,#$46,#$47,#$48,#$49,#$4A,#$4B,#$4C,#$4D,#$4E,#$4F,
  75.      #$50,#$51,#$52,#$53,#$54,#$55,#$56,#$57,#$58,#$59,#$5A,#$7B,#$7C,#$7D,#$7E,#$7F,
  76.      #$80,#$81,#$82,#$81,#$84,#$85,#$86,#$87,#$88,#$89,#$8A,#$8B,#$8C,#$8D,#$8E,#$8F,
  77.      #$80,#$91,#$92,#$93,#$94,#$95,#$96,#$97,#$98,#$99,#$8A,#$9B,#$8C,#$8D,#$8E,#$8F,
  78.      #$A0,#$A1,#$A1,#$A3,#$A4,#$A5,#$A6,#$A7,#$A8,#$A9,#$AA,#$AB,#$AC,#$AD,#$AE,#$AF,
  79.      #$B0,#$B1,#$B2,#$B2,#$A5,#$B5,#$B6,#$B7,#$A8,#$B9,#$AA,#$BB,#$A3,#$BD,#$BD,#$AF,
  80.      #$C0,#$C1,#$C2,#$C3,#$C4,#$C5,#$C6,#$C7,#$C8,#$C9,#$CA,#$CB,#$CC,#$CD,#$CE,#$CF,
  81.      #$D0,#$D1,#$D2,#$D3,#$D4,#$D5,#$D6,#$D7,#$D8,#$D9,#$DA,#$DB,#$DC,#$DD,#$DE,#$DF,
  82.      #$C0,#$C1,#$C2,#$C3,#$C4,#$C5,#$C6,#$C7,#$C8,#$C9,#$CA,#$CB,#$CC,#$CD,#$CE,#$CF,
  83.      #$D0,#$D1,#$D2,#$D3,#$D4,#$D5,#$D6,#$D7,#$D8,#$D9,#$DA,#$DB,#$DC,#$DD,#$DE,#$DF);
  84.  
  85.   ToLowerChars: array[0..255] of Char =
  86.     (#$00,#$01,#$02,#$03,#$04,#$05,#$06,#$07,#$08,#$09,#$0A,#$0B,#$0C,#$0D,#$0E,#$0F,
  87.      #$10,#$11,#$12,#$13,#$14,#$15,#$16,#$17,#$18,#$19,#$1A,#$1B,#$1C,#$1D,#$1E,#$1F,
  88.      #$20,#$21,#$22,#$23,#$24,#$25,#$26,#$27,#$28,#$29,#$2A,#$2B,#$2C,#$2D,#$2E,#$2F,
  89.      #$30,#$31,#$32,#$33,#$34,#$35,#$36,#$37,#$38,#$39,#$3A,#$3B,#$3C,#$3D,#$3E,#$3F,
  90.      #$40,#$61,#$62,#$63,#$64,#$65,#$66,#$67,#$68,#$69,#$6A,#$6B,#$6C,#$6D,#$6E,#$6F,
  91.      #$70,#$71,#$72,#$73,#$74,#$75,#$76,#$77,#$78,#$79,#$7A,#$5B,#$5C,#$5D,#$5E,#$5F,
  92.      #$60,#$61,#$62,#$63,#$64,#$65,#$66,#$67,#$68,#$69,#$6A,#$6B,#$6C,#$6D,#$6E,#$6F,
  93.      #$70,#$71,#$72,#$73,#$74,#$75,#$76,#$77,#$78,#$79,#$7A,#$7B,#$7C,#$7D,#$7E,#$7F,
  94.      #$90,#$83,#$82,#$83,#$84,#$85,#$86,#$87,#$88,#$89,#$9A,#$8B,#$9C,#$9D,#$9E,#$9F,
  95.      #$90,#$91,#$92,#$93,#$94,#$95,#$96,#$97,#$98,#$99,#$9A,#$9B,#$9C,#$9D,#$9E,#$9F,
  96.      #$A0,#$A2,#$A2,#$BC,#$A4,#$B4,#$A6,#$A7,#$B8,#$A9,#$BA,#$AB,#$AC,#$AD,#$AE,#$BF,
  97.      #$B0,#$B1,#$B3,#$B3,#$B4,#$B5,#$B6,#$B7,#$B8,#$B9,#$BA,#$BB,#$BC,#$BE,#$BE,#$BF,
  98.      #$E0,#$E1,#$E2,#$E3,#$E4,#$E5,#$E6,#$E7,#$E8,#$E9,#$EA,#$EB,#$EC,#$ED,#$EE,#$EF,
  99.      #$F0,#$F1,#$F2,#$F3,#$F4,#$F5,#$F6,#$F7,#$F8,#$F9,#$FA,#$FB,#$FC,#$FD,#$FE,#$FF,
  100.      #$E0,#$E1,#$E2,#$E3,#$E4,#$E5,#$E6,#$E7,#$E8,#$E9,#$EA,#$EB,#$EC,#$ED,#$EE,#$EF,
  101.      #$F0,#$F1,#$F2,#$F3,#$F4,#$F5,#$F6,#$F7,#$F8,#$F9,#$FA,#$FB,#$FC,#$FD,#$FE,#$FF);
  102.  
  103.  
  104. function PosStr(const FindString, SourceString: string; StartPos: Integer): Integer;
  105. asm
  106.         PUSH    ESI
  107.         PUSH    EDI
  108.         PUSH    EBX
  109.         PUSH    EDX
  110.         TEST    EAX,EAX
  111.         JE      @@qt
  112.         TEST    EDX,EDX
  113.         JE      @@qt0
  114.         MOV     ESI,EAX
  115.         MOV     EDI,EDX
  116.         MOV     EAX,[EAX-4]
  117.         MOV     EDX,[EDX-4]
  118.         DEC     EAX
  119.         SUB     EDX,EAX
  120.         DEC     ECX
  121.         SUB     EDX,ECX
  122.         JNG     @@qt0
  123.         MOV     EBX,EAX
  124.         XCHG    EAX,EDX
  125.         NOP
  126.         ADD     EDI,ECX
  127.         MOV     ECX,EAX
  128.         MOV     AL,BYTE PTR [ESI]
  129. @@lp1:  CMP     AL,BYTE PTR [EDI]
  130.         JE      @@uu
  131. @@fr:   INC     EDI
  132.         DEC     ECX
  133.         JNZ     @@lp1
  134. @@qt0:  XOR     EAX,EAX
  135.         JMP     @@qt
  136. @@ms:   MOV     AL,BYTE PTR [ESI]
  137.         MOV     EBX,EDX
  138.         JMP     @@fr
  139. @@uu:   TEST    EDX,EDX
  140.         JE      @@fd
  141. @@lp2:  MOV     AL,BYTE PTR [ESI+EBX]
  142.         XOR     AL,BYTE PTR [EDI+EBX]
  143.         JNE     @@ms
  144.         DEC     EBX
  145.         JNE     @@lp2
  146. @@fd:   LEA     EAX,[EDI+1]
  147.         SUB     EAX,[ESP]
  148. @@qt:   POP     ECX
  149.         POP     EBX
  150.         POP     EDI
  151.         POP     ESI
  152. end;
  153.  
  154.  
  155. function PosText(const FindString, SourceString: string; StartPos: Integer): Integer;
  156. asm
  157.         PUSH    ESI
  158.         PUSH    EDI
  159.         PUSH    EBX
  160.         NOP
  161.         TEST    EAX,EAX
  162.         JE      @@qt
  163.         TEST    EDX,EDX
  164.         JE      @@qt0
  165.         MOV     ESI,EAX
  166.         MOV     EDI,EDX
  167.         PUSH    EDX
  168.         MOV     EAX,[EAX-4]
  169.         MOV     EDX,[EDX-4]
  170.         DEC     EAX
  171.         SUB     EDX,EAX
  172.         DEC     ECX
  173.         PUSH    EAX
  174.         SUB     EDX,ECX
  175.         JNG     @@qtx
  176.         ADD     EDI,ECX
  177.         MOV     ECX,EDX
  178.         MOV     EDX,EAX
  179.         MOVZX   EBX,BYTE PTR [ESI]
  180.         MOV     AL,BYTE PTR [EBX+ToUpperChars]
  181. @@lp1:  MOVZX   EBX,BYTE PTR [EDI]
  182.         CMP     AL,BYTE PTR [EBX+ToUpperChars]
  183.         JE      @@uu
  184. @@fr:   INC     EDI
  185.         DEC     ECX
  186.         JNE     @@lp1
  187. @@qtx:  ADD     ESP,$08
  188. @@qt0:  XOR     EAX,EAX
  189.         JMP     @@qt
  190. @@ms:   MOVZX   EBX,BYTE PTR [ESI]
  191.         MOV     AL,BYTE PTR [EBX+ToUpperChars]
  192.         MOV     EDX,[ESP]
  193.         JMP     @@fr
  194.         NOP
  195. @@uu:   TEST    EDX,EDX
  196.         JE      @@fd
  197. @@lp2:  MOV     BL,BYTE PTR [ESI+EDX]
  198.         MOV     AH,BYTE PTR [EDI+EDX]
  199.         CMP     BL,AH
  200.         JE      @@eq
  201.         MOV     AL,BYTE PTR [EBX+ToUpperChars]
  202.         MOVZX   EBX,AH
  203.         XOR     AL,BYTE PTR [EBX+ToUpperChars]
  204.         JNE     @@ms
  205. @@eq:   DEC     EDX
  206.         JNZ     @@lp2
  207. @@fd:   LEA     EAX,[EDI+1]
  208.         POP     ECX
  209.         SUB     EAX,[ESP]
  210.         POP     ECX
  211. @@qt:   POP     EBX
  212.         POP     EDI
  213.         POP     ESI
  214. end;
  215.  
  216. function Contains(const value:variant;const aset:string):boolean;
  217. var
  218.   s:string;
  219.   p1,p2,L:integer;
  220. begin
  221.   result:=false;
  222.   s:=value;
  223.   L:=length(aset);
  224.   p1:=postext(s,aset);
  225.   if p1=0 then exit;
  226.   // check before
  227.   p2:=p1+length(s);
  228.   if p1>1 then begin
  229.     if aset[p1-1]<>'''' then begin
  230.       while (p1>0) and (aset[p1]=' ') do
  231.         dec(p1);
  232.       if (p1>0) then
  233.         if aset[p1]<>',' then exit;
  234.     end
  235.   end;
  236.   // check after
  237.   if (p2<=L) then begin
  238.     if aset[p2]<>'''' then begin
  239.       while (p2<=L) and (aset[p2]=' ') do
  240.         inc(p2);
  241.       if (p2<=L) then
  242.         if aset[p2]<>',' then exit;
  243.     end;
  244.   end;
  245.   result:=true;
  246. end;
  247.  
  248. procedure SaveString(aFile, aText:string);
  249. begin
  250.   with TFileStream.Create(aFile, fmCreate) do try
  251.     writeBuffer(aText[1],length(aText));
  252.     finally free; end;
  253. end;
  254.  
  255. function  LoadString(aFile:string):string;
  256. var s:string;
  257. begin
  258.   with TFileStream.Create(aFile, fmOpenRead) do try
  259.       SetLength(s, Size);
  260.       ReadBuffer(s[1], Size);
  261.     finally free; end;
  262.   result:=s;
  263. end;
  264.  
  265. function Soundex(source:string) : integer;
  266. Const
  267. {This table gives the SoundEX SCORE for all characters Upper and Lower Case
  268. hence no need to convert. This is faster than doing an UpCase on the whole input string
  269. The 5 NON Chars in middle are just given 0}
  270.  
  271. SoundExTable : Array[65..122] Of Byte
  272. //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 [ / ] ^ _ '
  273. =(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,
  274. //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
  275.   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);
  276.  
  277. Var
  278.   i, l, s, SO, x : Byte;
  279.   Multiple : Word;
  280.   Name : PChar;
  281. begin
  282.   If source<>''                           //do nothing if nothing is passed
  283.   then begin
  284.     name:=pchar(source);
  285.     Result := Ord(UpCase(Name[0]));       //initialise to first character
  286.     SO := 0;                              //initialise last char as 0
  287.     Multiple := 26;                       //initialise to 26 char of alphabet
  288.     l := Pred(StrLen(Name));              //get into var to save repeating function
  289.     For i := 1 to l do                    //for each char of input str
  290.     begin
  291.       s := Ord(name[i]);                  //*
  292.       If (s > 64) and (s < 123)           //see notes * below
  293.       then begin
  294.         x := SoundExTable[s];             //get soundex value
  295.         If (x > 0)                        //it is a scoring char
  296.         AND (x <> SO)                     //is different from previous char
  297.         then begin
  298.           Result := Result + (x * Multiple); //avoid use of POW as it needs maths unit
  299.           If (Multiple = 26 * 6 * 6)      //we have done enough (NB compiles to a const
  300.            then break;                    //We have done, so leave loop
  301.           Multiple := Multiple * 6;
  302.           SO := x;                        //save for next round
  303.         end;                              // of if a scoring char
  304.       end;                                //of if in range of SoundEx table
  305.     end;                                  //of for loop
  306.   end else result := 0;
  307. end;                                      //of function SoundBts
  308.  
  309. procedure ListSections(atext:string;list:TStrings);
  310. var
  311.   p1,p2:integer;
  312. begin
  313.   list.clear;
  314.   p1:=1;
  315.   repeat
  316.     p1:=posstr('[',atext,p1);
  317.     if p1>0 then begin
  318.       p2:=posstr(']',atext,p1);
  319.       if p2=0 then
  320.         p1:=0
  321.       else begin
  322.         list.append(copy(atext,p1+1,p2-(p1+1)));
  323.         p1:=p2;
  324.       end;
  325.     end;
  326.   until p1=0;
  327. end;
  328.  
  329. function GetSection(atext,asection:string):string;
  330. var
  331.   p1,p2:integer;
  332. begin
  333.   result:='';
  334.   p1:=postext('['+asection+']',atext);
  335.   if p1=0 then exit;
  336.   p1:=p1+length('['+asection+']');
  337.   p2:=posstr('[',atext,p1);
  338.   if p2=0 then
  339.     result:=trim(copy(atext,p1,maxint))
  340.   else
  341.     result:=trim(copy(atext,p1,p2-p1));
  342. end;
  343.  
  344.  
  345. function Easter( nYear: Integer ): TDateTime;
  346. var
  347.    nMonth, nDay, nMoon, nEpact, nSunday, nGold, nCent, nCorx, nCorz: Integer;
  348.  begin
  349.  
  350.     { The Golden Number of the year in the 19 year Metonic Cycle }
  351.     nGold := ( ( nYear mod 19 ) + 1  );
  352.  
  353.     { Calculate the Century }
  354.     nCent := ( ( nYear div 100 ) + 1 );
  355.  
  356.     { No. of Years in which leap year was dropped in order to keep in step
  357.       with the sun }
  358.     nCorx := ( ( 3 * nCent ) div 4 - 12 );
  359.  
  360.     { Special Correction to Syncronize Easter with the moon's orbit }
  361.     nCorz := ( ( 8 * nCent + 5 ) div 25 - 5 );
  362.  
  363.     { Find Sunday }
  364.     nSunday := ( ( 5 * nYear ) div 4 - nCorx - 10 );
  365.  
  366.     { Set Epact (specifies occurance of full moon }
  367.     nEpact := ( ( 11 * nGold + 20 + nCorz - nCorx ) mod 30 );
  368.  
  369.     if ( nEpact < 0 ) then
  370.        nEpact := nEpact + 30;
  371.  
  372.     if ( ( nEpact = 25 ) and ( nGold > 11 ) ) or ( nEpact = 24 ) then
  373.        nEpact := nEpact + 1;
  374.  
  375.     { Find Full Moon }
  376.     nMoon := 44 - nEpact;
  377.  
  378.     if ( nMoon < 21 ) then
  379.        nMoon := nMoon + 30;
  380.  
  381.     { Advance to Sunday }
  382.     nMoon := ( nMoon + 7 - ( ( nSunday + nMoon ) mod 7 ) );
  383.  
  384.     if ( nMoon > 31 ) then
  385.        begin
  386.          nMonth := 4;
  387.          nDay   := ( nMoon - 31 );
  388.        end
  389.     else
  390.        begin
  391.          nMonth := 3;
  392.          nDay   := nMoon;
  393.        end;
  394.  
  395.     Result := EncodeDate( nYear, nMonth, nDay );
  396.  
  397.  end;
  398.  
  399. function DateToSQLString(adate:TDateTime):string;
  400. var
  401.   ayear,amonth,aday:word;
  402. begin
  403.   decodedate(adate,ayear,amonth,aday);
  404.   result:=format('%.4d',[ayear])+'-'+format('%.2d',[amonth])+'-'+format('%.2d',[aday]);
  405. end;
  406.  
  407. function SQLStringToDate(atext:string):TDateTime;
  408. begin
  409.   result:=0;
  410.   try
  411.     result:=encodedate(strtoint(copy(atext,1,4)),strtoint(copy(atext,6,2)),strtoint(copy(atext,9,2)));
  412.   except
  413.   end;
  414. end;
  415.  
  416. function Date2Year (const DT: TDateTime): Word;
  417. var
  418.   D, M: Word;
  419. begin
  420.   DecodeDate (DT, Result, M, D);
  421. end;
  422.  
  423.  
  424. function GetFirstDayOfYear (const Year: Word): TDateTime;
  425. begin
  426.   Result := EncodeDate (Year, 1, 1);
  427. end;
  428.  
  429. function StartOfWeek (const DT: TDateTime): TDateTime;
  430. begin
  431.   Result := DT - DayOfWeek (DT) + 1;
  432. end;
  433.  
  434. function DaysApart (const DT1, DT2: TDateTime): LongInt;
  435. begin
  436.   Result := Trunc (DT2) - Trunc (DT1);
  437. end;
  438.  
  439. function Date2WeekNo (const DT: TDateTime): Integer;
  440. var
  441.   Year: Word;
  442.   FirstSunday, StartYear: TDateTime;
  443.   WeekOfs: Byte;
  444. begin
  445.   Year := Date2Year (DT);
  446.   StartYear := GetFirstDayOfYear (Year);
  447.   if DayOfWeek (StartYear) = 0 then
  448.   begin
  449.     FirstSunday := StartYear;
  450.     WeekOfs := 1;
  451.   end
  452.   else
  453.   begin
  454.     FirstSunday := StartOfWeek (StartYear) + 7;
  455.     WeekOfs := 2;
  456.     if DT < FirstSunday then
  457.     begin
  458.       Result := 1;
  459.       Exit;
  460.     end;
  461.   end;
  462.   Result := DaysApart (FirstSunday, StartofWeek (DT)) div 7 + WeekOfs;
  463. end;
  464.  
  465.  
  466.  
  467. end.
  468.