MonaUtils.pas

   1 unit MonaUtils;
   2
   3 {$IOCHECKS ON}
   4
   5 {----------------------------------------------------------
   6   MonaUtils
   7
   8   --History--
   9   2002.12.10 GetDatSince\8dì\90¬
  10   2001.03.07 ExtractUrlPath\8dì\90¬
  11   2001.03.07 ExtractUrlName\8dì\90¬
  12   2001.03.08 Max\8dì\90¬
  13   2001.03.08 Min\8dì\90¬
  14   2001.03 10 EMonaError, MonaError\8dì\90¬
  15   2001.03.10 IncludeTrailingSlash\8dì\90¬
  16   2001.03.10 ExcludeTrailingSlash\8dì\90¬
  17   2001.03 10 IsUrlDelimiter\8dì\90¬
  18   2001.03 10 FindFile\8dì\90¬
  19   2001.03.10 LoadStringFromFile\8dì\90¬
  20   2001.03.10 SaveStringToFile\8dì\90¬
  21   2001.03.11 TMonaHtmlParser\8dì\90¬
  22   2001.03.11 TMonaProfiler\8dì\90¬
  23   2001.03.11 ShellOpen\8dì\90¬
  24   2001.04.06 AddHRefTag\8dì\90¬                                       < GikoNavi\82æ\82è
  25   2001.04.27 TrimHRefTag\8dì\90¬
  26   2001.04.27 DecodeHtmlEsc\8dì\90¬
  27   2001.04.27 EncodeHtmlEsc\8dì\90¬
  28   2001.04.27 ExtractHostName\8dì\90¬
  29   2001.04.27 Get2chDate\8dì\90¬                                       < GikoNavi\82æ\82è
  30   2001.04.27 ChooseString\8dì\90¬
  31   2001.04.27 ExtractQuotedStr\8dì\90¬
  32   2001.04.27 ExtractUrlLastPath\8dì\90¬
  33   2001.04.27 IsNumeric\8dì\90¬                                        < GikoNavi\82æ\82è
  34   2001.04.27 IsFloat\8dì\90¬                                          < GikoNavi\82æ\82è
  35   2001.04.27 Fmt2chToDateTime\8dì\90¬                               < Monaplorer\82æ\82è
  36   2001.04.27 AddHRefTag\82ð\83A\83b\83v\83f\81[\83g                        < GikoNavi a013\82æ\82è
  37   2001.04.27 StrCount1\8dì\90¬                                      < Monaplorer\82æ\82è
  38   2001.04.27 BackAnsiPos\8dì\90¬                                    < Monaplorer\82æ\82è
  39   2001.10.30 TMonaProfiler\82ð\88ê\92U\8aO\82·
  40   2001.10.30 TMonaHtmlParser\82É Attributes\83v\83\8d\83p\83e\83B\82ð\92Ç\89Á          < Hotzonu\82æ\82è
  41   2001.10.30 UrlToDosPath\8dì\90¬                                      < Hotzonu\82æ\82è
  42   2001.10.30 ChooseValue\8dì\90¬                                       < Hotzonu\82æ\82è
  43   2001.10.30 MargeUrl\8dì\90¬                                          < Hotzonu\82æ\82è
  44   2001.10.30 ExtractHrefUrl\8dì\90¬                                    < Hotzonu\82æ\82è
  45   2001.10.30 ZenToHan\8dì\90¬                                          < Hotzonu\82æ\82è
  46   2001.10.30 GetContentLength\8dì\90¬                                  < Hotzonu\82æ\82è
  47   2001.10.30 TrimTag\8dì\90¬                                           < Hotzonu\82æ\82è
  48   2001.10.30 AddTargetBlank\8dì\90¬                                    < Hotzonu\82æ\82è
  49   2001.11.09 ExtractDatNo\8dì\90¬
  50
  51   --Procedures--
  52   ExtractUrlPath .......... URL\82©\82ç\83p\83X\82¾\82¯\82ð\92\8a\8fo
  53   ExtractUrlName .......... URL\82©\82ç\83t\83@\83C\83\8b\96¼\82¾\82¯\82ð\92\8a\8fo
  54   IncludeTrailingSlash .... \83t\83@\83C\83\8b\96¼\82Ì\96\96\94ö\82É'/'\82ð\92Ç\89Á\82·\82é
  55   ExcludeTrailingSlash .... \83t\83@\83C\83\8b\96¼\82Ì\96\96\94ö\82©\82ç'/'\82ð\8eæ\82è\8f\9c\82
  56   IsUrlDelimiter .......... \95¶\8e\9a\97ñ\92\86\82Ì\8ew\92è\88Ê\92u\82ª / \82©\82Ç\82¤\82©
  57   Max ..................... \82Ó\82½\82Â\82Ì\88ø\90\94\82Ì\82¤\82¿\91å\82«\82¢\95û\82ð\95Ô\82·
  58   Min ..................... \82Ó\82½\82Â\82Ì\88ø\90\94\82Ì\82¤\82¿\8f¬\82³\82¢\95û\82ð\95Ô\82·
  59   FindFile ................ \8ew\92è\83p\83X\82Ì\83t\83@\83C\83\8b\82Ì TSearchRec\82ð\95Ô\82·
  60   LoadStringFromFile ...... \83t\83@\83C\83\8b\82©\82ç\95¶\8e\9a\97ñ\82ð\93Ç\82Ý\8d\9e\82Þ
  61   SaveStringToFile ........ \95¶\8e\9a\97ñ\82ð\83t\83@\83C\83\8b\82É\8f\91\82«\8fo\82·
  62   ShellOpen ............... \8ew\92è\83t\83@\83C\83\8b\93\99\82ðShellExecute
  63   AddHRefTag .............. http://\82©\82ç\8en\82Ü\82é\95¶\8e\9a\97ñ\82É A\83^\83O\82ð\82Â\82¯\82é
  64   TrimHRefTag ............. \95¶\8e\9a\97ñ\82©\82ç<A HREF\81`> </A>\83^\83O\82ð\8f\9c\8b\8e\82·\82é
  65   DecodeHtmlEsc ........... \95¶\8e\9a\97ñ\92\86\82Ì\93Á\8eê\83^\83O(&lt;\82Æ\82©)\82ð\95Ï\8a·\82·\82é
  66   EncodeHtmlEsc ........... \95¶\8e\9a\97ñ\92\86\82Ì"<"\82È\82Ç\82ð\93Á\8eê\83^\83O\82É\95Ï\8a·\82·\82é
  67   ExtractHostName ......... URL\82©\82ç\83z\83X\83g\96¼\82¾\82¯\82ð\92\8a\8fo
  68   Get2chDate .............. \93ú\95t\82ð\82Q\82¿\82á\82ñ\82Ë\82éPOST\97p\93ú\95t\82É\95Ï\8a·\82·\82é
  69   ChooseString ............ \82 \82é\83Z\83p\83\8c\81[\83^\82Å\8bæ\90Ø\82ç\82ê\82½\95¶\8e\9a\97ñ\82©\82ç
  70                             \82\8e\94Ô\96Ú\82Ì\95¶\8e\9a\97ñ\82ð\8eæ\82è\8fo\82·
  71   ExtractQuotedStr ........ \95¶\8e\9a\97ñ\82Ì\91O\8cã\82Ì\88ø\97p\95\84\82ð\8aO\82·
  72   ExtractUrlLastPath ...... URL\82Ì\8dÅ\8cã\82Ì\83p\83X\82ð\92\8a\8fo
  73   IsNumeric ............... \8ew\92è\95¶\8e\9a\97ñ\82ª\90®\90\94\82©\82Ç\82¤\82©\82ð\94»\92f\82·\82é
  74   IsFloat ................. \8ew\92è\95¶\8e\9a\97ñ\82ª\8eÀ\90\94\82©\82Ç\82¤\82©\82ð\94»\92f\82·\82é
  75   Fmt2chToDateTime ........ DAT\83t\83@\83C\83\8b\82Å\82Ì\93ú\95t\95¶\8e\9a\97ñ\82ð\93ú\95t\8c^\82É\95Ï\8a·\82·\82é
  76   StrCount1 ............... S\82Ì\92\86\82ÉSubStr\82ª\82¢\82\82Â\82 \82é\82©\83J\83E\83\93\83g\82·\82é(2\83o\83C\83g\91Î\89\9e)
  77   UrlToDosPath ............ URL\82ðDOS\8c`\8e®\82Ì\83p\83X\82É\95Ï\8a·\82·\82é
  78   ChooseValue ............. URL\82Ì ?param=value \82ÌParam\82ð\8ew\92è\82·\82é\82ÆValue\82ð\8eæ\93¾\82·\82é
  79   MargeUrl ................ \90â\91ÎURL\82Æ\91\8a\91ÎURL\82ð\83}\81[\83W\82·\82é
  80   ExtractHrefUrl .......... A HREF\83^\83O\82Ì\92\86\82©\82çURL\82ð\92\8a\8fo\82·\82é
  81   ZenToHan ................ \91S\8ap\95¶\8e\9a\97ñ\82ð\94¼\8ap\95¶\8e\9a\97ñ\82É\95Ï\8a·(Windows\82Ì\82Ý)
  82   GetContentLength ........ \8ew\92è\95¶\8e\9a\97ñ\82Ì\92·\82³\82ð\95Ô\82· (#13\82ð\8aÜ\82Ü\82È\82¢)
  83   TrimTag ................. \8ew\92è\82³\82ê\82½\95¶\8e\9a\97ñ\82©\82ç\83^\83O\82ð\8f\9c\8b\8e\82·\82é
  84   AddTargetBlank .......... A HREF\83^\83O\82É TARGET="_blank"\82ð\91}\93ü\82·\82é
  85   ExtractDatNo ............ DAT\83t\83@\83C\83\8b\96¼\82©\82ç DAT\82Ì\94Ô\8d\86\82¾\82¯\8eæ\93¾\82·\82é
  86
  87   --Classes--
  88   TMonaHtmlParser ......... HTML\83p\81[\83T\81[\83N\83\89\83X
  89   TMonaProfiler ........... \83v\83\8d\83t\83@\83C\83\89
  90
  91   --Report--
  92   SaveStringToFile \82ÍLinux\83v\83\89\83b\83g\83t\83H\81[\83\80\82Å\92·\82³\83[\83\8d\82Ì\95¶\8e\9a\97ñ\82ð\83T\83|\81[\83g\82µ\82Ü\82¹\82ñ\81B
  93   ShellOpen, MonaProfiler\82ÍLinux\83v\83\89\83b\83g\83t\83H\81[\83\80\82ð\83T\83|\81[\83g\82µ\82Ü\82¹\82ñ\81B
  94 ----------------------------------------------------------}
  95
  96 interface
  97
  98 uses
  99   {$IFDEF LINUX}
 100     QForms,
 101   {$ENDIF}
 102   {$IFDEF MSWINDOWS}
 103     Windows, ShellApi, Forms,
 104   {$ENDIF}
 105   Classes, SysUtils, HTTPApp, DateUtils;
 106
 107 //
 108 //  \97á\8aO
 109 //
 110 type
 111   EMonaError = class(Exception);
 112
 113 // EMonaError\82ðraise
 114 procedure MonaError(msg: String); overload;
 115 procedure MonaError(format: String; args: array of const); overload;
 116
 117 //
 118 //  \8eè\91±\82«\81E\8aÖ\90\94
 119 //
 120 function  ExtractUrlPath(const FileName: string): string;
 121 function  ExtractUrlName(const FileName: string): string;
 122 function  Max(A, B: Integer): Integer; overload;
 123 function  Max(A, B: Int64): Int64; overload;
 124 function  Max(A, B: Single): Single; overload;
 125 function  Max(A, B: Double): Double; overload;
 126 function  Max(A, B: Extended): Extended; overload;
 127 function  Min(A, B: Integer): Integer; overload;
 128 function  Min(A, B: Int64): Int64; overload;
 129 function  Min(A, B: Single): Single; overload;
 130 function  Min(A, B: Double): Double; overload;
 131 function  Min(A, B: Extended): Extended; overload;
 132 function  IncludeTrailingSlash(const S: string): string;
 133 function  ExcludeTrailingSlash(const S: string): string;
 134 function  IsUrlDelimiter(const S: string; Index: Integer): Boolean;
 135 function  FindFile(const FileName: String): TSearchRec;
 136 function  LoadStringFromFile(const FileName: String): String;
 137 procedure SaveStringToFile(const FileName, Str: String);
 138 procedure ShellOpen(const FileName: String); // \82Æ\82É\82©\82\8aJ\82
 139 function  AddHRefTag(s: string): string;
 140 function  TrimHRefTag(const S: string): string;
 141 function  DecodeHtmlEsc(const s: string): string;
 142 function  EncodeHtmlEsc(const s: string): string;
 143 function  ExtractHostName(const Url: string): string;
 144 function  Get2chDate(aDate: TDateTime): string;  {from GikoNavi / hiroyuki}
 145 function  GetDatSince(aDatNo: string): string;
 146 function  ChooseString(const Text, Separator: string; Index: integer): string;
 147 function  ExtractQuotedStr(S: string; Quote: char): string;
 148 function  ExtractUrlLastPath(Url: string): string;
 149 function  IsNumeric(s: string): boolean; {GikoNavi}
 150 function  Fmt2chToDateTime(Fmt2ch: String): TDateTime; {monaCommonFunc}
 151 function  StrCount1(const Substr, S: string): Integer; {monaCommonFunc}
 152 function  BackAnsiPos(const SubStr,S: String): Integer;{monaCommonFunc}
 153 function  IsFloat(s: string): boolean;
 154 function  UrlToDosPath(const Url: string): string;
 155 function  ChooseValue(const Url, Key: string): string;
 156 function  MargeUrl(const BaseUrl, NewUrl: string): string;
 157 function  ExtractHrefUrl(const s: string): string;
 158 function  ZenToHan(const s: string): string;
 159 function  GetContentLength(S : string): integer;
 160 function  TrimTag(const s: string): string;
 161 function  AddTargetBlank(const Value: string): string;
 162 function  ExtractDatNo(const DatFileName: string): string;
 163 function  DateStrToDateTime(const DateStr: string): TDateTime;
 164 //
 165 procedure testMonaUtils;
 166
 167 //
 168 //  \83N\83\89\83X\81E\83\8c\83R\81[\83h
 169 //
 170 type
 171   TMonaHtmlTokenType = (
 172     htNone,
 173     htTag,  // \83^\83O\82Ì\92\86
 174     htText  // \83^\83O\82Ì\8aO
 175     );
 176
 177   TMonaHtmlParser = class(TObject)
 178   protected
 179     p: PChar;
 180     FLine: String;
 181     FToken: String;
 182     FTokenType: TMonaHtmlTokenType;
 183     FAttributes: TStrings;
 184     procedure SetAttributes(const Value: TStrings); // Dax
 185     procedure makeAttributes(const Token: string);  // Dax
 186   public
 187     constructor Create(s: String);  virtual;
 188     destructor  Destory;  // Dax
 189     procedure Error; // \89ð\90Í\83G\83\89\81[\97á\8aO\82ð\94\90¶\82³\82¹\82é
 190     procedure Assign(s: String);
 191     procedure GetToken(ATokenType: TMonaHtmlTokenType; AToken: String; IgnoreCase: Boolean = False); overload;
 192     function GetToken: TMonaHtmlTokenType; overload;
 193     function GetToken(ATokenType: TMonaHtmlTokenType): String; overload;
 194     property Token: String read FToken;
 195     property TokenType: TMonaHtmlTokenType read FTokenType;
 196     property Attributes: TStrings   read  FAttributes write SetAttributes;  // Dax
 197   end;
 198
 199   TMonaProfiler = class(TObject)
 200   private
 201     FActive: Boolean;
 202     FStartCounter, FTotalCounter: Int64;
 203     function GetMicroSec: Integer;
 204     function GetMilliSec: Integer;
 205     function GetSec: Integer;
 206     procedure SetActive(const Value: Boolean);
 207   protected
 208     function GetCounter: Int64;
 209   public
 210     constructor Create;
 211     procedure Start;
 212     procedure Stop;
 213     procedure Clear;
 214     property Active: Boolean read FActive write SetActive;
 215     property MilliSec: Integer read GetMilliSec;
 216     property MicroSec: Integer read GetMicroSec;
 217     property Sec: Integer read GetSec;
 218   end;
 219
 220 ////////////////////////////////////////////////////////////////////////////////
 221 implementation
 222 ////////////////////////////////////////////////////////////////////////////////
 223
 224 uses
 225   MonaTest;
 226
 227 procedure MonaError(msg: String);
 228 begin
 229   raise EMonaError.Create(msg);
 230 end;
 231
 232 procedure MonaError(format: String; args: array of const);
 233 begin
 234   MonaError(SysUtils.Format(format, args));
 235 end;
 236
 237 function ExtractUrlPath(const FileName: string): string;
 238 var
 239   I: Integer;
 240 begin
 241   I := LastDelimiter('/:', FileName);
 242   Result := Copy(FileName, 1, I);
 243 end;
 244
 245 procedure testExtractUrlPath;
 246   procedure mycheck(s, s2: String);
 247   begin
 248     Check(s, ExtractUrlPath(s2));
 249   end;
 250 begin
 251   mycheck(
 252     'http://piza.2ch.net/tech/',
 253     'http://piza.2ch.net/tech/index2.html');
 254
 255   mycheck(
 256     'http://piza.2ch.net/tech/',
 257     'http://piza.2ch.net/tech/index2.html#menu');
 258
 259   mycheck(
 260     'http://',
 261     'http://www.yahoo.co.jp' );
 262
 263   mycheck(
 264     '',
 265     'www.yahoo.co.jp' );
 266 end;
 267
 268 function ExtractUrlName(const FileName: string): string;
 269 var
 270   I: Integer;
 271 begin
 272   I := LastDelimiter('/:', FileName);
 273   Result := Copy(FileName, I + 1, MaxInt);
 274 end;
 275
 276 procedure testExtractUrlName;
 277   procedure mycheck(s, s2: String);
 278   begin
 279     Check(s, ExtractUrlName(s2));
 280   end;
 281 begin
 282   mycheck(
 283     'index2.html',
 284     'http://piza.2ch.net/tech/index2.html');
 285
 286   mycheck(
 287     'index2.html#menu',
 288     'http://piza.2ch.net/tech/index2.html#menu');
 289
 290   mycheck(
 291     'www.yahoo.co.jp',
 292     'http://www.yahoo.co.jp' );
 293
 294   mycheck(
 295     'www.yahoo.co.jp',
 296     'www.yahoo.co.jp' );
 297 end;
 298
 299
 300 function Max(A, B: Integer): Integer;
 301 begin
 302   if B < A then Result := A else Result := B;
 303 end;
 304
 305 function Max(A, B: Int64): Int64;
 306 begin
 307   if B < A then Result := A else Result := B;
 308 end;
 309
 310 function Max(A, B: Single): Single;
 311 begin
 312   if B < A then Result := A else Result := B;
 313 end;
 314
 315 function Max(A, B: Double): Double;
 316 begin
 317   if B < A then Result := A else Result := B;
 318 end;
 319
 320 function Max(A, B: Extended): Extended;
 321 begin
 322   if B < A then Result := A else Result := B;
 323 end;
 324
 325 function Min(A, B: Integer): Integer;
 326 begin
 327   if A < B then Result := A else Result := B;
 328 end;
 329
 330 function Min(A, B: Int64): Int64; overload;
 331 begin
 332   if A < B then Result := A else Result := B;
 333 end;
 334
 335 function Min(A, B: Single): Single; overload;
 336 begin
 337   if A < B then Result := A else Result := B;
 338 end;
 339
 340 function Min(A, B: Double): Double; overload;
 341 begin
 342   if A < B then Result := A else Result := B;
 343 end;
 344
 345 function Min(A, B: Extended): Extended; overload;
 346 begin
 347   if A < B then Result := A else Result := B;
 348 end;
 349
 350 procedure testMaxMin;
 351 var
 352   LowInteger, HighInteger: Integer;
 353   LowInt64, HighInt64: Int64;
 354   LowSingle, HighSingle: Single;
 355   LowDouble, HighDouble: Double;
 356   LowExtended, HighExtended: Extended;
 357 begin
 358   LowInteger := Low(Integer) ; HighInteger := High(Integer);
 359   LowInt64 := Low(Int64); HighInt64 := High(Int64);
 360   LowSingle := -PI; HighSingle := PI;
 361   LowDouble := -PI; HighDouble := PI;
 362   LowExtended := -PI; HighExtended := PI;
 363   Check(
 364     HighInteger,
 365     Max(LowInteger, HighInteger));
 366   Check(
 367     HighInt64,
 368     Max(LowInt64, HighInt64));
 369   Check(
 370     HighSingle,
 371     Max(LowSingle, HighSingle));
 372   Check(
 373     HighDouble,
 374     Max(LowDouble, HighDouble));
 375   Check(
 376     HighExtended,
 377     Max(LowExtended, HighExtended));
 378   Check(
 379     LowInteger,
 380     Min(LowInteger, HighInteger));
 381   Check(
 382     LowInt64,
 383     Min(LowInt64, HighInt64));
 384   Check(
 385     LowSingle,
 386     Min(LowSingle, HighSingle));
 387   Check(
 388     LowDouble,
 389     Min(LowDouble, HighDouble));
 390   Check(
 391     LowExtended,
 392     Min(LowExtended, HighExtended));
 393 end;
 394
 395
 396
 397 //\83t\83@\83C\83\8b\96¼\82Ì\96\96\94ö\82É'\'\82ð\92Ç\89Á\82·\82é\8aÖ\90\94
 398 function IncludeTrailingSlash(const S: string): string;
 399 begin
 400   Result := S;
 401   if not IsUrlDelimiter(Result, Length(Result)) then
 402     Result := Result + '/';
 403 end;
 404
 405 procedure testIncludeTrailingSlash;
 406   procedure mycheck(s, s2: string);
 407   begin
 408     Check(s, IncludeTrailingSlash(s2));
 409   end;
 410 begin
 411     mycheck(
 412       'http://www.yahoo.co.jp/',
 413       'http://www.yahoo.co.jp' );
 414     mycheck(
 415       'http://www.yahoo.co.jp/',
 416       'http://www.yahoo.co.jp/' );
 417 end;
 418
 419 //\83t\83@\83C\83\8b\96¼\82Ì\96\96\94ö\82©\82ç'\'\82ð\8eæ\82è\8f\9c\82\8aÖ\90\94
 420 function ExcludeTrailingSlash(const S: string): string;
 421 begin
 422   Result := S;
 423   if IsUrlDelimiter(Result, Length(Result)) then
 424     SetLength(Result, Length(Result)-1);
 425 end;
 426
 427 procedure testExcludeTrailingSlash;
 428   procedure mycheck(s, s2: String);
 429   begin
 430     Check(s, ExcludeTrailingSlash(s2));
 431   end;
 432 begin
 433   mycheck(
 434     'http://www.yahoo.co.jp',
 435     'http://www.yahoo.co.jp/' );
 436   mycheck(
 437     'http://www.yahoo.co.jp',
 438     'http://www.yahoo.co.jp' );
 439 end;
 440
 441 function IsUrlDelimiter(const S: string; Index: Integer): Boolean;
 442 begin
 443   Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = '/')
 444     and (ByteType(S, Index) = mbSingleByte);
 445 end;
 446
 447 procedure testIsUrlDelimiter;
 448   procedure mycheck(b: Boolean; s: String; Index: Integer);
 449   begin
 450     Check(b, IsUrlDelimiter(s, Index));
 451   end;
 452 begin
 453   mycheck(
 454     True,
 455     'http://www.yahoo.co.jp/index.htm', 6 );
 456   mycheck(
 457     False,
 458     'http://www.yahoo.co.jp/index.htm', 3 );
 459 end;
 460
 461 //\83t\83@\83C\83\8b\82©\82ç\95¶\8e\9a\97ñ\82ð\93Ç\82Ý\8d\9e\82Þ
 462 function LoadStringFromFile(const FileName: String): String;
 463 var
 464   size: Integer;
 465   F: File;
 466 begin
 467   size := FindFile(FileName).Size;
 468   if size = 0 then
 469   begin
 470     Result := '';
 471     Exit;
 472   end;
 473
 474   try
 475     SetLength(Result, size);
 476     AssignFile(F, FileName);
 477     Reset(F, size);
 478     BlockRead(F, PChar(Result)^, 1);
 479   finally
 480     CloseFile(F);
 481   end;
 482 end;
 483
 484 procedure SaveStringToFile(const FileName, Str: String);
 485 var
 486   path: String;
 487   F: File;
 488 begin
 489   path := ExtractFileDir(FileName);
 490   if (path <> '') and not DirectoryExists(path) then
 491     {$IFDEF VER130}
 492     if ForceDirectories(path) then
 493       MonaError('\83f\83B\83\8c\83N\83g\83\8a%s\82ª\8dì\82ê\82Ü\82¹\82ñ\81B', [path]);
 494       {\83E\83G(\81L\84D\81M) \83t\83H\83\8b\83_\82ª\91¶\8dÝ\82µ\82È\82¢\8fê\8d\87\8dì\90¬\82·\82é}
 495     {$ELSE}
 496     try
 497       ForceDirectories(path);
 498     except
 499       MonaError('\83f\83B\83\8c\83N\83g\83\8a%s\82ª\8dì\82ê\82Ü\82¹\82ñ\81B', [path]);
 500     end;
 501     {$ENDIF}
 502   try
 503     AssignFile(F, FileName);
 504     Rewrite(F, Length(Str));
 505     if Length(Str) > 0 then
 506       BlockWrite(F, PChar(Str)^, 1);
 507   finally
 508     CloseFile(F);
 509   end;
 510 end;
 511
 512 procedure testLoadSaveString;
 513   procedure mycheck(s: String);
 514   var s2: String;
 515   begin
 516     try
 517       SaveStringToFile('testString.txt', s);
 518       s2 := LoadStringFromFile('testString.txt');
 519       Check(s, s2, 'testLoadSaveString');
 520     except
 521       on E:Exception do Error(E);
 522     end;
 523   end;
 524 begin
 525   mycheck('hello,world');
 526   {$IFDEF LINUX}
 527   {$ELSE}
 528   mycheck(''); //Kylix \82Å\82Í\83G\83\89\81[
 529                //\83v\83\8d\83W\83F\83N\83g Project1 \82ª EInOutError \83N\83\89\83X\82Ì\97á\8aO\82ð\90¶\90¬\82µ\82Ü\82µ\82½\81B
 530                //'\93ü\97Í\92l\82ª\90\94\92l\82Å\82Í\82 \82è\82Ü\82¹\82ñ'
 531   {$ENDIF}
 532   mycheck('test' + #13 + 'LoadString' + #10 + 'SaveString' + #13 + #10 + 'xxx');
 533 end;
 534
 535 function FindFile(const FileName: String): TSearchRec;
 536 begin
 537   if FindFirst(FileName, faAnyFile, Result) = 0 then
 538     FindClose(Result)
 539   else
 540     MonaError('%s\82Ì\8fî\95ñ\82Ì\8eæ\93¾\82É\8e¸\94s\82µ\82Ü\82µ\82½\81B', [FileName]);
 541 end;
 542
 543 procedure testFindFile;
 544 var
 545   sl: TStringList;
 546 begin
 547   sl := TStringList.Create;
 548   try
 549     sl.Text := 'hello,world';
 550     sl.SaveToFile('fileinfo.txt');
 551     with FindFile('fileinfo.txt') do
 552     begin
 553       Check(Size, Length(sl.Text));
 554       Check(Name, 'fileinfo.txt');
 555     end;
 556   finally
 557     sl.Free;
 558   end;
 559 end;
 560
 561 { TMonaHtmlParser }
 562 procedure TMonaHtmlParser.Error;
 563 begin
 564   MonaError('HTML\82Ì\89ð\90Í\82É\8e¸\94s\82µ\82Ü\82µ\82½:%s', [p]);
 565 end;
 566
 567 constructor TMonaHtmlParser.Create(s: String);
 568 begin
 569   FAttributes :=  TStringList.Create;
 570   Assign(s);
 571 end;
 572
 573 procedure TMonaHtmlParser.Assign(s: String);
 574 begin
 575   FLine := s;
 576   p := PChar(s);
 577 end;
 578
 579 function TMonaHtmlParser.GetToken: TMonaHtmlTokenType;
 580 begin
 581   FToken := '';
 582   while True do
 583     case p^ of
 584     #10, #13:
 585       Inc(p);
 586     else
 587       break;
 588     end;
 589
 590   case p^ of
 591   #0:
 592     FTokenType := htNone;
 593
 594   '<':
 595   begin
 596     FTokenType := htTag;
 597     while True do
 598     begin
 599       Inc(p);
 600       case p^ of
 601       #10, #13:
 602         ;
 603       #0, '<':
 604         Error;
 605       '>':
 606         begin
 607           makeAttributes(FToken); // add Dax 2001/10/30
 608                                 Break;
 609         end;
 610       else
 611         FToken := FToken + p^;
 612       end;
 613     end;
 614     Inc(p);
 615   end;
 616
 617   else
 618     FTokenType := htText;
 619     while True do
 620     begin
 621       case p^ of
 622       #10, #13:
 623         ;
 624       #0, '<':
 625         Break;
 626
 627       '>':
 628         Error;
 629       else
 630         FToken := FToken + p^;
 631       end;
 632       Inc(p);
 633     end;
 634   end;
 635
 636   Result := FTokenType;
 637 end;
 638
 639 function TMonaHtmlParser.GetToken(ATokenType: TMonaHtmlTokenType): String;
 640 begin
 641   if GetToken <> ATokenType then
 642     Error;
 643   Result := Token;
 644 end;
 645
 646 procedure TMonaHtmlParser.GetToken(ATokenType: TMonaHtmlTokenType;
 647   AToken: String; IgnoreCase: Boolean);
 648 begin
 649   if IgnoreCase then
 650   begin
 651     if UpperCase(GetToken(ATokenType)) <> UpperCase(AToken) then
 652       Error;
 653   end else begin
 654     if GetToken(ATokenType) <> AToken then
 655       Error;
 656   end;
 657 end;
 658
 659
 660 destructor TMonaHtmlParser.Destory;
 661 begin
 662   FAttributes.Free;
 663 end;
 664
 665 procedure TMonaHtmlParser.makeAttributes(const Token: string);
 666 var
 667   x, xend : PChar;
 668   Attr  : string;
 669   S : string;
 670 begin
 671   //'<AAA BBB=CCC DDD=EEE>'
 672   x       :=  PChar(Token);
 673   xend    :=  PChar(Token) + Length(Token) + 1;
 674   S := '';
 675   while (x < xend)  do  begin
 676     if  (x^ = ' ') or (x^ = #0) then  begin
 677       if  (Attr <> '')  then  begin
 678         FAttributes.Values[Attr]  :=  S;
 679       end;
 680       Attr  :=  '';
 681       S     :=  '';
 682     end else
 683     if  (x^ = '=')  then  begin
 684       Attr  :=  S;
 685       S     :=  '';
 686     end else begin
 687       S :=  S + x^;
 688     end;
 689     inc(x);
 690   end;
 691 end;
 692
 693 procedure TMonaHtmlParser.SetAttributes(const Value: TStrings);
 694 begin
 695   FAttributes.Assign(Value);
 696 end;
 697
 698 procedure testMonaHtmlParser;
 699 var
 700   parser: TMonaHtmlParser;
 701
 702 begin
 703   parser := TMonaHtmlParser.Create( // TStrings.Text\82È\82Ç\82ð\93n\82·
 704     '<!-- saved from url=(0032)http://www.2ch.net/bbstable.html -->' +
 705     '<html>' +#10+
 706       '<HEAD>' +#13+
 707         '<TITLE>BBS TABLE for 2ch</TITLE>' +
 708       '</HEAD>' +#13+
 709       '<Body>' +#13+#10+
 710         '\81y<B>\93é\82ê\8d\87\82¢</B>\81z' +
 711         '<A href="http://piza.2ch.net/intro/index2.html">\8e©\8cÈ\8fÐ\89î</A>' +
 712       '</Body>' +#10+#13+
 713     '</html>' +#10
 714   );
 715   with parser do
 716   try
 717     // \89ü\8ds\95¶\8e\9a\82Í\82·\82×\82Ä\96³\8e\8b\81A\91å\95¶\8e\9a\8f¬\95¶\8e\9a\82Í\8bæ\95Ê\81A
 718     // \83e\83L\83X\83g\81E\83^\83O\82Ì\92\86\90g\82Í\89ð\8eß\82¹\82¸\82É\82»\82Ì\82Ü\82Ü\95Ô\82·\81B
 719     GetToken(htTag,  '!-- saved from url=(0032)http://www.2ch.net/bbstable.html --');
 720 //    GetToken;(htTag,  'html');
 721     GetToken;
 722     Check(TokenType = htTag, 'GetToken = htTag');
 723     Check(Token, 'html');
 724
 725 //    GetToken(htTag,  'HEAD');
 726     Check(GetToken(htTag), 'HEAD');
 727
 728     GetToken(htTag,  'TITLE');
 729     GetToken(htText, 'BBS TABLE for 2ch');
 730     GetToken(htTag,  '/title', True);
 731     GetToken(htTAG,  '/HEAD');
 732     GetToken(htTag,  'Body');
 733     GetToken(htText, '\81y');
 734     GetToken(htTag,  'B');
 735     GetToken(htText, '\93é\82ê\8d\87\82¢');
 736     GetToken(htTag,  '/B');
 737     GetToken(htText, '\81z');
 738     GetToken(htTag,  'A href="http://piza.2ch.net/intro/index2.html"');
 739     GetToken(htText, '\8e©\8cÈ\8fÐ\89î');
 740     GetToken(htTag,  '/A');
 741     GetToken(htTag,  '/Body');
 742     GetToken(htTag,  '/html');
 743     Check(GetToken = htNone); // \82¨\82µ\82Ü\82¢
 744   finally
 745     Free;
 746   end;
 747 end;
 748
 749 { TMonaProfiler }
 750
 751 // PerformanceCounter\97p
 752 var TMonaProfiler_FFrequency: Int64;
 753
 754 procedure TMonaProfiler.Clear;
 755 begin
 756   FTotalCounter := 0;
 757   if FActive then
 758     FStartCounter := GetCounter;
 759 end;
 760
 761 constructor TMonaProfiler.Create;
 762 begin
 763   Clear;
 764 end;
 765
 766 function TMonaProfiler.GetCounter: Int64;
 767 begin
 768   {$IFDEF LINUX}
 769     //
 770   {$ELSE}
 771     if not QueryPerformanceCounter(Result) then
 772       RaiseLastWin32Error;
 773   {$ENDIF}
 774 end;
 775
 776 function TMonaProfiler.GetMicroSec: Integer;
 777 var
 778   counter: Int64;
 779 begin
 780   counter := FTotalCounter;
 781   if FActive then
 782     Inc(counter, GetCounter - FStartCounter);
 783   try
 784     Result := Round(counter / TMonaProfiler_FFrequency * 1000000);
 785   except
 786     Result  :=  0;
 787   end;
 788 end;
 789
 790 function TMonaProfiler.GetMilliSec: Integer;
 791 var
 792   counter: Int64;
 793 begin
 794   counter := FTotalCounter;
 795   if FActive then
 796     Inc(counter, GetCounter - FStartCounter);
 797   try
 798     Result := Round(counter / TMonaProfiler_FFrequency * 1000);
 799   except
 800     Result  :=  0;
 801   end;
 802 end;
 803
 804 function TMonaProfiler.GetSec: Integer;
 805 var
 806   counter: Int64;
 807 begin
 808   counter := FTotalCounter;
 809   if FActive then
 810     Inc(counter, GetCounter - FStartCounter);
 811   try
 812     Result := Round(counter / TMonaProfiler_FFrequency);
 813   except
 814     Result  :=  0;
 815   end;
 816 end;
 817
 818 procedure TMonaProfiler.SetActive(const Value: Boolean);
 819 begin
 820   FActive := Value;
 821   if FActive then
 822     Start
 823   else
 824     Stop;
 825 end;
 826
 827 procedure TMonaProfiler.Start;
 828 begin
 829   if FActive then
 830     Exit;
 831   FActive := True;
 832   FStartCounter := GetCounter;
 833 end;
 834
 835 procedure TMonaProfiler.Stop;
 836 begin
 837   if not FActive then
 838     Exit;
 839   Inc(FTotalCounter, GetCounter - FStartCounter);
 840   FActive := False;
 841 end;
 842
 843 procedure testMonaProfiler;
 844 var
 845   profiler: TMonaProfiler;
 846 begin
 847   profiler := TMonaProfiler.Create;
 848   try
 849     profiler.Start; // \8aJ\8en
 850     Sleep(500);
 851     profiler.Stop;
 852     Check(500, (profiler.MilliSec + 50) div 100 * 100);
 853
 854     Sleep(500);
 855
 856     profiler.Start; // \8dÄ\8aJ
 857     Sleep(1000);
 858     Check(1500, (profiler.MilliSec + 50) div 100 * 100); // \89Ò\93®\92\86\82Å\82àOK
 859     profiler.Stop;
 860
 861     profiler.Clear;
 862     Check(0, profiler.MicroSec);
 863     profiler.Start; // \8aJ\8en
 864     Sleep(500);
 865     profiler.Stop;
 866     Check(500*1000, (profiler.MicroSec + 50) div 1000 * 1000);
 867   finally
 868   end;
 869 end;
 870
 871 procedure ShellOpen(const FileName: String); // \82Æ\82É\82©\82\8aJ\82
 872 begin
 873   {$IFDEF WINDOWS}
 874     if 32 >= ShellExecute(Application.Handle, 'open', PChar(FileName), nil, nil, sw_show) then
 875       RaiseLastWin32Error;
 876   {$ELSE}
 877     // ??\82È\82ñ\82¾\82ë\82Ë??
 878   {$ENDIF}
 879 end;
 880
 881 (*
 882 function AddHRefTag(s: string): string;
 883 const
 884   NORMAL_CHAR: string = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789:/.%?&#=-_~+*;!^`\|@[]{}$,';
 885 var
 886   url: string;
 887   i: Integer;
 888   idx: Integer;
 889 begin
 890   Result := '';
 891
 892   while True do begin
 893     idx := AnsiPos('http://', s);
 894
 895     if idx = 0 then begin
 896       //\83\8a\83\93\83N\82ª\96³\82¢\81[\82æ\81B
 897       Result := Result + s;
 898       Break;
 899     end;
 900
 901     Result := Result + Copy(s, 0, idx - 1);
 902
 903     s := Copy(s, idx, length(s));
 904
 905     for i := 0 to Length(s) do begin
 906
 907       idx := AnsiPos(s[i + 1], NORMAL_CHAR);
 908
 909       if (idx = 0) or (i = (Length(s))) then begin
 910         //URL\82¶\82á\82È\82¢\95¶\8e\9a\94\8c©\81I\82Æ\82©\81A\95¶\8e\9a\82ª\82È\82\82È\82Á\82½\81B
 911         url := Copy(s, 0, i);
 912
 913         Result := Result + '<a href="' + url + '" target="_blank">' + url + '</a>';
 914         s := Copy(s, i + 1, Length(s));
 915         Break;
 916       end;
 917     end;
 918   end;
 919 end;
 920 *)
 921 function AddHRefTag(s: string): string;
 922 const
 923   NORMAL_CHAR: string = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789:/.%?&#=-_~+*;!^`\|@[]{}$,';
 924 var
 925   url: string;
 926   i, x: Integer;
 927   idx, idx1, idx2, idx3, idx4: Integer;
 928   prefix: string;
 929   s1: string;
 930 begin
 931   Result := '';
 932
 933   while True do begin
 934     idx1 := AnsiPos('http://', s);
 935     idx2 := AnsiPos('ttp://', s);
 936     idx3 := AnsiPos('www.', s);
 937
 938     if  (idx1 > 1) then  begin
 939       for x :=  idx1  downto  1 do  begin
 940         if  (s[x] = '>')  then  begin
 941           Break;
 942         end else
 943         if  (s[x] = '<')  then  begin
 944           idx1  :=  0;
 945           idx2  :=  0;
 946           idx3  :=  0;
 947           Break;
 948         end;
 949       end;
 950     end;
 951     if  (idx1 > 4) then  begin
 952       s1  :=  AnsiLowerCase(Copy(s, idx1 - 4, 4));
 953       if  (s1 <> '<br>')  and
 954           (s[idx1 - 1] = '>') then
 955       begin
 956         idx1  :=  0;
 957         idx2  :=  0;
 958         idx3  :=  0;
 959       end;
 960     end;
 961     if  ((idx3 < idx2) and (idx3 > 0)) or ((idx3 > 0) and (idx2 = 0)) then  begin
 962       // www
 963       idx  :=  idx3;
 964       prefix:=  'http://';
 965     end else
 966     if  (idx2 < idx1) or ((idx2 > 0) and (idx1 = 0)) then  begin
 967       // ttp
 968       idx  :=  idx2;
 969       prefix:=  'h';
 970     end else begin
 971       idx  :=  idx1;
 972       prefix:=  '';
 973     end;
 974
 975     if (idx1 = 0) and (idx2 = 0) and (idx3 = 0) then begin
 976       //\83\8a\83\93\83N\82ª\96³\82¢\81[\82æ\81B
 977       Result := Result + s;
 978       Break;
 979     end;
 980
 981     Result := Result + Copy(s, 0, idx - 1);
 982     s := Copy(s, idx, length(s));
 983     for i := 0 to Length(s) - 1 do begin
 984       idx4 := AnsiPos(s[i + 1], NORMAL_CHAR);
 985       if (idx4 = 0) then  begin
 986         url := Copy(s, 0, i);
 987         Result := Result + '<a href="' + prefix + url + '" target="_blank">' + url + '</a>';
 988         s := Copy(s, i + 1, Length(s));
 989         Break;
 990       end else
 991       if (i = (Length(s) - 1)) then begin
 992         //URL\82¶\82á\82È\82¢\95¶\8e\9a\94\8c©\81I\82Æ\82©\81A\95¶\8e\9a\82ª\82È\82\82È\82Á\82½\81B
 993         url := Copy(s, 0, i + 1);
 994         Result := Result + '<a href="' + prefix + url + '" target="_blank">' + url + '</a>';
 995         s := Copy(s, i + 2, Length(s));
 996         Break;
 997       end;
 998     end;
 999   end;
1000 end;
1001
1002 procedure testAddHRefTag;
1003   procedure mycheck(s, s2: String);
1004   begin
1005     Check(s, AddHRefTag(s2));
1006   end;
1007 begin
1008   mycheck(
1009     '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>',
1010     'http://piza.2ch.net/tech/');
1011   mycheck(
1012     '\8fÚ\8d×\82Í\83R\83R<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>',
1013     '\8fÚ\8d×\82Í\83R\83Rhttp://piza.2ch.net/tech/');
1014   mycheck(
1015     '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>\82¾\82æ',
1016     'http://piza.2ch.net/tech/\82¾\82æ');
1017   mycheck(
1018     '<a href="http://piza.2ch.net/tech/index2.html#menu" target="_blank">http://piza.2ch.net/tech/index2.html#menu</a>',
1019     'http://piza.2ch.net/tech/index2.html#menu');
1020   mycheck(
1021     '<a href="http://www.yahoo.com" target="_blank">http://www.yahoo.com</a>\82¾\82Á\82½\82è<a href="http://www.goo.ne.jp" target="_blank">http://www.goo.ne.jp</a>\82¾\82Á\82½\82è',
1022     'http://www.yahoo.com\82¾\82Á\82½\82èhttp://www.goo.ne.jp\82¾\82Á\82½\82è');
1023   mycheck(
1024     'https://piza.2ch.net/tech/index2.html#menu',
1025     'https://piza.2ch.net/tech/index2.html#menu');
1026   mycheck(
1027     '<a href="http://piza.2ch.net/tech/index2.html#menu0" target="_blank">http://piza.2ch.net/tech/index2.html#menu0</a>',
1028     'http://piza.2ch.net/tech/index2.html#menu0');
1029   mycheck(
1030     'http\82Å\8en\82Ü\82é',
1031     'http\82Å\8en\82Ü\82é');
1032   mycheck(
1033     '',
1034     '');
1035   mycheck(
1036     '<a href="http://www.2ch.net/tech/" target="_blank">www.2ch.net/tech/</a>',
1037     'www.2ch.net/tech/');
1038   mycheck(
1039     'www\82Æ\82©',
1040     'www\82Æ\82©');
1041   mycheck(
1042     'www ',
1043     'www ');
1044 end;
1045
1046 //
1047 //  \95¶\8e\9a\97ñ\92\86\82©\82ç <A HREF="xxx"> </A>\83^\83O\82ð\8eæ\82è\8f\9c\82«\82Ü\82·
1048 //
1049 function TrimHRefTag(const S: string): string;
1050 var
1051   x, y : integer;
1052   BodyText : string;
1053 begin
1054   BodyText  :=  StringReplace(S,'</A>', '', [rfReplaceAll,rfIgnoreCase]);
1055   while True do  begin
1056     x :=  Pos('<a ',AnsiLowerCase(BodyText));
1057     if (AnsiPos('>',AnsiLowerCase(BodyText)) = 0) then  begin
1058       Break;
1059     end;
1060     y :=  x;
1061     if  (x > 0) then  begin
1062       while true  do  begin
1063         if  (BodyText[y] = '>') and (ByteType(BodyText, y) = mbSingleByte)  then
1064         begin
1065           BodyText  :=  Copy(BodyText,1, x-1) +
1066                         Copy(BodyText,y + 1, Length(BodyText));
1067           break;
1068         end else begin
1069           inc(y);
1070           if  (y > Length(BodyText)) then  Break;
1071         end;
1072       end;
1073     end else begin
1074       Break;
1075     end;
1076   end;
1077   Result  :=  BodyText;
1078 end;
1079
1080 procedure testTrimHRefTag;
1081   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1082   begin
1083     Check(s, TrimHRefTag(s2));
1084   end;
1085 begin
1086   mycheck(
1087     'http://piza.2ch.net/tech/',
1088     '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>');
1089   mycheck(
1090     '\8fÚ\8d×\82Í\83R\83Rhttp://piza.2ch.net/tech/',
1091     '\8fÚ\8d×\82Í\83R\83R<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>');
1092   mycheck(
1093     'http://piza.2ch.net/tech/\82¾\82æ',
1094     '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>\82¾\82æ');
1095   mycheck(
1096     'http://piza.2ch.net/tech/index2.html#menu',
1097     '<a href="http://piza.2ch.net/tech/index2.html#menu" target="_blank">http://piza.2ch.net/tech/index2.html#menu</a>');
1098   mycheck(
1099     'http://www.yahoo.com\82¾\82Á\82½\82èhttp://www.goo.ne.jp\82¾\82Á\82½\82è',
1100     '<a href="http://www.yahoo.com" target="_blank">http://www.yahoo.com</a>\82¾\82Á\82½\82è<a href="http://www.goo.ne.jp" target="_blank">http://www.goo.ne.jp</a>\82¾\82Á\82½\82è');
1101   mycheck(
1102     'https://piza.2ch.net/tech/index2.html#menu',
1103     'https://piza.2ch.net/tech/index2.html#menu');
1104   mycheck(
1105     'http\82Å\8en\82Ü\82é',
1106     'http\82Å\8en\82Ü\82é');
1107   mycheck(
1108     '',
1109     '');
1110 end;
1111
1112 function DecodeHtmlEsc(const s: string): string;
1113 var
1114   DispText : string;
1115 begin
1116   DispText  :=  StringReplace(S, '<br>', #13#10, [rfIgnoreCase, rfReplaceAll]);
1117   DispText  :=  StringReplace(DispText, '&lt;', '<', [rfIgnoreCase, rfReplaceAll]);
1118   DispText  :=  StringReplace(DispText, '&gt;', '>', [rfIgnoreCase, rfReplaceAll]);
1119   DispText  :=  StringReplace(DispText, '&quot;', '"', [rfIgnoreCase, rfReplaceAll]);
1120   DispText  :=  StringReplace(DispText, '&amp;', '&', [rfIgnoreCase, rfReplaceAll]);
1121   DispText  :=  StringReplace(DispText, '&nbsp;', ' ', [rfIgnoreCase, rfReplaceAll]);
1122   Result    :=  DispText;
1123 end;
1124
1125 procedure testDecodeHtmlEsc;
1126   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1127   begin
1128     Check(s, DecodeHtmlEsc(s2));
1129   end;
1130 begin
1131   mycheck(
1132     '<HTML&XML>',
1133     '&lt;HTML&amp;XML&gt;');
1134   mycheck(
1135     'BR' + #13#10  + 'BR' + #13#10#13#10,
1136     'BR<BR>BR<BR><BR>');
1137   mycheck(
1138     '<">',
1139     '&LT;&quot;&GT;');
1140   mycheck(
1141     '  ',
1142     '&nbsp;&nbsp;');
1143   mycheck(
1144     '',
1145     '');
1146 end;
1147
1148 function EncodeHtmlEsc(const s: string): string;
1149 var
1150   DispText : string;
1151 begin
1152   DispText  :=  StringReplace(S, '&', '&amp;', [rfReplaceAll]);
1153   DispText  :=  StringReplace(DispText, '<', '&lt;', [rfReplaceAll]);
1154   DispText  :=  StringReplace(DispText, '>', '&gt;', [rfReplaceAll]);
1155   DispText  :=  StringReplace(DispText, '"', '&quot;', [rfReplaceAll]);
1156   DispText  :=  StringReplace(DispText, #13#10, '<br>', [rfReplaceAll]);
1157   Result    :=  DispText;
1158 end;
1159
1160 procedure testEncodeHtmlEsc;
1161   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1162   begin
1163     Check(s, EncodeHtmlEsc(s2));
1164   end;
1165 begin
1166   mycheck(
1167     '&lt;HTML&amp;XML&gt;',
1168     '<HTML&XML>');
1169   mycheck(
1170     'BR<br>BR<br><br>',
1171     'BR' + #13#10  + 'BR' + #13#10#13#10);
1172   mycheck(
1173     '&lt;&quot;&gt;',
1174     '<">');
1175   mycheck(
1176     '',
1177     '');
1178 end;
1179
1180 function ExtractHostName(const Url: string): string;
1181 const
1182   PRE = 'http://';
1183 var
1184   n : integer;
1185 begin
1186   if  (AnsiPos(PRE, Url) = 1) then  begin
1187     n :=  Pos('/', Copy(Url,Length(PRE)+1,Length(Url))) - 1;
1188     if  (n < 0) then  n :=  Length(Url) - Length(PRE);
1189     Result :=  Copy(Url, Length(PRE) + 1, n);
1190   end else begin
1191     Result  :=  '';
1192   end;
1193 end;
1194
1195 procedure testExtractHostName;
1196   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1197   begin
1198     Check(s, ExtractHostName(s2));
1199   end;
1200 begin
1201   mycheck(
1202     'www.2ch.net',
1203     'http://www.2ch.net/');
1204
1205   mycheck(
1206     'piza.2ch.net',
1207     'http://piza.2ch.net/tech/index2.html');
1208
1209   mycheck(
1210     'piza.2ch.net',
1211     'http://piza.2ch.net/tech/index2.html#menu');
1212
1213   mycheck(
1214     'www.yahoo.co.jp',
1215     'http://www.yahoo.co.jp' );
1216
1217   mycheck(
1218     '',
1219     'www.yahoo.co.jp' );
1220   mycheck(
1221     '',
1222     '');
1223 end;
1224
1225 function Get2chDate(aDate: TDateTime): string;
1226 var
1227   d1: TDateTime;
1228   d2: TDateTime;
1229 begin
1230   d1 := EncodeDate(1970, 1, 1);
1231   d2 := aDate - EncodeTime(9, 0, 0, 0);
1232   Result := FloatToStr(Trunc((d2 - d1) * 24 * 60 * 60));
1233 end;
1234
1235 function GetDatSince(aDatNo: string): string;
1236 var
1237   s:  string;
1238   v:  double;
1239   ad: TDateTime;
1240   d1: TDateTime;
1241 begin
1242   if  (AnsiPos('_', aDatNo) > 0)  then  begin
1243     s :=  Copy(aDatNo, 1, AnsiPos('_', aDatNo) - 1);  //\82µ\82½\82ç\82Î\91Î\89\9e
1244   end else begin
1245     s :=  aDatNo;
1246   end;
1247   if  (TryStrToFloat(s, v)) then  begin
1248     v   :=  StrToFloat(s);
1249     ad  :=  v / 60 / 60 / 24;
1250     d1  :=  EncodeDate(1970, 1, 1);
1251     ad  :=  (ad + EncodeTime(9,0,0,0))  + d1;
1252     Result  :=  FormatDateTime('yyyy/mm/dd h:m:s', ad);
1253   end else begin
1254     Result  :=  '';
1255   end;
1256 end;
1257
1258 procedure testGet2chDate;
1259   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: TDateTime);
1260   begin
1261     Check(s, Get2chDate(s2));
1262   end;
1263 begin
1264   mycheck(
1265     '986094000',
1266     StrToDateTime('2001/04/01 12:00:00'));
1267
1268   mycheck(
1269     '1078023600',
1270     StrToDateTime('2004/02/29 12:00:00'));
1271 end;
1272
1273 function ChooseString(const Text, Separator: string; Index: integer): string;
1274 var
1275   S : string;
1276   i, p : integer;
1277 begin
1278   S :=  Text;
1279   for i :=  0 to  Index - 1 do  begin
1280     if  (AnsiPos(Separator, S) = 0) then  S :=  ''
1281     else  S :=  Copy(S, AnsiPos(Separator, S) + Length(Separator), Length(S));
1282   end;
1283   p :=  AnsiPos(Separator, S);
1284   if  (p > 0) then  Result  :=  Copy(S, 1, p - 1) else Result :=  S;
1285 end;
1286
1287 procedure testChooseString;
1288   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2, s3{\8aÖ\90\94\82É\93n\82·\93à\97e}: String;
1289                     n: integer);
1290   begin
1291     Check(s, ChooseString(s2, s3, n));
1292   end;
1293 begin
1294   mycheck(
1295     'a',
1296     'a/b/c/', '/', 0);
1297
1298   mycheck(
1299     'b',
1300     'a/b/c/', '/', 1);
1301
1302   mycheck(
1303     'c',
1304     'a/b/c/', '/', 2);
1305
1306   mycheck(
1307     '',
1308     'a/b/c/', '/', 3);
1309
1310   mycheck(
1311     '',
1312     'a/b/c', '/', 3);
1313
1314   mycheck(
1315     'arakabu',
1316     'http://www.2ch.com/arakabu/', '/', 3);
1317
1318   mycheck(
1319     '\82É\82È\82é',
1320     '\82±\82Ì\96Ø\82È\82ñ\82Ì\96Ø\96Ø\82É\82È\82é\96Ø', '\96Ø', 3);
1321
1322   mycheck(
1323     'C++Builder',
1324     'BorlandDelphiBorlandC++BuilderBorlandKylix', 'Borland', 2);
1325
1326   mycheck(
1327     '',
1328     '', '/', 0);
1329 end;
1330
1331 function ExtractQuotedStr(S: string; Quote: char): string;
1332 begin
1333   if  (Length(S) > 1) then  begin
1334     if  (S[1] = Quote) and (Copy(S, Length(S), 1) = Quote)  then  begin
1335       Result  :=  Copy(S, 2, Length(S) - 2);
1336     end else begin
1337       Result  :=  S;
1338     end;
1339   end else begin
1340     Result  :=  S;
1341   end;
1342 end;
1343
1344 procedure testExtractQuotedStr;
1345   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String; s3: char);
1346   begin
1347     Check(s, ExtractQuotedStr(s2, s3));
1348   end;
1349 begin
1350   mycheck('ABC',    '"ABC"',  '"');
1351   mycheck('ABC ',   '"ABC "', '"');
1352   mycheck('ABC',    'ABC',    '"');
1353   mycheck('"ABC"',  '"ABC"',  '''');
1354   mycheck('""',     '""""',   '"');
1355   mycheck('A',      'A',      '"');
1356   mycheck('',       '',       '"');
1357 end;
1358
1359 function ExtractUrlLastPath(Url: string): string;
1360 var
1361   I: Integer;
1362 begin
1363   if  (Length(Url) > 0) then  begin
1364     if  (Url[Length(Url)] <> '/')  then Url :=  ExtractURLPath(Url);
1365     Url :=  Copy(Url,1,Length(Url) - 1);
1366     I := LastDelimiter('/:', Url);
1367     Result := Copy(Url, I + 1, Length(Url) - I);
1368   end else begin
1369     Result  :=  '';
1370   end;
1371 end;
1372
1373 procedure testExtractURLLastPath;
1374   procedure mycheck(s{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1375   begin
1376     Check(s, ExtractURLLastPath(s2));
1377   end;
1378 begin
1379   mycheck('www.2ch.net',  'http://www.2ch.net/');
1380   mycheck('tech',         'http://piza.2ch.net/tech/index2.html');
1381   mycheck('tech',         'http://piza.2ch.net/tech/index2.html#menu');
1382   mycheck('',             'http://www.yahoo.co.jp' );
1383   mycheck('',             'www.yahoo.co.jp' );
1384   mycheck('','');
1385 end;
1386
1387 function IsNumeric(s: string): boolean;
1388 var
1389   e: integer;
1390   v: integer;
1391 begin
1392   Val(s, v, e);
1393   Result := e = 0;
1394 end;
1395
1396 procedure testIsNumeric;
1397   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: boolean; s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1398   begin
1399     Check(r, IsNumeric(s2));
1400   end;
1401 begin
1402   mycheck(True, '12345');
1403   mycheck(True, '-12345');
1404   mycheck(False,'123.45');
1405   mycheck(False,'12345F' );
1406   mycheck(True,  '+50');
1407   mycheck(False,'\82P\82Q\82R\82S\82T');
1408   mycheck(False,'');
1409 end;
1410
1411 function IsFloat(s: string): boolean;
1412 var
1413   v: Extended;
1414 begin
1415   Result := TextToFloat(PChar(s), v, fvExtended);
1416 end;
1417
1418 procedure testIsFloat;
1419   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: boolean; s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1420   begin
1421     Check(r, IsFloat(s2));
1422   end;
1423 begin
1424   mycheck(True, '12345.0');
1425   mycheck(True, '-12345.0');
1426   mycheck(True,'123.45');
1427   mycheck(True, '12345');
1428   mycheck(False,'12345F' );
1429   mycheck(True,  '+50');
1430   mycheck(False,'\82P\82Q\82R\82S\82T');
1431   mycheck(False,'');
1432 end;
1433
1434
1435 function Fmt2chToDateTime(Fmt2ch: String): TDateTime;
1436 var
1437   Year, Month, Day: word;
1438   Hour, Min, Sec, MSec: word;
1439 begin
1440   try
1441     Fmt2ch  :=  Trim(Fmt2ch); //dax
1442     Year    := StrToInt(Copy(Fmt2ch, 1, 4));
1443     Month   := StrToInt(Copy(Fmt2ch, 6, 2));
1444     Day     := StrToInt(Copy(Fmt2ch, 9, 2));
1445
1446     Hour    := StrToInt(Copy(Fmt2ch,16, 2));
1447     Min     := StrToInt(Copy(Fmt2ch,19, 2));
1448     Sec := 0;
1449     MSec:= 0;
1450
1451     Result := EncodeDate(Year, Month, Day)
1452                 + EncodeTime(Hour, Min, Sec, MSec);
1453   except
1454     raise EConvertError.Create('\93ú\95t\95Ï\8a·\82ª\90³\82µ\82\82Ë\82¦\82¼(ß\84Dß)ºÞÙ§');
1455   end;
1456 end;
1457
1458 procedure testFmt2chToDateTime;
1459   procedure mycheck(d{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: TDateTime; s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1460   begin
1461     Check(d, Fmt2chToDateTime(s2));
1462   end;
1463 begin
1464   mycheck(StrToDateTime('2001/02/18 15:23:00'),
1465           '2001/02/18(\93ú) 15:23');
1466
1467   mycheck(StrToDateTime('2001/02/18 15:23:00'),
1468           '2001/02/18(\93ú) 15:23 ID=???');
1469
1470   //\82±\82ê\82Í\83G\83\89\81[\81«
1471   {
1472   mycheck(StrToDateTime('0'),
1473           '\82 \82Ú\81[\82ñ');
1474   }
1475 end;
1476
1477 //S\82Ì\92\86\82ÉSubStr\82ª\82¢\82\82Â\82 \82é\82©\83J\83E\83\93\83g\82·\82é(2\83o\83C\83g\91Î\89\9e)
1478 {\95¶\8e\9a\82ð\8c©\82Â\82¯\82é\82Æ\82»\82Ì\95¶\8e\9a\82ð\8dí\8f\9c\82µ\82Ä\8c\9f\8dõ\82·\82é\82Æ\82¢\82¤\95û\8e®\82È\82Ì\82Å
1479  "\82 \82 \82 \82 \82 \82 "\82Æ\82¢\82¤\95¶\8e\9a\97ñ\82©\82ç"\82 \82 "\82Ì\8cÂ\90\94\82ð\91ª\92è\82·\82é\82Æ3\82ð\95Ô\82·}
1480 function StrCount1(const Substr, S: string): Integer;
1481 var
1482   Str: String;
1483 begin
1484   Result := 0;
1485   if (Substr = '') or (S = '') then exit;
1486
1487   Str := S;
1488   try
1489     while AnsiPos( Substr, Str) <> 0 do
1490     begin
1491       Inc(Result);
1492       delete(Str, AnsiPos( Substr, Str), Length(Substr));
1493     end;
1494   except
1495     Result := -1;
1496   end;
1497 end;
1498
1499 procedure testStrCount1;
1500   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: integer; s2, s3{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1501   begin
1502     Check(r, StrCount1(s3, s2));
1503   end;
1504 begin
1505   mycheck(3, '\82 \82 \82 \82 \82 \82 ', '\82 \82 ');
1506   mycheck(3, 'BorlandDelphiBorlandC++BuilderBorlandKylix', 'Borland');
1507   mycheck(2, 'BorlandDelphiBorlandC++BuilderBorlandKylix', '+');
1508   mycheck(4, 'http://www.2ch.net/hogehoge/test', '/');
1509   mycheck(0, 'http://www.2ch.net/hogehoge/test', '+');
1510   mycheck(0, '+', '+++++');
1511   mycheck(0, '', '+');
1512 end;
1513
1514 //\95¶\8e\9a\97ñ\82Ì\8cã\95û\8c\9f\8dõ
1515 {"\82 \82 \82 \82 \82 "\82©\82ç"\82 \82 "\82ð\8c\9f\8dõ\82·\82é\82Æ\83o\83C\83g\90\94\82Å7\82ð\95Ô\82·}
1516 function BackAnsiPos(const SubStr,S: String): Integer;
1517 var
1518   SearchStr: String;
1519   BackPosIndex: Integer;
1520   MbcsFlag: TMbcsByteType;
1521 begin
1522   Result := 0;
1523   MbcsFlag := mbSingleByte; {\93Á\82É\88Ó\96¡\82Ì\82È\82¢\8f\89\8aú\89»}
1524   if AnsiPos(subStr,S)=0 then exit;
1525
1526   SearchStr := S;
1527   while AnsiPos(subStr,SearchStr)<>0 do
1528   begin
1529     BackPosIndex := AnsiPos(subStr,SearchStr);
1530     MbcsFlag := ByteType(SearchStr, BackPosIndex);
1531     case MbcsFlag of
1532
1533       mbSingleByte:  { \94¼\8ap }
1534         Delete(SearchStr,1,BackPosIndex);
1535
1536       mbLeadByte:    { \91S\8ap\82Ì\82P\83o\83C\83g\96Ú }
1537         Delete(SearchStr,1,BackPosIndex  +1  );
1538
1539       mbTrailByte:   { \91S\8ap\82Ì\82Q\83o\83C\83g\96Ú }
1540         Delete(SearchStr,1,BackPosIndex);
1541     else
1542       raise Exception.Create('\83G\83\89\81[');
1543     end;
1544   end; //while
1545
1546   case MbcsFlag of
1547     mbSingleByte:
1548       Result := length(S)-Length(SearchStr);
1549
1550     mbLeadByte:
1551       Result := length(S)-Length(SearchStr) - 1;
1552
1553     mbTrailByte:
1554       Result := length(S)-Length(SearchStr);
1555   else
1556     raise Exception.Create('\83G\83\89\81[');
1557   end;
1558 end;
1559
1560 procedure testBackAnsiPos;
1561   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: integer; s2, s3{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1562   begin
1563     Check(r, BackAnsiPos(s3, s2));
1564   end;
1565 begin
1566   mycheck(9, '\82 \82 \82 \82 \82 \82 ', '\82 \82 ');
1567   mycheck(31,'BorlandDelphiBorlandC++BuilderBorlandKylix', 'Borland');
1568   mycheck(28,'http://www.2ch.net/hogehoge/test', '/');
1569   mycheck(0, 'http://www.2ch.net/hogehoge/test', '+');
1570   mycheck(0, '+', '+++++');
1571   mycheck(0, '', '+');
1572 end;
1573
1574 //URL\82ðDOS\83p\83X\82É\95Ï\8dX
1575 function  UrlToDosPath(const Url: string): string;
1576 const
1577   PATH_TERMINATE = '\';
1578 var
1579   S : string;
1580   n, m : integer;
1581 begin
1582   if  (AnsiPos('http://', Url) = 1) then  begin
1583     s :=  Copy(Url, 8, Length(Url));
1584   end else begin
1585     s :=  Url;
1586   end;
1587   n :=  AnsiPos(':', s);
1588   if  (n > 0) then  begin
1589     m :=  AnsiPos('/', s);
1590     s :=  'http://' +
1591           Copy(s, 1, n - 1) +
1592           Copy(s, m, Length(Url));
1593   end;
1594
1595   S :=  AnsiLowerCase(
1596           MonaUtils.ExcludeTrailingSlash(
1597             MonaUtils.ExtractUrlPath(S)));
1598   if  (S = '')  then  begin
1599     Result  :=  Url;
1600     Exit;
1601   end;
1602   if  (Copy(S,1,7) = 'http://') then  begin
1603     S :=  Copy(S,8,Length(S) - 7);
1604   end;
1605
1606   S :=  StringReplace(S, '/', PATH_TERMINATE, [rfReplaceAll]);
1607
1608   if  (Copy(S,Length(S) - 3, 4) = PATH_TERMINATE + 'dat') then  begin
1609     S :=  Copy(S,1,Length(S) - 4);
1610   end;
1611   Result  :=    S + PATH_TERMINATE + MonaUtils.ExtractUrlName(Url);
1612 end;
1613
1614 procedure testUrlToDosPath;
1615   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1616   begin
1617     Check(r, UrlToDosPath(s1));
1618   end;
1619 begin
1620   mycheck('www.2ch.net\',               'http://www.2ch.net/');
1621   mycheck('www.2ch.net\test\read.cgi',  'http://www.2ch.net/test/read.cgi');
1622   mycheck('www.2ch.net\test\',          'www.2ch.net/test/');
1623   mycheck('www.2ch.net\test',           'www.2ch.net/test');
1624   mycheck('ABCDEFG',                    'ABCDEFG');
1625   mycheck('\abcdefg\',                  '/abcdefg/');
1626   mycheck('www.2ch.net\abc\def',        'http://www.2ch.net/abc\def');
1627 end;
1628
1629 //?param=value\82Ì param\82ð\8ew\92è\82·\82é\82Æ value\82ð\95Ô\82·
1630 function ChooseValue(const Url, Key: string): string;
1631 var
1632   List  : TStringList;
1633   S : PChar;
1634 begin
1635   GetMem(S, Length(Url) + 1);
1636   StrCopy(S, PChar(Url));
1637   List  :=  TStringList.Create;
1638   {$IFDEF VER120}
1639     ExtractHttpFields(['?','&'], [], S, List);
1640   {$ELSE}
1641     ExtractHttpFields(['?','&'], [], S, List, False);
1642   {$ENDIF}
1643   Result  :=  List.Values[Key];
1644   List.Free;
1645   FreeMem(S);
1646 end;
1647
1648 procedure testChooseValue;
1649   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1650   begin
1651     Check(r, ChooseValue(s1, s2));
1652   end;
1653 begin
1654   mycheck('tech',
1655           'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1656           'bbs');
1657   mycheck('12345678',
1658           'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1659           'key');
1660   mycheck('10',
1661           'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1662           'st');
1663   mycheck('',
1664           'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1665           'to');
1666   mycheck('',
1667           'http://www.2ch.net/test/read.cgi',
1668           'bbs');
1669   mycheck('10',
1670           'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10&st=20',
1671           'st');
1672 end;
1673
1674 //URL\82Ì\83}\81[\83W
1675 function MargeUrl(const BaseUrl, NewUrl: string): string;
1676 var
1677   s,r,b : string;
1678   l : TStringList;
1679   i, count : integer;
1680 begin
1681   if  (NewUrl = '') then  begin
1682     Result  :=  BaseUrl;
1683     Exit;
1684   end else
1685   if  (NewUrl[1]  = '/')  then  begin
1686     Result  :=  'http://' + ExtractHostName(BaseUrl) + NewUrl;
1687     Exit;
1688   end;
1689   count :=  0;
1690   s :=  NewUrl;
1691   while true  do  begin
1692     if  (Copy(s,1,3) = '../')  then  begin
1693       s :=  Copy(s, 4, Length(s) - 3);
1694       inc(count);
1695     end else
1696     if  (Copy(s,1,2) = './')  then  begin
1697       s :=  Copy(s, 3, Length(s) - 2);
1698     end else begin
1699       Break;
1700     end;
1701   end;
1702   r := '';
1703   b := ExtractUrlPath(BaseUrl);
1704   b := Copy(b,7,Length(b));
1705   l :=  TStringList.Create;
1706   ExtractHTTPFields(['/'],[],PChar(b), l);
1707   for i :=  0 to  l.Count - count - 1 do  begin
1708     r :=  r + '/'+ l[i];
1709   end;
1710   Result  :=  'http:/' + r + '/' + s;
1711 end;
1712
1713 procedure testMargeUrl;
1714   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1, s2{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1715   begin
1716     Check(r, MargeUrl(s1, s2));
1717   end;
1718 begin
1719   mycheck('http://www.2ch.net/dat',
1720           'http://www.2ch.net/test/',
1721           '../dat');
1722   mycheck('http://www.2ch.net/dat',
1723           'http://www.2ch.net/test/data',
1724           '../dat');
1725   mycheck('http://www.2ch.net/test/dat',
1726           'http://www.2ch.net/test/data',
1727           './dat');
1728   mycheck('http://www.2ch.net/test/dat/',
1729           'http://www.2ch.net/test/data',
1730           './dat/');
1731   mycheck('http://www.2ch.net/',
1732           'http://www.2ch.net/test/',
1733           '../');
1734   mycheck('http://www.2ch.net/',
1735           'http://www.2ch.net/test/',
1736           '/');
1737   mycheck('http://www.2ch.net/test/a/',
1738           'http://www.2ch.net/test/',
1739           'a/');
1740 end;
1741
1742 //A HREF\83^\83O\82Ì\92\86\82©\82çURL\82ð\92\8a\8fo\82·\82é
1743 function ExtractHrefUrl(const s: string): string;
1744 var
1745   r : string;
1746   n : integer;
1747 begin
1748   n :=  AnsiPos('href', AnsiLowerCase(s));
1749   r :=  Copy(s, n, Length(s));
1750   n :=  AnsiPos('>', r);
1751   if  (n > 0) then  r :=  Copy(r, 1, n - 1);
1752   n :=  AnsiPos(' ', r);
1753   if  (n > 0) then  r :=  Copy(r, 1, n - 1);
1754   n :=  AnsiPos('=', r);
1755   r :=  Copy(r, n + 1, Length(r));
1756   n :=  AnsiPos('"', r);
1757   if  (n > 0) then  r :=  Copy(r, 2, Length(r)  - 2);
1758   Result  :=  r;
1759 end;
1760
1761 procedure testExtractHrefUrl;
1762   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1763   begin
1764     Check(r, ExtractHrefUrl(s1));
1765   end;
1766 begin
1767   mycheck('http://www.2ch.net/dat/',
1768           '<A HREF="http://www.2ch.net/dat/">');
1769   mycheck('http://www.2ch.net/dat/',
1770           '<a href=http://www.2ch.net/dat/>');
1771   mycheck('http://www.2ch.net/dat/',
1772           '<a target=_blank href=http://www.2ch.net/dat/>');
1773   mycheck('http://www.2ch.net/dat/',
1774           '<a target=_blank href=http://www.2ch.net/dat/><a href=http://www.2ch.net/test/>');
1775 end;
1776
1777 function ZenToHan(const s: string): string;
1778 var
1779   Chr : array [0..255]  of  char;
1780 begin
1781   {$IFDEF LINUX}
1782   //**LINUX**
1783   {$ENDIF}
1784   {$IFDEF MSWINDOWS}
1785   Windows.LCMapString(
1786      GetUserDefaultLCID(),
1787      LCMAP_HALFWIDTH,
1788      PChar(s),
1789      Length(s) + 1,
1790      chr,
1791      Sizeof(chr)
1792      );
1793   Result :=  Chr;
1794   {$ENDIF}
1795 end;
1796
1797 procedure testZenToHan;
1798   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1799   begin
1800     Check(r, ZenToHan(s1));
1801   end;
1802 begin
1803   mycheck('±²³´µ',      '\83A\83C\83E\83G\83I');
1804   mycheck('±²³´µ±²³´µ', '\83A\83C\83E\83G\83I±²³´µ');
1805   mycheck('ABC',        '\82`\82a\82b');
1806   mycheck('\8a¿\8e\9a',       '\8a¿\8e\9a');
1807   mycheck('\8a¿\8e\9aABC',    '\8a¿\8e\9a\82`\82a\82b');
1808 end;
1809
1810 function GetContentLength(S : string): integer;
1811 var
1812   p : PChar;
1813   p_end : PChar;
1814   n : integer;
1815 begin
1816   p :=  PChar(s);
1817   p_end :=  PChar(s) + Length(s);
1818   n :=  0;
1819   while p < p_end do begin
1820     if p^ = #13 then begin
1821       //
1822     end else begin
1823       inc(n);
1824     end;
1825     Inc(p);
1826   end;
1827   Result  :=  n;
1828 end;
1829
1830 procedure testGetContentLength;
1831   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: integer; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1832   begin
1833     Check(r, GetContentLength(s1));
1834   end;
1835 begin
1836   mycheck(1,      'A');
1837   mycheck(0,      '');
1838   mycheck(14,     '<HTML>' + #13#10 + '</HTML>');
1839   mycheck(14,     '<HTML>' + #10 + '</HTML>');
1840   mycheck(15,     '<HTML>' + #13#10 + #9 + '</HTML>');
1841   mycheck(20,     '<HTML>' + #13#10 + 'Hello' + #0 + '</HTML>');  //#0\82à\83J\83E\83\93\83g
1842 end;
1843
1844 function TrimTag(const s: string): string;
1845 var
1846   r : string;
1847   b : boolean;
1848   i : integer;
1849 begin
1850   r :=  '';
1851   b :=  False;
1852   for i :=  1 to  Length(s) do  begin
1853     if  (ByteType(s, i) = mbSingleByte) then  begin
1854       if  (s[i] = '<') then  begin
1855         b :=  True;
1856       end else
1857       if  (s[i] = '>') and (b) then  begin
1858         b :=  False;
1859       end else
1860       if  (not b) then  begin
1861         r :=  r + s[i];
1862       end;
1863     end else begin
1864       if  (not b) then  begin
1865         r :=  r + s[i];
1866       end;
1867     end;
1868   end;
1869   Result  :=  Trim(r);
1870 end;
1871
1872 procedure testTrimTag;
1873   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
1874   begin
1875     Check(r, TrimTag(s1));
1876   end;
1877 begin
1878   mycheck('\83A\83C\83E\83G\83I',   '<ABC>\83A\83C\83E\83G\83I</ABC>');
1879   mycheck('\83A\83C\83E\83G\83I',   '<\90À\82Á\82Ä\82æ\82µ>\83A\83C\83E\83G\83I</\83I\83}\83G\83\82\83i\81[>');
1880   mycheck('\82 \82 ',         '<<<a>>>\82 \82 <<</a>>>');
1881   mycheck('\83A\83C\83E\83G\83I',   '\83A\83C\83E\83G\83I');
1882   mycheck('',             '<A HREF="\83A\83C\83E\83G\83I">');
1883   mycheck('ABC',          '<A HREF="\83A\83C\83E\83G\83I">ABC</A>');
1884 end;
1885
1886 function AddTargetBlank(const Value: string): string;
1887 var
1888   Org, s, r : string;
1889   x, y, z, t : string;
1890   p, i : integer;
1891 begin
1892   r   :=  '';
1893   Org :=  Value;
1894   while true  do  begin
1895     p :=  AnsiPos('<a', AnsiLowerCase(Org));
1896     if  (p > 0) then  begin
1897       //\90æ\93ª\82©\82ç<A \82Ü\82Å\82ð --> r
1898       s :=  Copy(Org, 1, p - 1);
1899       r :=  r + s;
1900       //<A \82©\82ç > \82Ü\82Å\82ð --> s
1901
1902       // s = "<A xxxx xxxxxx>"
1903       //t :=  Copy(Org, p, Length(org));
1904       s :=  Copy(Org, p, Length(org));
1905       i :=  AnsiPos('>', s);
1906       t :=  Copy(s, i + 1, Length(s));
1907       s :=  Copy(S, 1, i);
1908
1909       if  (AnsiPos('href', AnsiLowerCase(s)) > 0) then  begin
1910         //TARGET=
1911         p :=  AnsiPos('TARGET=', AnsiUpperCase(s));
1912         if  (p > 0) then  begin
1913           x :=  Copy(s, 1, p - 1);  //TARGET\82Ü\82Å
1914           y :=  Copy(s, p, Length(s));  //TARGET\88È\8d~
1915           i :=  AnsiPos(' ', y);
1916           if  (i > 0) then  begin
1917             y :=  Copy(y, 1, i - 1);
1918           end;
1919           i :=  AnsiPos('>', y);
1920           if  (i > 0) then  begin
1921             y :=  Copy(y, 1, i - 1);
1922           end;
1923           //TARGET \82Ì\82Ý --> y
1924           z :=  Copy(s, Length(x) + Length(y) + 1, Length(s)); //TARGET\82æ\82è\8cã\82ë
1925           //
1926           s :=  x + 'TARGET="_blank"' + z;
1927           r :=  r + s;
1928           //org :=  Copy(org, AnsiPos('>', Org) + 1, Length(org));
1929           Org := t;
1930         end else begin
1931           //<A xxxxxxx>
1932           s :=  Copy(s, 1, Length(S) - 1) + ' TARGET="_blank">';
1933           r :=  r + s;
1934           //org :=  Copy(org, AnsiPos('>', Org) + 1, Length(org));
1935           Org := t;
1936         end;
1937
1938
1939       end else begin
1940         r :=  r + s;
1941         org :=  t; //Copy(org, Length(t) + 1, Length(org));
1942       end;
1943
1944     end else begin;
1945       r :=  r + Org;
1946       Break;
1947     end;
1948   end;
1949   Result  :=  r;
1950 end;
1951
1952 {
1953 function AddTargetBlank(const Value: string): string;
1954 var
1955   org , s, r, w, x, y, z : string;
1956   frx, tox, i : integer;
1957   b : boolean;
1958 begin
1959   org :=  Value;
1960   r   :=  '';
1961   while true  do  begin
1962     //frx :=  AnsiPos('<A HREF=', AnsiUpperCase(org));
1963     frx :=  AnsiPos('<A ', AnsiUpperCase(org));
1964     if  (frx > 0) then  begin
1965       r :=  r + Copy(org, 1, frx);
1966       org :=  Copy(org, frx + 1, Length(org));
1967       tox :=  AnsiPos('>', AnsiUpperCase(org));
1968       if  (tox > 0) then  begin
1969         s   :=  Copy(org, 1, tox - 1);
1970         if  (AnsiPos('TARGET=', AnsiUpperCase(org)) = 0)  then  begin
1971           s :=  s + ' TARGET="_blank"';
1972           r :=  r + s;
1973           org :=  Copy(org, tox, Length(org));
1974         end else begin
1975           //
1976           //  x = '<A HREF=xxxxxxxx |TARGET
1977           //x :=  Copy(S, 1, AnsiPos('TARGET=', S) - 1);
1978           //y :=  Copy(S, AnsiPos('TARGET=', S), Length(S));
1979           //z :=  Copy(y, AnsiPos(' ', y) + 1, Length(y));
1980           b := False;
1981           x :=  Copy(org, 1, AnsiPos('TARGET=', org) - 1);
1982           w :=  Trim(Copy(org, Length(x) + 1, Length(org)));
1983           i :=  AnsiPos(' ', w);
1984           if  (i > 0) then  begin
1985             y :=  Copy(w, 1, i - 1);
1986           end else begin
1987             y :=  w;
1988             b :=  True;
1989           end;
1990           i :=  AnsiPos('>', y);
1991           if  (i > 0) then  begin
1992             y :=  Copy(y, 1, i - 1);
1993           end;
1994           z :=  Copy(org, Length(x) + Length(y) + 1, Length(org));
1995
1996           if  (Length(x) > 0) then  begin
1997             if  (Copy(x, Length(x), 1) <> ' ')  then  begin
1998               x :=  x + ' ';
1999             end;
2000           end;
2001           if  (b) then begin
2002             s :=  x + 'TARGET="_blank"' + z;
2003           end else begin
2004             s :=  x + 'TARGET="_blank"';// + z;
2005           end;
2006
2007           //x :=  x + ' TARGET="_blank"';
2008           //s :=  s + ' TARGET="_blank"';
2009           r :=  r + s;
2010           org :=  Copy(org, Length(s), Length(org));
2011           if  (Length(org) > 0) then  begin
2012             if  (org[1] = '"')  then  begin
2013               org :=  Copy(org, 2, Length(org));
2014             end;
2015           end;
2016         end;
2017       end else begin
2018         r :=  r + org;
2019         Break;
2020       end;
2021     end else begin
2022       r :=  r + org;
2023       Break;
2024     end;
2025   end;
2026   Result  :=  r;
2027 end;
2028 }
2029 procedure testAddTargetBlank;
2030   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
2031   begin
2032     Check(r, AddTargetBlank(s1));
2033   end;
2034 begin
2035   mycheck('\82»\82Ì\82P\82ª\82P\82O\82O\82O\82ð\92´\82¦\82½\82Ì\82Å\82Q\82É\88Ú\8ds\82·\82é\82Æ\82¢\82¤\82±\82Æ\82Å\81B<BR><BR><BR>\82P\82Í\82±\82Á\82¿\82Å\82·\81B<BR><BR><a href=http://www.megabbs.com/cgi-bin/readres.cgi TARGET="_blank">\82±\82±</a><BR>',
2036           '\82»\82Ì\82P\82ª\82P\82O\82O\82O\82ð\92´\82¦\82½\82Ì\82Å\82Q\82É\88Ú\8ds\82·\82é\82Æ\82¢\82¤\82±\82Æ\82Å\81B<BR><BR><BR>\82P\82Í\82±\82Á\82¿\82Å\82·\81B<BR><BR><a href=http://www.megabbs.com/cgi-bin/readres.cgi>\82±\82±</a><BR>');
2037   mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2038           '<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>');
2039   mycheck('AAA<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2040           'AAA<A HREF="http://www.2ch.net">2ch</A>');
2041   mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2042           '<A HREF="http://www.2ch.net">2ch</A>');
2043   mycheck('<a href="http://www.2ch.net" TARGET="_blank">2ch</A>',
2044           '<a href="http://www.2ch.net">2ch</A>');
2045   mycheck('<a href=http://www.2ch.net TARGET="_blank">2ch</A>',
2046           '<a href=http://www.2ch.net>2ch</A>');
2047   mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2048           '<A HREF="http://www.2ch.net" TARGET="parent">2ch</A>');
2049   mycheck('<A TARGET="_blank" HREF="http://www.2ch.net">2ch</A>',
2050           '<A TARGET="_blank" HREF="http://www.2ch.net">2ch</A>');
2051   mycheck('<A TARGET="_blank" HREF=http://www.2ch.net>2ch</A>',
2052           '<A TARGET=_top HREF=http://www.2ch.net>2ch</A>');
2053   mycheck('<A NAME="AA">2ch</A>',
2054           '<A NAME="AA">2ch</A>');
2055   mycheck('<A>2ch</A>',
2056           '<A>2ch</A>');
2057   mycheck('2ch',
2058           '2ch');
2059 end;
2060
2061 function  ExtractDatNo(const DatFileName: string): string;
2062 var
2063   s, ext : string;
2064 begin
2065   if  (AnsiPos('http:', DatFileName) = 1) then  begin
2066     s   :=  ExtractUrlName(DatFileName);
2067   end else begin
2068     s   :=  ExtractFileName(DatFileName);
2069   end;
2070   ext :=  ExtractFileExt(s);
2071   if  (ext <> '') then  begin
2072     s :=  Copy(s, 1, Length(s) - Length(ext));
2073   end;
2074   Result  :=  s;
2075 end;
2076
2077 procedure testExtractDatNo;
2078   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: string; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
2079   begin
2080     Check(r, ExtractDatNo(s1));
2081   end;
2082 begin
2083   mycheck('123456789',
2084           '123456789.dat');
2085   mycheck('123456789',
2086           '123456789');
2087   mycheck('123456789',
2088           'http://www.2ch.net/tech/dat/123456789.dat');
2089   mycheck('123456789',
2090           'C:\monazilla\monaplorer\dat\123456789.dat');
2091   mycheck('123456789_1',
2092           '123456789_1.dat');
2093   mycheck('123456789_1',
2094           '123456789_1');
2095   mycheck('123456789_1',
2096           'http://www.2ch.net/tech/dat/123456789_1.dat');
2097   mycheck('123456789_1',
2098           'C:\monazilla\monaplorer\dat\123456789_1.dat');
2099 end;
2100
2101 //Tue, 17 Dec 2002 12:18:07 GMT \81¨ TDateTime\82Ö
2102 function  DateStrToDateTime(const DateStr: string): TDateTime;
2103   function  StrMonthToMonth(const s: string): integer;
2104   const
2105     m: array[1..12] of string = ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec');
2106   var
2107     i: integer;
2108   begin
2109     Result  :=  -1;
2110     for i :=  Low(m)  to  High(m) do  begin
2111       if  (SameText(s, m[i]))  then  begin
2112         Result  :=  i;
2113         Break;
2114       end;
2115     end;
2116   end;
2117 var
2118   wDay, wMonth, wYear: word;
2119   wHour, wMinute, wSecond: word;
2120   sTime: string;
2121   d: TDateTime;
2122 begin
2123   wDay    :=  StrToIntDef(ChooseString(DateStr, ' ', 1), 0);
2124   wMonth  :=  StrMonthToMonth(ChooseString(DateStr, ' ', 2));
2125   wYear   :=  StrToIntDef(ChooseString(DateStr, ' ', 3), 0);
2126   sTime   :=  ChooseString(DateStr, ' ', 4);
2127   wHour   :=  StrToIntDef(ChooseString(sTime, ':', 0), 0);
2128   wMinute :=  StrToIntDef(ChooseString(sTime, ':', 1), 0);
2129   wSecond :=  StrToIntDef(ChooseString(sTime, ':', 2), 0);
2130   d :=  EncodeDateTime(wYear, wMonth, wDay, wHour, wMinute, wSecond, 0);
2131   Result  :=  d;
2132 end;
2133
2134 procedure testDateStrToDateTime;
2135   procedure mycheck(r{\8aú\91Ò\82³\82ê\82é\8c\8b\89Ê}: TDateTime; s1{\8aÖ\90\94\82É\93n\82·\93à\97e}: String);
2136   begin
2137     Check(r, DateStrToDateTime(s1));
2138   end;
2139 begin
2140   mycheck(StrToDateTime('2002/12/17 12:18:07'),
2141                         'Tue, 17 Dec 2002 12:18:07 GMT');
2142   mycheck(StrToDateTime('2003/1/10 23:15:10'),
2143                         'Fri, 10 Jan 2003 23:15:10 GMT');
2144   mycheck(StrToDateTime('2004/2/29 00:00:00'),
2145                         'Fri, 29 Feb 2004 00:00:00 GMT');
2146   mycheck(StrToDateTime('2001/11/11 11:22:33'),
2147                         'Fri, 11 Nov 2001 11:22:33 JST');
2148 end;
2149
2150
2151 procedure testMonaUtils;
2152 begin
2153   ClearTestResult;
2154   try
2155     //testMonaHtmlParser;
2156     //testMonaProfiler;
2157     //testExtractUrlPath;
2158     //testExtractUrlName;
2159     //testMaxMin;
2160     //testIncludeTrailingSlash;
2161     //testExcludeTrailingSlash;
2162     //testIsUrlDelimiter;
2163     //testLoadSaveString;
2164     //testFindFile;
2165     //testAddHRefTag;
2166     //testTrimHRefTag;
2167     //testDecodeHtmlEsc;
2168     //testEncodeHtmlEsc;
2169     //testExtractHostName;
2170     //testGet2chDate;
2171     //testChooseString;
2172     //testExtractQuotedStr;
2173     //testExtractUrlLastPath;
2174     //testIsNumeric;
2175     //testFmt2chToDateTime;
2176     //testStrCount1;
2177     //testBackAnsiPos;
2178     //testIsFloat;
2179     //testUrlToDosPath;
2180     //testChooseValue;
2181     //testMargeUrl;
2182     //testExtractHrefUrl;
2183     //testZenToHan;
2184     //testGetContentLength;
2185     //testTrimTag;
2186     //testAddTargetBlank;
2187     //testExtractDatNo;
2188     //testAddTargetBlank;
2189     testDateStrToDateTime;
2190   except
2191     on E:ETestFailure do
2192       ;
2193     on E:Exception do
2194       Inc(TestResult.Error);
2195   end;
2196 end;
2197
2198 initialization
2199         if not QueryPerformanceFrequency(TMonaProfiler_FFrequency) then
2200                 RaiseLastWin32Error;
2201
2202 end.