YofUtils.pas

   1 unit YofUtils;
   2
   3 interface
   4
   5 //==================================================
   6 uses
   7 //==================================================
   8
   9   {$IFDEF LINUX}
  10     QForms,
  11   {$ENDIF}
  12   {$IFDEF MSWINDOWS}
  13     Windows, ShellApi, Forms,
  14   {$ENDIF}
  15   Classes, SysUtils, DateUtils;
  16
  17 //==================================================
  18 type
  19 //==================================================
  20
  21         // \82í\82¯\82í\82©\82ç\82¸\8dì\82Á\82Ä\82é\82©\82ç\83o\83O\82¾\82ç\82¯\82©\82à
  22         XMLDictionary = Record
  23                 Name : string;
  24                 Value : string;
  25         end;
  26
  27         IXMLNode = class
  28         private
  29                 FNodeName : string;
  30                 FCount : Integer;
  31                 FAttributeCount : Integer;
  32                 FChildNodes : IXMLNode;
  33                 FNodes : array of IXMLNode;
  34                 FAttributes : array of XMLDictionary;
  35                 function GetAttribute( const Name : string ) : string;
  36                 function GetNode( Index : Integer ) : IXMLNode;
  37         public
  38                 constructor Create;
  39
  40                 property NodeName : string read FNodeName write FNodeName;
  41                 property Attributes[ const Name : string ] : string read GetAttribute;
  42                 property Node[ Index : Integer ] : IXMLNode read GetNode; default;
  43                 property ChildNodes : IXMLNode read FChildNodes write FChildNodes;
  44                 property Count : Integer read FCount write FCount;
  45                 procedure Add( node : IXMLNode );
  46                 procedure AddAttribute( const Name : string; const Value : string );
  47         end;
  48
  49         IXMLDocument = class( IXMLNode )
  50         private
  51                 function GetDocumentElement() : IXMLNode;
  52         public
  53                 property DocumentElement : IXMLNode read GetDocumentElement;
  54         end;
  55
  56         CryptBlock = record
  57                 b_data : array [0..63] of char;
  58         end;
  59         PCryptBlock = ^CryptBlock;
  60
  61         CryptOrdering = record
  62                 o_data : array [0..63] of char;
  63         end;
  64
  65         CryptData = record
  66                 Key : CryptBlock;
  67                 EP : ^CryptOrdering;
  68         end;
  69
  70 procedure ExtractHttpFields(
  71   const chrSep : TSysCharSet;
  72   const chrWhite : TSysCharSet;
  73   const strValue : string;
  74   var strResult : TStringList;
  75   unknownFlag : boolean = false );
  76
  77 function HtmlEncode(
  78   const strValue : string
  79   ) : string;
  80
  81 function HtmlDecode(
  82   const strValue : string
  83   ) : string;
  84
  85 function HttpEncode(
  86   const strValue : string
  87   ) : string;
  88
  89 function MatchesMask(
  90   const filename, mask : string
  91   ) : boolean;
  92
  93 procedure FileThruUntil(
  94         var f : TFileStream;
  95         const untilSet : TSysCharSet
  96 );
  97
  98 procedure FileThruWhile(
  99         var f : TFileStream;
 100         const whileSet : TSysCharSet
 101 );
 102
 103 function XMLCloseCheck(
 104         var f : TFileStream;
 105         var node : IXMLNode;
 106         ch : char;
 107         out tag : string;
 108         out closed : boolean // \8cÄ\82Ñ\8fo\82µ\82½\83\8b\81[\83`\83\93\82ª node \82ð\95Â\82¶\82é\82×\82«\82È\82ç true
 109 ) : boolean; // ch \82ð\82±\82Ì\83\8b\81[\83`\83\93\82ª\8f\88\97\9d\82µ\82½\82È\82ç true
 110
 111 function XMLReadNode(
 112         var f : TFileStream;
 113         var node : IXMLNode
 114 ) : string; // node \88È\8aO\82Ì\83m\81[\83h\82ª\95Â\82¶\82ç\82ê\82½\8fê\8d\87\82Ì\83m\81[\83h\96¼
 115
 116 function LoadXMLDocument(
 117   const fileName : string
 118   ) : IXMLDocument;
 119
 120 function get_2ch_trip(
 121         const pw : PChar
 122 ) : string;
 123
 124 //==================================================
 125 const
 126 //==================================================
 127         kXMLWhite : TSysCharSet = [#0..#$20];
 128         kXMLDQuote : TSysCharSet = ['"'];
 129         kXMLTagStart : TSysCharSet = ['<'];
 130         kXMLTagEnd : TSysCharSet = ['>'];
 131         kXMLKanji : TSysCharSet = [#$80..#$A0, #$E0..#$ff];
 132         kCryptInitialTr : CryptOrdering = ( o_data: (
 133                 #58,#50,#42,#34,#26,#18,#10, #2,#60,#52,#44,#36,#28,#20,#12, #4,
 134                 #62,#54,#46,#38,#30,#22,#14, #6,#64,#56,#48,#40,#32,#24,#16, #8,
 135                 #57,#49,#41,#33,#25,#17, #9, #1,#59,#51,#43,#35,#27,#19,#11, #3,
 136                 #61,#53,#45,#37,#29,#21,#13, #5,#63,#55,#47,#39,#31,#23,#15, #7
 137         ) );
 138
 139         kCryptFinalTr : CryptOrdering = ( o_data: (
 140                 #40, #8,#48,#16,#56,#24,#64,#32,#39, #7,#47,#15,#55,#23,#63,#31,
 141                 #38, #6,#46,#14,#54,#22,#62,#30,#37, #5,#45,#13,#53,#21,#61,#29,
 142                 #36, #4,#44,#12,#52,#20,#60,#28,#35, #3,#43,#11,#51,#19,#59,#27,
 143                 #34, #2,#42,#10,#50,#18,#58,#26,#33, #1,#41, #9,#49,#17,#57,#25
 144         ) );
 145
 146         kCryptSwap : CryptOrdering = ( o_data: (
 147                 #33,#34,#35,#36,#37,#38,#39,#40,#41,#42,#43,#44,#45,#46,#47,#48,
 148                 #49,#50,#51,#52,#53,#54,#55,#56,#57,#58,#59,#60,#61,#62,#63,#64,
 149                  #1, #2, #3, #4, #5, #6, #7, #8, #9,#10,#11,#12,#13,#14,#15,#16,
 150                 #17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,#32
 151         ) );
 152
 153         kCryptKeyTr1 : CryptOrdering = ( o_data: (
 154                 #57, #49, #41, #33, #25, #17, #9,   #1, #58, #50, #42, #34, #26, #18,
 155                 #10,  #2, #59, #51, #43, #35, #27, #19, #11,  #3, #60, #52, #44, #36,
 156                 #63, #55, #47, #39, #31, #23, #15,  #7, #62, #54, #46, #38, #30, #22,
 157                 #14,  #6, #61, #53, #45, #37, #29, #21, #13,  #5, #28, #20, #12,  #4,
 158                  #0,  #0,  #0,  #0,  #0,  #0,  #0,  #0
 159         ) );
 160
 161         kCryptKeyTr2 : CryptOrdering = ( o_data: (
 162                 #14,#17,#11,#24, #1, #5, #3,#28,#15, #6,#21,#10,
 163                 #23,#19,#12, #4,#26, #8,#16, #7,#27,#20,#13, #2,
 164                 #41,#52,#31,#37,#47,#55,#30,#40,#51,#45,#33,#48,
 165                 #44,#49,#39,#56,#34,#53,#46,#42,#50,#36,#29,#32,
 166                  #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
 167                  #0, #0, #0, #0
 168         ) );
 169
 170         kCryptEtr : CryptOrdering = ( o_data: (
 171                 #32, #1, #2, #3, #4, #5, #4, #5, #6, #7, #8, #9,
 172                  #8, #9,#10,#11,#12,#13,#12,#13,#14,#15,#16,#17,
 173                 #16,#17,#18,#19,#20,#21,#20,#21,#22,#23,#24,#25,
 174                 #24,#25,#26,#27,#28,#29,#28,#29,#30,#31,#32, #1,
 175                  #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
 176                  #0, #0, #0, #0
 177         ) );
 178
 179         kCryptPtr : CryptOrdering = ( o_data: (
 180                 #16, #7,#20,#21,#29,#12,#28,#17, #1,#15,#23,#26, #5,#18,#31,#10,
 181                  #2, #8,#24,#14,#32,#27, #3, #9,#19,#13,#30, #6,#22,#11, #4,#25,
 182                  #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
 183                  #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0
 184         ) );
 185
 186         kCryptS_boxes : array [ 0..7, 0..63 ] of Char = (
 187         (       #14, #4,#13, #1, #2,#15,#11, #8, #3,#10, #6,#12, #5, #9, #0, #7,
 188                  #0,#15, #7, #4,#14, #2,#13, #1,#10, #6,#12,#11, #9, #5, #3, #8,
 189                  #4, #1,#14, #8,#13, #6, #2,#11,#15,#12, #9, #7, #3,#10, #5, #0,
 190                 #15,#12, #8, #2, #4, #9, #1, #7, #5,#11, #3,#14,#10, #0, #6,#13
 191         ),
 192
 193         (       #15, #1, #8,#14, #6,#11, #3, #4, #9, #7, #2,#13,#12, #0, #5,#10,
 194                  #3,#13, #4, #7,#15, #2, #8,#14,#12, #0, #1,#10, #6, #9,#11, #5,
 195                  #0,#14, #7,#11,#10, #4,#13, #1, #5, #8,#12, #6, #9, #3, #2,#15,
 196                 #13, #8,#10, #1, #3,#15, #4, #2,#11, #6, #7,#12, #0, #5,#14, #9
 197         ),
 198
 199         (       #10, #0, #9,#14, #6, #3,#15, #5, #1,#13,#12, #7,#11, #4, #2, #8,
 200                 #13, #7, #0, #9, #3, #4, #6,#10, #2, #8, #5,#14,#12,#11,#15, #1,
 201                 #13, #6, #4, #9, #8,#15, #3, #0,#11, #1, #2,#12, #5,#10,#14, #7,
 202                  #1,#10,#13, #0, #6, #9, #8, #7, #4,#15,#14, #3,#11, #5, #2,#12
 203         ),
 204
 205         (        #7,#13,#14, #3, #0, #6, #9,#10, #1, #2, #8, #5,#11,#12, #4,#15,
 206                 #13, #8,#11, #5, #6,#15, #0, #3, #4, #7, #2,#12, #1,#10,#14, #9,
 207                 #10, #6, #9, #0,#12,#11, #7,#13,#15, #1, #3,#14, #5, #2, #8, #4,
 208                  #3,#15, #0, #6,#10, #1,#13, #8, #9, #4, #5,#11,#12, #7, #2,#14
 209         ),
 210
 211         (        #2,#12, #4, #1, #7,#10,#11, #6, #8, #5, #3,#15,#13, #0,#14, #9,
 212                 #14,#11, #2,#12, #4, #7,#13, #1, #5, #0,#15,#10, #3, #9, #8, #6,
 213                  #4, #2, #1,#11,#10,#13, #7, #8,#15, #9,#12, #5, #6, #3, #0,#14,
 214                 #11, #8,#12, #7, #1,#14, #2,#13, #6,#15, #0, #9,#10, #4, #5, #3
 215         ),
 216
 217         (       #12, #1,#10,#15, #9, #2, #6, #8, #0,#13, #3, #4,#14, #7, #5,#11,
 218                 #10,#15, #4, #2, #7,#12, #9, #5, #6, #1,#13,#14, #0,#11, #3, #8,
 219                  #9,#14,#15, #5, #2, #8,#12, #3, #7, #0, #4,#10, #1,#13,#11, #6,
 220                  #4, #3, #2,#12, #9, #5,#15,#10,#11,#14, #1, #7, #6, #0, #8,#13
 221         ),
 222
 223         (        #4,#11, #2,#14,#15, #0, #8,#13, #3,#12, #9, #7, #5,#10, #6, #1,
 224                 #13, #0,#11, #7, #4, #9, #1,#10,#14, #3, #5,#12, #2,#15, #8, #6,
 225                  #1, #4,#11,#13,#12, #3, #7,#14,#10,#15, #6, #8, #0, #5, #9, #2,
 226                  #6,#11,#13, #8, #1, #4,#10, #7, #9, #5, #0,#15,#14, #2, #3,#12
 227         ),
 228
 229         (       #13, #2, #8, #4, #6,#15,#11, #1,#10, #9, #3,#14, #5, #0,#12, #7,
 230                  #1,#15,#13, #8,#10, #3, #7, #4,#12, #5, #6,#11, #0,#14, #9, #2,
 231                  #7,#11, #4, #1, #9,#12,#14, #2, #0, #6,#10,#13,#15, #3, #5, #8,
 232                  #2, #1,#14, #7, #4,#10, #8,#13,#15,#12, #9, #0, #3, #5, #6,#11
 233         )
 234         );
 235
 236         kCryptRots : array [ 0..15 ] of Integer = (
 237                 1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1
 238         );
 239
 240 //==================================================
 241 implementation
 242 //==================================================
 243
 244 // Constructor
 245 constructor IXMLNode.Create();
 246 begin
 247         FCount := 0;
 248 end;
 249
 250 function IXMLNode.GetAttribute( const Name : string ) : string;
 251 var
 252         i : Integer;
 253 begin
 254         i := 0;
 255         while i < FAttributeCount do
 256         begin
 257                 if Name = FAttributes[ i ].Name then
 258                 begin
 259                         Result := FAttributes[ i ].Value;
 260                         exit;
 261                 end;
 262
 263                 Inc( i );
 264         end;
 265 end;
 266
 267 function IXMLNode.GetNode( Index : Integer ) : IXMLNode;
 268 begin
 269         Result := FNodes[ Index ];
 270 end;
 271
 272 procedure IXMLNode.Add( node : IXMLNode );
 273 begin
 274         Inc( FCount );
 275         SetLength( FNodes, FCount );
 276         FNodes[ FCount - 1 ] := node;
 277 end;
 278
 279 procedure IXMLNode.AddAttribute(
 280         const Name : string;
 281         const Value : string
 282 );
 283 var
 284         index : Integer;
 285 begin
 286         index := FAttributeCount;
 287         Inc( FAttributeCount );
 288         SetLength( FAttributes, FAttributeCount );
 289         FAttributes[ index ].Name := Name;
 290         FAttributes[ index ].Value := Value;
 291 end;
 292
 293 function IXMLDocument.GetDocumentElement() : IXMLNode;
 294 begin
 295         Result := FChildNodes[ 0 ];
 296 end;
 297
 298 // \82Æ\82è\82 \82¦\82¸\82Ì\91ã\97p\95i\82È\82Ì\82Å chrWhite \82ð\8dl\97¶\82µ\82Ä\82¢\82È\82¢\82±\82Æ\82É\92\8d\88Ó\81I\81I\81I
 299 procedure ExtractHttpFields(
 300   const chrSep : TSysCharSet;
 301   const chrWhite : TSysCharSet;
 302   const strValue : string;
 303   var strResult : TStringList;
 304   unknownFlag : boolean = false
 305   );
 306 var
 307   last, p, strLen : Integer;
 308 begin
 309
 310   strLen := Length( strValue );
 311   p := 1;
 312   last := 1;
 313
 314   while p <= strLen do
 315   begin
 316
 317     if strValue[ p ] in chrSep then
 318     begin
 319       strResult.Add( Copy( strValue, last, p - last ) );
 320       last := p + 1;
 321     end;
 322
 323     p := p + 1;
 324
 325   end;
 326
 327   if last <> p then
 328         strResult.Add( Copy( strValue, last, strLen - last + 1 ) );
 329
 330 end;
 331
 332 function HtmlEncode(
 333   const strValue : string
 334   ) : string;
 335 var
 336   i : Integer;
 337   strLen : Integer;
 338   strResult : string;
 339 begin
 340
 341   strLen := Length( strValue );
 342   i := 1;
 343
 344   while i <= strLen do
 345   begin
 346
 347     case strValue[ i ] of
 348     '&':
 349       begin
 350         strResult := strResult + '&amp;';
 351       end;
 352     '<':
 353       begin
 354         strResult := strResult + '&lt;';
 355       end;
 356     '>':
 357       begin
 358         strResult := strResult + '&gt;';
 359       end;
 360     '"':
 361       begin
 362         strResult := strResult + '&quot;';
 363       end;
 364     else
 365       begin
 366         if strValue[ i ] in kXMLKanji then
 367         begin
 368                 strResult := strResult + strValue[ i ];
 369                 Inc( i );
 370         end;
 371         strResult := strResult + strValue[ i ];
 372       end;
 373     end;
 374
 375     i := i + 1;
 376
 377   end;
 378
 379   Result := strResult;
 380
 381 end;
 382
 383 function HtmlDecode(
 384   const strValue : string
 385   ) : string;
 386 var
 387   strResult : string;
 388 begin
 389
 390         strResult := StringReplace( strValue, '&lt;', '<', [rfReplaceAll] );
 391         strResult := StringReplace( strResult, '&gt;', '>', [rfReplaceAll] );
 392         strResult := StringReplace( strResult, '&quot;', '"', [rfReplaceAll] );
 393         strResult := StringReplace( strResult, '&amp;', '&', [rfReplaceAll] );
 394
 395         Result := strResult;
 396
 397 end;
 398
 399 function HttpEncode(
 400   const strValue : string
 401   ) : string;
 402 var
 403   i : Integer;
 404   strLen : Integer;
 405   strResult : string;
 406   b : Integer;
 407 const
 408   kHexCode : array [0..15] of char = (
 409         '0', '1', '2', '3', '4', '5', '6', '7',
 410         '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
 411 begin
 412
 413   strLen := Length( strValue );
 414   i := 1;
 415
 416   while i <= strLen do
 417   begin
 418
 419     case strValue[ i ] of
 420     '0' .. '9', 'a' .. 'z', 'A' .. 'Z', '*', '-', '.', '@', '_':
 421       begin
 422         strResult := strResult + strValue[ i ];
 423       end;
 424     else
 425       begin
 426         b := Integer( strValue[ i ] );
 427         strResult := strResult + '%'
 428                 + kHexCode[ b div $10 ]
 429                 + kHexCode[ b mod $10 ];
 430       end;
 431     end;
 432
 433     i := i + 1;
 434
 435   end;
 436
 437   Result := strResult;
 438
 439 end;
 440
 441 // \82Æ\82è\82 \82¦\82¸\82Ì\91ã\97p\95i\82È\82Ì\82Å [] \82ð\8eg\82Á\82½\90³\8bK\95\\8c»\82ð\8dl\97¶\82µ\82Ä\82¢\82È\82¢\82±\82Æ\82É\92\8d\88Ó\81I\81I\81I
 442 function MatchesMask(
 443   const filename, mask : string
 444   ) : boolean;
 445 var
 446   pName, pMask : Integer;
 447   nameLen, maskLen : Integer;
 448   chrUpMask : char;
 449 begin
 450
 451   nameLen := Length( filename );
 452   maskLen := Length( mask );
 453   pName := 0;
 454   pMask := 0;
 455
 456   while (pMask < maskLen) and (pName < nameLen) do
 457   begin
 458
 459     case mask[ pMask ] of
 460     '?':
 461       begin
 462         // \82±\82Ì 1 \8e\9a\82Í\89½\82à\82µ\82È\82¢
 463       end;
 464     '*':
 465       begin
 466         pMask := pMask + 1;
 467         // mask \82ð\91\96\8d¸\82µ\90Ø\82Á\82½\82ç\8fI\97¹
 468         if pMask >= maskLen then
 469         begin
 470           Result := true;
 471           exit;
 472         end;
 473
 474         // * \82Ì\8e\9f\82Ì\95¶\8e\9a\82ª\97\88\82é\82Ü\82Å\94ò\82Î\82·
 475         chrUpMask := upcase( mask[ pMask ] );
 476         while chrUpMask <> UpCase( filename[ pName ] ) do
 477         begin
 478           pName := pName + 1;
 479           if pName >= nameLen then
 480           begin
 481             Result := true;
 482             exit;
 483           end;
 484         end;
 485
 486         // * \82Ì\8e\9f\82Ì\95¶\8e\9a\82ª\8c©\82Â\82©\82ç\82È\82©\82Á\82½\82ç\8fI\97¹
 487         if chrUpMask <> UpCase( filename[ pName ] ) then
 488         begin
 489           Result := false;
 490           exit;
 491         end;
 492
 493         pName := pName + 1;
 494         pMask := pMask + 1;
 495       end;
 496     else
 497       begin
 498         // \82±\82Ì 1 \95¶\8e\9a\82ª\88á\82Á\82½\82ç\8fI\97¹
 499         if UpCase( mask[ pMask ] ) <> UpCase( filename[ pName ] ) then
 500         begin
 501           Result := false;
 502           exit;
 503         end;
 504
 505       end;
 506     end;
 507
 508     // \8e\9f\82Ì\95¶\8e\9a\82Ö
 509     pName := pName + 1;
 510     pMask := pMask + 1;
 511
 512   end;
 513
 514   if (pMask >= maskLen) and (pName >= nameLen) then
 515     Result := true
 516   else
 517     Result := false;
 518
 519 end;
 520
 521 // untilSet \82É\82È\82é\82Ü\82Å\94ò\82Î\82·
 522 procedure FileThruUntil(
 523         var f : TFileStream;
 524         const untilSet : TSysCharSet
 525 );
 526 var
 527         ch : char;
 528 begin
 529         while f.Position < f.Size do
 530         begin
 531                 f.ReadBuffer( ch, 1 );
 532                 if ch in untilSet then
 533                 begin
 534                         f.Seek( -1, soFromCurrent );
 535                         exit;
 536                 end else if ch in kXMLKanji then
 537                         f.Seek( 1, soFromCurrent );
 538         end;
 539 end;
 540
 541 // whileSet \82Ì\8aÔ\94ò\82Î\82·
 542 procedure FileThruWhile(
 543         var f : TFileStream;
 544         const whileSet : TSysCharSet
 545 );
 546 var
 547         ch : char;
 548 begin
 549         while f.Position < f.Size do
 550         begin
 551                 f.ReadBuffer( ch, 1 );
 552                 if ch in whileSet then
 553                 begin
 554                         if ch in kXMLKanji then
 555                                 f.ReadBuffer( ch, 1 );
 556                 end else begin
 557                         f.Seek( -1, soFromCurrent );
 558                         exit;
 559                 end;
 560         end;
 561 end;
 562
 563 function XMLCloseCheck(
 564         var f : TFileStream;
 565         var node : IXMLNode;
 566         ch : char;
 567         out tag : string;
 568         out closed : boolean
 569 ) : boolean; // ch \82ð\82±\82Ì\83\8b\81[\83`\83\93\82ª\8f\88\97\9d\82µ\82½\82È\82ç true
 570 var
 571         last : Integer;
 572         tagLen : Integer;
 573 begin
 574         closed := false;
 575         Result := false;
 576         tag := '';
 577
 578         if ch = '>' then
 579         begin
 580                 // \8aJ\8en\83^\83O\82Ì\8dÅ\8cã\82Ü\82Å\93Ç\82ñ\82¾
 581                 Result := true;
 582         end else if ch = '?' then
 583         begin
 584                 // <?xml?> \82Ý\82½\82¢\82È\82â\82Â\81B\82æ\82Á\82Ä\96³\8e\8b
 585                 FileThruUntil( f, kXMLTagEnd );
 586                 FileThruUntil( f, kXMLTagStart );
 587                 f.Seek( 1, soFromCurrent );
 588                 FileThruWhile( f, kXMLWhite );
 589                 //closed := true;
 590                 Result := true;
 591         end else if ch = '/' then
 592         begin
 593                 // \83^\83O\96¼\82ð\93Ç\82Ý\8d\9e\82ñ\82Å\95Ô\82·
 594                 last := f.Position;
 595                 FileThruUntil( f, kXMLTagEnd );
 596                 tagLen := f.Position - last;
 597                 SetLength( tag, tagLen );
 598
 599                 f.Seek( last, soFromBeginning );
 600                 f.ReadBuffer( PChar( tag )^, tagLen );
 601
 602                 f.Seek( f.Position + 1, soFromBeginning ); // '>' \94ò\82Î\82µ
 603                 closed := true;
 604                 Result := true;
 605         end;
 606 end;
 607
 608 function XMLReadNode(
 609         var f : TFileStream;
 610         var node : IXMLNode
 611 ) : string; // node \88È\8aO\82Ì\83m\81[\83h\82ª\95Â\82¶\82ç\82ê\82½\8fê\8d\87\82Ì\83m\81[\83h\96¼
 612 var
 613         child : IXMLNode;
 614
 615         last : Integer;
 616         tag : string;
 617         tagLen : Integer;
 618
 619         isClosed : boolean;
 620
 621         attributeName : string;
 622         attributeValue : string;
 623
 624         ch : char;
 625 label
 626         NextNode;
 627 begin
 628         try
 629                 // node \82Ì\93Ç\82Ý\8d\9e\82Ý(1 \83\8b\81[\83v\82É\82Â\82« 1 \83m\81[\83h)
 630                 node.ChildNodes := IXMLNode.Create;
 631
 632                 while f.Position < f.Size do
 633                 begin
 634                         // NodeName \93Ç\82Ý\8d\9e\82Ý
 635                         FileThruWhile( f, kXMLWhite );
 636
 637                         while f.Position < f.Size do
 638                         begin
 639                                 f.ReadBuffer( ch, 1 );
 640
 641                                 if XMLCloseCheck( f, node, ch, tag, isClosed ) then
 642                                 begin
 643                                         if isClosed then
 644                                         begin
 645                                                 Result := tag;
 646                                                 exit;
 647                                         end;
 648
 649                                         goto NextNode;
 650                                 end else if ch = '<' then
 651                                 begin
 652                                         // \90V\8bK\83m\81[\83h
 653                                         child := IXMLNode.Create;
 654                                         tag := XMLReadNode( f, child );
 655                                         node.ChildNodes.Add( child );
 656
 657                                         // \83^\83O\82ª\95Â\82¶\82ç\82ê\82½
 658                                         if Length( tag ) > 0 then
 659                                         begin
 660                                                 // \8e©\95ª\82Ì\82à\82Ì\82©\83`\83F\83b\83N\82µ\82Ä\81A\88á\82¦\82Î\90e\82É\95Ô\82·
 661                                                 if tag <> node.NodeName then
 662                                                         Result := tag;
 663                                                 exit;
 664                                         end;
 665
 666                                         goto NextNode;
 667                                 end else if ch in kXMLWhite then
 668                                 begin
 669                                         // NodeName \8a®\97¹
 670                                         break;
 671                                 end else begin
 672                                         node.NodeName := node.NodeName + ch;
 673
 674                                         if ch in kXMLKanji then
 675                                         begin
 676                                                 f.ReadBuffer( ch, 1 );
 677                                                 node.NodeName := node.NodeName + ch;
 678                                         end;
 679                                 end;
 680                         end;
 681
 682                         // Attribute \82Ì\93Ç\82Ý\8d\9e\82Ý
 683                         while f.Position < f.Size do
 684                         begin
 685                                 // Attribute \82Ì\96¼\91O\82ð\93Ç\82Ý\8d\9e\82Ý
 686                                 attributeName := '';
 687                                 attributeValue := '';
 688
 689                                 FileThruWhile( f, kXMLWhite );
 690
 691                                 while f.Position < f.Size do
 692                                 begin
 693                                         f.ReadBuffer( ch, 1 );
 694
 695                                         if XMLCloseCheck( f, node, ch, tag, isClosed ) then
 696                                         begin
 697                                                 if isClosed then
 698                                                 begin
 699                                                         // \83^\83O\82ª\95Â\82¶\82ç\82ê\82½\82Ì\82Å\83\8a\83^\81[\83\93
 700                                                         // \81¦NodeName \82ð\92Ê\89ß\82µ\82Ä\82é\82Ì\82Å\93r\92\86\82Å\95Â\82¶\82Ä\82é\82±\82Æ\82É\82È\82é\81B
 701                                                         // \82æ\82Á\82Ä\93Æ\97§\83m\81[\83h\81B
 702                                                         exit;
 703                                                 end;
 704
 705                                                 // \8e\9f\82Ì\83m\81[\83h\82Ö
 706                                                 goto NextNode;
 707                                         end else if ch = '=' then
 708                                         begin
 709                                                 // \82±\82±\82©\82ç\82Í\92l\82ª\8en\82Ü\82é\82Ì\82Å\96¼\91O\82Í\8fI\97¹
 710                                                 break;
 711                                         end else if ch in kXMLWhite then
 712                                         begin
 713                                                 // Value \82ª\91¶\8dÝ\82µ\82È\82¢(\8bK\8ai\8aO)\82Ì\82Å\8e\9f\82Ì\83m\81[\83h\82Ö
 714                                                 goto NextNode;
 715                                         end else begin
 716                                                 attributeName := attributeName + ch;
 717
 718                                                 if ch in kXMLKanji then
 719                                                 begin
 720                                                         f.ReadBuffer( ch, 1 );
 721                                                         attributeName := attributeName + ch;
 722                                                 end;
 723                                         end;
 724
 725                                 end;
 726
 727                                 // Attribute \82Ì\92l\82ð\93Ç\82Ý\8d\9e\82Ý
 728                                 FileThruWhile( f, kXMLWhite );
 729
 730                                 while f.Position < f.Size do
 731                                 begin
 732                                         f.ReadBuffer( ch, 1 );
 733
 734                                         if XMLCloseCheck( f, node, ch, tag, isClosed ) then
 735                                         begin
 736                                                 if isClosed then
 737                                                 begin
 738                                                         if Length( attributeName ) > 0 then
 739                                                                 // \8bK\8ai\8aO\82¾\82¯\82Ç\82Ë
 740                                                                 node.AddAttribute( attributeName, attributeValue );
 741
 742                                                         // \83^\83O\82ª\95Â\82¶\82ç\82ê\82½\82Ì\82Å\83\8a\83^\81[\83\93
 743                                                         // \81¦NodeName \82ð\92Ê\89ß\82µ\82Ä\82é\82Ì\82Å\93r\92\86\82Å\95Â\82¶\82Ä\82é\82±\82Æ\82É\82È\82é\81B
 744                                                         // \82æ\82Á\82Ä\93Æ\97§\83m\81[\83h\81B
 745                                                         exit;
 746                                                 end;
 747
 748                                                 // \8e\9f\82Ì\83m\81[\83h\82Ö
 749                                                 goto NextNode;
 750                                         end else if ch = '"' then
 751                                         begin
 752                                                 // \92l\82ª "" \82Å\8a\87\82ç\82ê\82Ä\82é\82Ì\82Å(\82Ä\82¢\82¤\82©\8a\87\82ç\82ê\82Ä\82È\82«\82á\82¢\82¯\82È\82¢\82ñ\82¾\82¯\82Ç)
 753                                                 // \92l\82ð\88ê\8a\87\93Ç\82Ý\8d\9e\82Ý
 754                                                 last := f.Position;
 755                                                 FileThruUntil( f, kXMLDQuote );
 756                                                 tagLen := f.Position - last;
 757                                                 SetLength( attributeValue, tagLen );
 758
 759                                                 f.Seek( last, soFromBeginning );
 760                                                 f.ReadBuffer( PChar( attributeValue )^, tagLen );
 761
 762                                                 node.AddAttribute( attributeName, HtmlDecode( attributeValue ) );
 763
 764                                                 // \92l\82ð\93Ç\82Ý\8fI\82í\82Á\82½\82Ì\82Å\8fI\97¹
 765                                                 f.Seek( f.Position + 1, soFromBeginning ); // '"' \94ò\82Î\82µ
 766                                                 break;
 767                                         end else if ch in kXMLWhite then
 768                                         begin
 769                                                 // \8bK\8ai\8aO\82¾\82¯\82Ç\82Ë
 770                                                 node.AddAttribute( attributeName, HtmlDecode( attributeValue ) );
 771
 772                                                 goto NextNode;
 773                                         end else begin
 774                                                 // \8bK\8ai\8aO\82¾\82¯\82Ç\88ê\89\9e\8eæ\82Á\82Ä\82¨\82
 775                                                 attributeValue := attributeValue + ch;
 776
 777                                                 if ch in kXMLKanji then
 778                                                 begin
 779                                                         f.ReadBuffer( ch, 1 );
 780                                                         attributeValue := attributeValue + ch;
 781                                                 end;
 782                                         end;
 783                                 end;
 784                         end; // Attribute \82Ì\93Ç\82Ý\8d\9e\82Ý
 785
 786                         NextNode:;
 787                 end; // // node \82Ì\93Ç\82Ý\8d\9e\82Ý(1 \83\8b\81[\83v\82É\82Â\82« 1 \83m\81[\83h)
 788         finally
 789         end;
 790 end;
 791
 792 function LoadXMLDocument(
 793   const fileName : string
 794   ) : IXMLDocument;
 795 type
 796         xmlMode = ( xmlHoge );
 797 var
 798         xmlFile : TFileStream;
 799         doc : IXMLDocument;
 800 begin
 801
 802         doc := IXMLDocument.Create;
 803
 804         xmlFile := TFileStream.Create( fileName, fmOpenRead );
 805         XMLReadNode( xmlFile, IXMLNode( doc ) );
 806         xmlFile.Destroy;
 807
 808         Result := doc;
 809
 810 end;
 811
 812 procedure memcpy(
 813         dst : PChar;
 814         src : PChar;
 815         size : Integer
 816 );
 817 begin
 818         while size > 0 do
 819         begin
 820                 dst^ := src^;
 821                 Inc( dst );
 822                 Inc( src );
 823                 Dec( size );
 824         end;
 825 end;
 826
 827 procedure transpose(
 828         var data : CryptBlock;
 829         var t : CryptOrdering;
 830         n : Integer
 831 );
 832 var
 833         x : CryptBlock;
 834 begin
 835         x := data;
 836
 837         while n > 0 do
 838         begin
 839                 Dec( n );
 840                 data.b_data[ n ] := x.b_data[ Integer( t.o_data[ n ] ) - 1 ];
 841         end;
 842 end;
 843
 844 procedure rotate(
 845         var key : CryptBlock
 846 );
 847 var
 848         p : PChar;
 849         ep : PChar;
 850         data0, data28 : Char;
 851 begin
 852         p := key.b_data;
 853         ep := @(key.b_data[ 55 ]);
 854         data0 := key.b_data[ 0 ];
 855         data28 := key.b_data[ 28 ];
 856
 857         while p < ep do
 858         begin
 859                 Inc( p );
 860                 p[ -1 ] := p^;
 861         end;
 862         key.b_data[ 27 ] := data0;
 863         key.b_data[ 55 ] := data28;
 864 end;
 865
 866 procedure f(
 867         i : Integer;
 868         var key : CryptBlock;
 869         var a : CryptBlock;
 870         var x : CryptBlock;
 871         var data : CryptData
 872 );
 873 var
 874         e, ikey, y : CryptBlock;
 875         k : Integer;
 876         p, q, r : PChar;
 877
 878         xb, ir : Integer;
 879
 880         temp : CryptOrdering;
 881 begin
 882         e := a;
 883         transpose( e, data.EP^, 48 );
 884         for k := kCryptRots[ i ] downto 1
 885                 do rotate( key );
 886         ikey := key;
 887         temp := kCryptKeyTr2;    transpose( ikey, temp, 48 );
 888         p := @(y.b_data[ 48 ]);
 889         q := @(e.b_data[ 48 ]);
 890         r := @(ikey.b_data[ 48 ]);
 891         while p > y.b_data do
 892         begin
 893                 Dec( p );
 894                 Dec( q );
 895                 Dec( r );
 896                 p^ := Char( Integer( q^ ) xor Integer( r^ ) );
 897         end;
 898         q := x.b_data;
 899         for k := 0 to 7 do
 900         begin
 901                 ir := Integer( p^ ) shl 5; Inc( p );
 902                 ir := ir + Integer( p^ ) shl 3; Inc( p );
 903                 ir := ir + Integer( p^ ) shl 2; Inc( p );
 904                 ir := ir + Integer( p^ ) shl 1; Inc( p );
 905                 ir := ir + Integer( p^ );       Inc( p );
 906                 ir := ir + Integer( p^ ) shl 4; Inc( p );
 907
 908                 xb := Integer( kCryptS_Boxes[ k, ir ] );
 909
 910                 q^ := Char( (xb shr 3) and 1 ); Inc( q );
 911                 q^ := Char( (xb shr 2) and 1 ); Inc( q );
 912                 q^ := Char( (xb shr 1) and 1 ); Inc( q );
 913                 q^ := Char(  xb        and 1 ); Inc( q );
 914         end;
 915         temp := kCryptPtr;      transpose( x, temp, 32 );
 916 end;
 917
 918 procedure setkey_r(
 919         k : PChar;
 920         var data : CryptData
 921 );
 922 var
 923         //key : CryptBlock;
 924
 925         temp : CryptOrdering;
 926 begin
 927         memcpy( data.Key.b_data, k, sizeof(CryptBlock) );
 928         temp := kCryptKeyTr1;   transpose( data.Key, temp, 56 );
 929 end;
 930
 931 procedure encrypt_r(
 932         blck : PChar;
 933         edflag : Integer;
 934         var data : CryptData
 935 );
 936 var
 937         key : PCryptBlock;
 938         p : PCryptBlock;
 939         i : Integer;
 940
 941         j : Integer;
 942         k : Integer;
 943         b, x : CryptBlock;
 944
 945         temp : CryptOrdering;
 946 begin
 947         key := @data.Key;
 948         p := PCryptBlock( blck );
 949
 950         temp := kCryptInitialTr;transpose( p^, temp, 64 );
 951         for i := 15 downto 0 do
 952         begin
 953                 if edflag <> 0 then
 954                         j := i
 955                 else
 956                         j := 15 - i;
 957
 958                 b := p^;
 959                 for k := 31 downto 0
 960                         do p^.b_data[ k ] := b.b_data[ k + 32 ];
 961                 f( j, key^, p^, x, data );
 962                 for k := 31 downto 0
 963                         do p^.b_data[ k + 32 ] := Char( Integer( b.b_data[ k ] ) xor Integer( x.b_data[ k ] ) );
 964         end;
 965         temp := kCryptSwap;     transpose( p^, temp, 64 );
 966         temp := kCryptFinalTr;  transpose( p^, temp, 64 );
 967 end;
 968
 969 function crypt_r(
 970         pw : PChar;
 971         salt : PChar;
 972         var data : CryptData
 973 ) : string;
 974 var
 975         pwb : array [0..65] of char;
 976         cp : PChar;
 977         ret : array [0..15] of char;
 978         p : PChar;
 979         new_etr : CryptOrdering;
 980         i : Integer;
 981
 982         j : Integer;
 983         c : Char;
 984         t : Integer;
 985         temp : Integer;
 986 begin
 987
 988         p := pwb;
 989         data.EP := @kCryptEtr;
 990         while (pw^ <> #0) and (p < pwb + 64) do
 991         begin
 992                 j := 7;
 993
 994                 while j > 0 do
 995                 begin
 996                         Dec( j );
 997                         p^ := Char( (Integer(pw^) shr j) and 1 );
 998                         Inc( p );
 999                 end;
1000                 //Dec( j );
1001
1002                 Inc( pw );
1003                 p^ := #0;
1004                 Inc( p );
1005         end;
1006         while (p < pwb + 64) do
1007         begin
1008                 p^ := #0;
1009                 Inc( p );
1010         end;
1011
1012         p := pwb;
1013         setKey_r( p, data );
1014
1015         while (p < pwb + 66) do
1016         begin
1017                 p^ := #0;
1018                 Inc( p );
1019         end;
1020
1021         new_etr := kCryptEtr;
1022         data.EP := @new_etr;
1023         if (salt[ 0 ] = #0) and (salt[ 1 ] = #0) then
1024                 salt := '**#0';
1025         for i := 0 to 1 do
1026         begin
1027                 c := salt^;
1028                 Inc( salt );
1029
1030                 ret[ i ] := c;
1031                 if c > 'Z' then
1032                         c := Char( Integer(c) - (6 + 7 + Integer('.')) )
1033                 else if c > '9' then
1034                         c := Char( Integer(c) - (7 + Integer('.')) )
1035                 else
1036                         c := Char( (Integer(c) - Integer('.')) and $ff );
1037
1038                 for j := 0 to 5 do
1039                 begin
1040                         if ((Integer(c) shr j) and 1) <> 0 then
1041                         begin
1042                                 t := 6 * i + j;
1043                                 temp := Integer( new_etr.o_data[ t ] );
1044                                 new_etr.o_data[ t ] := new_etr.o_data[ t + 24 ];
1045                                 new_etr.o_data[ t + 24 ] := Char( temp );
1046                         end;
1047                 end;
1048         end;
1049
1050         if ret[ 1 ] = #0 then
1051                 ret[ 1 ] := ret[ 0 ];
1052
1053         for i := 0 to 24 do
1054                 encrypt_r( pwb, 0, data );
1055         data.EP := @kCryptEtr;
1056
1057         p := pwb;
1058         cp := ret + 2;
1059         while p < pwb + 66 do
1060         begin
1061                 c := #0;
1062                 j := 6;
1063
1064                 while j > 0 do
1065                 begin
1066                         Dec( j );
1067                         c := Char(  (Integer(c) shl 1) or Integer(p^) );
1068                         Inc( p );
1069                 end;
1070                 //Dec( j );
1071                 c := Char( Integer(c) + Integer('.') );
1072                 if c > '9' then
1073                         c := Char( Integer(c) + 7 );
1074                 if c > 'Z' then
1075                         c := Char( Integer(c) + 6 );
1076                 cp^ := c;
1077                 Inc( cp );
1078         end;
1079         cp^ := #0;
1080         Result := ret;
1081
1082 end;
1083
1084 function get_2ch_trip(
1085         const pw : PChar
1086 ) : string;
1087 var
1088         s : CryptData;
1089         salt : array [0..2] of char;
1090
1091         i : Integer;
1092         len : Integer;
1093 begin
1094         salt[ 0 ] := #0;
1095         if pw[ 0 ] = #0 then
1096         begin
1097                 Result := '';
1098                 Exit;
1099         end;
1100
1101         if pw[ 1 ] <> #0 then
1102         begin
1103                 if pw[ 2 ] <> #0 then
1104                         len := 2
1105                 else
1106                         len := 1;
1107                 for i := 0 to len - 1 do
1108                 begin
1109                         if ('.' <= pw[ i + 1 ]) and (pw[ i + 1 ] <= 'z' ) then
1110                                 salt[ i ] := pw[ i + 1 ]
1111                         else
1112                                 salt[ i ] := '.';
1113
1114                         if Pos( salt[ i ], ':;<=>?@[\\]^_`' ) > 0 then
1115                                 salt[ i ] := Char( Integer( salt[ i ] ) + 7 );
1116                 end;
1117                 if len = 1 then
1118                         salt[ 1 ] := 'H';
1119                 salt[ 2 ] := #0;
1120         end else begin
1121                 salt[ 0 ] := 'H';
1122                 salt[ 1 ] := '.';
1123         end;
1124
1125         Result := Copy( crypt_r( pw, salt, s ), 4, 100 );
1126 end;
1127
1128 end.