Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/MonaUtils.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.4 - (show annotations) (download) (as text)
Sun Jun 25 15:05:21 2006 UTC (17 years, 9 months ago) by h677
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +0 -0 lines
File MIME type: text/x-pascal
FILE REMOVED
MonaUtilsの使用している関数は、GikoSystemへ
SaveFileは利用されていないので、削除

1 unit MonaUtils;
2
3 {$IOCHECKS ON}
4
5 {----------------------------------------------------------
6 MonaUtils
7
8 --History--
9 2002.12.10 GetDatSince???店
10 2001.03.07 ExtractUrlPath???店
11 2001.03.07 ExtractUrlName???店
12 2001.03.08 Max???店
13 2001.03.08 Min???店
14 2001.03 10 EMonaError, MonaError???店
15 2001.03.10 IncludeTrailingSlash???店
16 2001.03.10 ExcludeTrailingSlash???店
17 2001.03 10 IsUrlDelimiter???店
18 2001.03 10 FindFile???店
19 2001.03.10 LoadStringFromFile???店
20 2001.03.10 SaveStringToFile???店
21 2001.03.11 TMonaHtmlParser???店
22 2001.03.11 TMonaProfiler???店
23 2001.03.11 ShellOpen???店
24 2001.04.06 AddHRefTag???店 < GikoNavi????
25 2001.04.27 TrimHRefTag???店
26 2001.04.27 DecodeHtmlEsc???店
27 2001.04.27 EncodeHtmlEsc???店
28 2001.04.27 ExtractHostName???店
29 2001.04.27 Get2chDate???店 < GikoNavi????
30 2001.04.27 ChooseString???店
31 2001.04.27 ExtractQuotedStr???店
32 2001.04.27 ExtractUrlLastPath???店
33 2001.04.27 IsNumeric???店 < GikoNavi????
34 2001.04.27 IsFloat???店 < GikoNavi????
35 2001.04.27 Fmt2chToDateTime???店 < Monaplorer????
36 2001.04.27 AddHRefTag???A?b?v?f?[?g < GikoNavi a013????
37 2001.04.27 StrCount1???店 < Monaplorer????
38 2001.04.27 BackAnsiPos???店 < Monaplorer????
39 2001.10.30 TMonaProfiler?????U?O??
40 2001.10.30 TMonaHtmlParser?? Attributes?v???p?e?B?????? < Hotzonu????
41 2001.10.30 UrlToDosPath???店 < Hotzonu????
42 2001.10.30 ChooseValue???店 < Hotzonu????
43 2001.10.30 MargeUrl???店 < Hotzonu????
44 2001.10.30 ExtractHrefUrl???店 < Hotzonu????
45 2001.10.30 ZenToHan???店 < Hotzonu????
46 2001.10.30 GetContentLength???店 < Hotzonu????
47 2001.10.30 TrimTag???店 < Hotzonu????
48 2001.10.30 AddTargetBlank???店 < Hotzonu????
49 2001.11.09 ExtractDatNo???店
50
51 --Procedures--
52 ExtractUrlPath .......... URL???巽?p?X?転?纏?????o
53 ExtractUrlName .......... URL???巽?t?@?C???添?転?纏?????o
54 IncludeTrailingSlash .... ?t?@?C???添?????旦??'/'?????????辿
55 ExcludeTrailingSlash .... ?t?@?C???添?????旦???巽'/'?????????足
56 IsUrlDelimiter .......... ???????????w?????u?? / ?????造??
57 Max ..................... ???????????????造?甜?頂?鼎???撤??????
58 Min ..................... ???????????????造?甜?店?????撤??????
59 FindFile ................ ?w???p?X???t?@?C???? TSearchRec??????
60 LoadStringFromFile ...... ?t?@?C?????巽???????????????鄭
61 SaveStringToFile ........ ?????????t?@?C???????鼎?o??
62 ShellOpen ............... ?w???t?@?C??????ShellExecute
63 AddHRefTag .............. http://???巽?n???辿???????? A?^?O?????纏?辿
64 TrimHRefTag ............. ?????????巽<A HREF?`> </A>?^?O?????????辿
65 DecodeHtmlEsc ........... ???????????????^?O(&lt;????)?????????辿
66 EncodeHtmlEsc ........... ??????????"<"???????????^?O?????????辿
67 ExtractHostName ......... URL???巽?z?X?g?添?転?纏?????o
68 Get2chDate .............. ?炭?t???Q?甜?叩?????辿POST?p?炭?t?????????辿
69 ChooseString ............ ???辿?Z?p???[?^?長?????巽?????????????巽
70 ?????????????????????o??
71 ExtractQuotedStr ........ ?????????O???????p?????O??
72 ExtractUrlLastPath ...... URL???長?????p?X?????o
73 IsNumeric ............... ?w???????????貼???????造?????泥?f???辿
74 IsFloat ................. ?w???????????????????造?????泥?f???辿
75 Fmt2chToDateTime ........ DAT?t?@?C???長???炭?t?????????炭?t?^?????????辿
76 StrCount1 ............... S??????SubStr?????足?????辿???J?E???g???辿(2?o?C?g????)
77 UrlToDosPath ............ URL??DOS?`?貼???p?X?????????辿
78 ChooseValue ............. URL?? ?param=value ??Param???w?????辿??Value?????転???辿
79 MargeUrl ................ ?但??URL??????URL???}?[?W???辿
80 ExtractHrefUrl .......... A HREF?^?O???????巽URL?????o???辿
81 ZenToHan ................ ?S?p?????????添?p????????????(Windows????)
82 GetContentLength ........ ?w???????????????????? (#13??????????)
83 TrimTag ................. ?w?????????????????巽?^?O?????????辿
84 AddTargetBlank .......... A HREF?^?O?? TARGET="_blank"???}?端???辿
85 ExtractDatNo ............ DAT?t?@?C???添???巽 DAT???????転?纏???転???辿
86
87 --Classes--
88 TMonaHtmlParser ......... HTML?p?[?T?[?N???X
89 TMonaProfiler ........... ?v???t?@?C??
90
91 --Report--
92 SaveStringToFile ??Linux?v???b?g?t?H?[???長?????[?????????????T?|?[?g?直???邸???B
93 ShellOpen, MonaProfiler??Linux?v???b?g?t?H?[?????T?|?[?g?直???邸???B
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,} YofUtils, DateUtils;
106
107 //
108 // ?叩?O
109 //
110 type
111 EMonaError = class(Exception);
112
113 // EMonaError??raise
114 procedure MonaError(msg: String); overload;
115 procedure MonaError(format: String; args: array of const); overload;
116
117 //
118 // ?????鼎?E????
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); // ???????足?J?足
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 // ?N???X?E???R?[?h
169 //
170 type
171 TMonaHtmlTokenType = (
172 htNone,
173 htTag, // ?^?O????
174 htText // ?^?O???O
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; // ?????G???[?叩?O???足?????邸?辿
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 //?t?@?C???添?????旦??'\'?????????辿????
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 //?t?@?C???添?????旦???巽'\'?????????足????
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 //?t?@?C?????巽???????????????鄭
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('?f?B???N?g??%s?????????邸???B', [path]);
494 {?E?G(?L?D?M) ?t?H???_???????直???????????店???辿}
495 {$ELSE}
496 try
497 ForceDirectories(path);
498 except
499 MonaError('?f?B???N?g??%s?????????邸???B', [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 ?長???G???[
529 //?v???W?F?N?g Project1 ?? EInOutError ?N???X???叩?O?????店?直???直???B
530 //'?端???l?????l?長?????????邸??'
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???樽???????転???存?s?直???直???B', [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?????????存?s?直???直??:%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???????n??
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 '?y<B>?辿??????</B>?z' +
711 '<A href="http://piza.2ch.net/intro/index2.html">???????樽</A>' +
712 '</Body>' +#10+#13+
713 '</html>' +#10
714 );
715 with parser do
716 try
717 // ?端?s?????????????????A?頂?????店???????????A
718 // ?e?L?X?g?E?^?O?????g???????邸?存???泥???????????B
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, '?y');
734 GetToken(htTag, 'B');
735 GetToken(htText, '?辿??????');
736 GetToken(htTag, '/B');
737 GetToken(htText, '?z');
738 GetToken(htTag, 'A href="http://piza.2ch.net/intro/index2.html"');
739 GetToken(htText, '???????樽');
740 GetToken(htTag, '/A');
741 GetToken(htTag, '/Body');
742 GetToken(htTag, '/html');
743 Check(GetToken = htNone); // ?即?直????
744 finally
745 Free;
746 end;
747 end;
748
749 { TMonaProfiler }
750
751 // PerformanceCounter?p
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; // ?J?n
850 Sleep(500);
851 profiler.Stop;
852 Check(500, (profiler.MilliSec + 50) div 100 * 100);
853
854 Sleep(500);
855
856 profiler.Start; // ???J
857 Sleep(1000);
858 Check(1500, (profiler.MilliSec + 50) div 100 * 100); // ???貼???長??OK
859 profiler.Stop;
860
861 profiler.Clear;
862 Check(0, profiler.MicroSec);
863 profiler.Start; // ?J?n
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); // ???????足?J?足
872 begin
873 {$IFDEF WINDOWS}
874 if 32 >= ShellExecute(Application.Handle, 'open', PChar(FileName), nil, nil, sw_show) then
875 RaiseLastWin32Error;
876 {$ELSE}
877 // ???????転?谷????
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 //?????N???????[???B
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???叩?????????足???I?????A?????????足???????B
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 //?????N???????[???B
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???叩?????????足???I?????A?????????足???????B
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 '???????R?R<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>',
1013 '???????R?Rhttp://piza.2ch.net/tech/');
1014 mycheck(
1015 '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>?転??',
1016 'http://piza.2ch.net/tech/?転??');
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>?転??????<a href="http://www.goo.ne.jp" target="_blank">http://www.goo.ne.jp</a>?転??????',
1022 'http://www.yahoo.com?転??????http://www.goo.ne.jp?転??????');
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?長?n???辿',
1031 'http?長?n???辿');
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????',
1040 'www????');
1041 mycheck(
1042 'www ',
1043 'www ');
1044 end;
1045
1046 //
1047 // ???????????巽 <A HREF="xxx"> </A>?^?O?????????鼎????
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{?炭???????辿????}, s2{???????n?????e}: 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 '???????R?Rhttp://piza.2ch.net/tech/',
1091 '???????R?R<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>');
1092 mycheck(
1093 'http://piza.2ch.net/tech/?転??',
1094 '<a href="http://piza.2ch.net/tech/" target="_blank">http://piza.2ch.net/tech/</a>?転??');
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?転??????http://www.goo.ne.jp?転??????',
1100 '<a href="http://www.yahoo.com" target="_blank">http://www.yahoo.com</a>?転??????<a href="http://www.goo.ne.jp" target="_blank">http://www.goo.ne.jp</a>?転??????');
1101 mycheck(
1102 'https://piza.2ch.net/tech/index2.html#menu',
1103 'https://piza.2ch.net/tech/index2.html#menu');
1104 mycheck(
1105 'http?長?n???辿',
1106 'http?長?n???辿');
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{?炭???????辿????}, s2{???????n?????e}: 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{?炭???????辿????}, s2{???????n?????e}: 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{?炭???????辿????}, s2{???????n?????e}: 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); //?直???巽??????
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{?炭???????辿????}: string; s2{???????n?????e}: 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{?炭???????辿????}, s2, s3{???????n?????e}: 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 '?????辿',
1320 '?????????????????????辿??', '??', 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{?炭???????辿????}, s2{???????n?????e}: 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{?炭???????辿????}, s2{???????n?????e}: 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 begin
1389 try
1390 StrToInt(s);
1391 Result := true;
1392 except
1393 on EConvertError do
1394 Result := false;
1395 end;
1396
1397 end;
1398
1399 procedure testIsNumeric;
1400 procedure mycheck(r{?炭???????辿????}: boolean; s2{???????n?????e}: String);
1401 begin
1402 Check(r, IsNumeric(s2));
1403 end;
1404 begin
1405 mycheck(True, '12345');
1406 mycheck(True, '-12345');
1407 mycheck(False,'123.45');
1408 mycheck(False,'12345F' );
1409 mycheck(True, '+50');
1410 mycheck(False,'?P?Q?R?S?T');
1411 mycheck(False,'');
1412 end;
1413
1414 function IsFloat(s: string): boolean;
1415 var
1416 v: Extended;
1417 begin
1418 Result := TextToFloat(PChar(s), v, fvExtended);
1419 end;
1420
1421 procedure testIsFloat;
1422 procedure mycheck(r{?炭???????辿????}: boolean; s2{???????n?????e}: String);
1423 begin
1424 Check(r, IsFloat(s2));
1425 end;
1426 begin
1427 mycheck(True, '12345.0');
1428 mycheck(True, '-12345.0');
1429 mycheck(True,'123.45');
1430 mycheck(True, '12345');
1431 mycheck(False,'12345F' );
1432 mycheck(True, '+50');
1433 mycheck(False,'?P?Q?R?S?T');
1434 mycheck(False,'');
1435 end;
1436
1437
1438 function Fmt2chToDateTime(Fmt2ch: String): TDateTime;
1439 var
1440 Year, Month, Day: word;
1441 Hour, Min, Sec, MSec: word;
1442 begin
1443 try
1444 Fmt2ch := Trim(Fmt2ch); //dax
1445 Year := StrToInt(Copy(Fmt2ch, 1, 4));
1446 Month := StrToInt(Copy(Fmt2ch, 6, 2));
1447 Day := StrToInt(Copy(Fmt2ch, 9, 2));
1448
1449 Hour := StrToInt(Copy(Fmt2ch,16, 2));
1450 Min := StrToInt(Copy(Fmt2ch,19, 2));
1451 Sec := 0;
1452 MSec:= 0;
1453
1454 Result := EncodeDate(Year, Month, Day)
1455 + EncodeTime(Hour, Min, Sec, MSec);
1456 except
1457 raise EConvertError.Create('?炭?t?????????直?足?????添(??D?)?鄭溺則');
1458 end;
1459 end;
1460
1461 procedure testFmt2chToDateTime;
1462 procedure mycheck(d{?炭???????辿????}: TDateTime; s2{???????n?????e}: String);
1463 begin
1464 Check(d, Fmt2chToDateTime(s2));
1465 end;
1466 begin
1467 mycheck(StrToDateTime('2001/02/18 15:23:00'),
1468 '2001/02/18(?炭) 15:23');
1469
1470 mycheck(StrToDateTime('2001/02/18 15:23:00'),
1471 '2001/02/18(?炭) 15:23 ID=???');
1472
1473 //???????G???[?鼎
1474 {
1475 mycheck(StrToDateTime('0'),
1476 '?????[??');
1477 }
1478 end;
1479
1480 //S??????SubStr?????足?????辿???J?E???g???辿(2?o?C?g????)
1481 {???????????纏?辿???泥?????????鱈???直?????????辿?????造?撤?貼?????長
1482 "????????????"?????造?????????巽"????"???????????????辿??3??????}
1483 function StrCount1(const Substr, S: string): Integer;
1484 var
1485 Str: String;
1486 begin
1487 Result := 0;
1488 if (Substr = '') or (S = '') then exit;
1489
1490 Str := S;
1491 try
1492 while AnsiPos( Substr, Str) <> 0 do
1493 begin
1494 Inc(Result);
1495 delete(Str, AnsiPos( Substr, Str), Length(Substr));
1496 end;
1497 except
1498 Result := -1;
1499 end;
1500 end;
1501
1502 procedure testStrCount1;
1503 procedure mycheck(r{?炭???????辿????}: integer; s2, s3{???????n?????e}: String);
1504 begin
1505 Check(r, StrCount1(s3, s2));
1506 end;
1507 begin
1508 mycheck(3, '????????????', '????');
1509 mycheck(3, 'BorlandDelphiBorlandC++BuilderBorlandKylix', 'Borland');
1510 mycheck(2, 'BorlandDelphiBorlandC++BuilderBorlandKylix', '+');
1511 mycheck(4, 'http://www.2ch.net/hogehoge/test', '/');
1512 mycheck(0, 'http://www.2ch.net/hogehoge/test', '+');
1513 mycheck(0, '+', '+++++');
1514 mycheck(0, '', '+');
1515 end;
1516
1517 //???????????撤????
1518 {"??????????"???巽"????"?????????辿???o?C?g???長7??????}
1519 function BackAnsiPos(const SubStr,S: String): Integer;
1520 var
1521 SearchStr: String;
1522 BackPosIndex: Integer;
1523 MbcsFlag: TMbcsByteType;
1524 begin
1525 Result := 0;
1526 MbcsFlag := mbSingleByte; {?????????????????炭?泥}
1527 if AnsiPos(subStr,S)=0 then exit;
1528
1529 SearchStr := S;
1530 while AnsiPos(subStr,SearchStr)<>0 do
1531 begin
1532 BackPosIndex := AnsiPos(subStr,SearchStr);
1533 MbcsFlag := ByteType(SearchStr, BackPosIndex);
1534 case MbcsFlag of
1535
1536 mbSingleByte: { ?添?p }
1537 Delete(SearchStr,1,BackPosIndex);
1538
1539 mbLeadByte: { ?S?p???P?o?C?g?? }
1540 Delete(SearchStr,1,BackPosIndex +1 );
1541
1542 mbTrailByte: { ?S?p???Q?o?C?g?? }
1543 Delete(SearchStr,1,BackPosIndex);
1544 else
1545 raise Exception.Create('?G???[');
1546 end;
1547 end; //while
1548
1549 case MbcsFlag of
1550 mbSingleByte:
1551 Result := length(S)-Length(SearchStr);
1552
1553 mbLeadByte:
1554 Result := length(S)-Length(SearchStr) - 1;
1555
1556 mbTrailByte:
1557 Result := length(S)-Length(SearchStr);
1558 else
1559 raise Exception.Create('?G???[');
1560 end;
1561 end;
1562
1563 procedure testBackAnsiPos;
1564 procedure mycheck(r{?炭???????辿????}: integer; s2, s3{???????n?????e}: String);
1565 begin
1566 Check(r, BackAnsiPos(s3, s2));
1567 end;
1568 begin
1569 mycheck(9, '????????????', '????');
1570 mycheck(31,'BorlandDelphiBorlandC++BuilderBorlandKylix', 'Borland');
1571 mycheck(28,'http://www.2ch.net/hogehoge/test', '/');
1572 mycheck(0, 'http://www.2ch.net/hogehoge/test', '+');
1573 mycheck(0, '+', '+++++');
1574 mycheck(0, '', '+');
1575 end;
1576
1577 //URL??DOS?p?X?????X
1578 function UrlToDosPath(const Url: string): string;
1579 const
1580 PATH_TERMINATE = '\';
1581 var
1582 S : string;
1583 n, m : integer;
1584 begin
1585 if (AnsiPos('http://', Url) = 1) then begin
1586 s := Copy(Url, 8, Length(Url));
1587 end else begin
1588 s := Url;
1589 end;
1590 n := AnsiPos(':', s);
1591 if (n > 0) then begin
1592 m := AnsiPos('/', s);
1593 s := 'http://' +
1594 Copy(s, 1, n - 1) +
1595 Copy(s, m, Length(Url));
1596 end;
1597
1598 S := AnsiLowerCase(
1599 MonaUtils.ExcludeTrailingSlash(
1600 MonaUtils.ExtractUrlPath(S)));
1601 if (S = '') then begin
1602 Result := Url;
1603 Exit;
1604 end;
1605 if (Copy(S,1,7) = 'http://') then begin
1606 S := Copy(S,8,Length(S) - 7);
1607 end;
1608
1609 S := StringReplace(S, '/', PATH_TERMINATE, [rfReplaceAll]);
1610
1611 if (Copy(S,Length(S) - 3, 4) = PATH_TERMINATE + 'dat') then begin
1612 S := Copy(S,1,Length(S) - 4);
1613 end;
1614 Result := S + PATH_TERMINATE + MonaUtils.ExtractUrlName(Url);
1615 end;
1616
1617 procedure testUrlToDosPath;
1618 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
1619 begin
1620 Check(r, UrlToDosPath(s1));
1621 end;
1622 begin
1623 mycheck('www.2ch.net\', 'http://www.2ch.net/');
1624 mycheck('www.2ch.net\test\read.cgi', 'http://www.2ch.net/test/read.cgi');
1625 mycheck('www.2ch.net\test\', 'www.2ch.net/test/');
1626 mycheck('www.2ch.net\test', 'www.2ch.net/test');
1627 mycheck('ABCDEFG', 'ABCDEFG');
1628 mycheck('\abcdefg\', '/abcdefg/');
1629 mycheck('www.2ch.net\abc\def', 'http://www.2ch.net/abc\def');
1630 end;
1631
1632 //?param=value?? param???w?????辿?? value??????
1633 function ChooseValue(const Url, Key: string): string;
1634 var
1635 List : TStringList;
1636 S : PChar;
1637 begin
1638 GetMem(S, Length(Url) + 1);
1639 StrCopy(S, PChar(Url));
1640 List := TStringList.Create;
1641 {$IFDEF VER120}
1642 ExtractHttpFields(['?','&'], [], S, List);
1643 {$ELSE}
1644 ExtractHttpFields(['?','&'], [], S, List, False);
1645 {$ENDIF}
1646 Result := List.Values[Key];
1647 List.Free;
1648 FreeMem(S);
1649 end;
1650
1651 procedure testChooseValue;
1652 procedure mycheck(r{?炭???????辿????}: string; s1, s2{???????n?????e}: String);
1653 begin
1654 Check(r, ChooseValue(s1, s2));
1655 end;
1656 begin
1657 mycheck('tech',
1658 'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1659 'bbs');
1660 mycheck('12345678',
1661 'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1662 'key');
1663 mycheck('10',
1664 'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1665 'st');
1666 mycheck('',
1667 'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10',
1668 'to');
1669 mycheck('',
1670 'http://www.2ch.net/test/read.cgi',
1671 'bbs');
1672 mycheck('10',
1673 'http://www.2ch.net/test/read.cgi?bbs=tech&key=12345678&st=10&st=20',
1674 'st');
1675 end;
1676
1677 //URL???}?[?W
1678 function MargeUrl(const BaseUrl, NewUrl: string): string;
1679 var
1680 s,r,b : string;
1681 l : TStringList;
1682 i, count : integer;
1683 begin
1684 if (NewUrl = '') then begin
1685 Result := BaseUrl;
1686 Exit;
1687 end else
1688 if (NewUrl[1] = '/') then begin
1689 Result := 'http://' + ExtractHostName(BaseUrl) + NewUrl;
1690 Exit;
1691 end;
1692 count := 0;
1693 s := NewUrl;
1694 while true do begin
1695 if (Copy(s,1,3) = '../') then begin
1696 s := Copy(s, 4, Length(s) - 3);
1697 inc(count);
1698 end else
1699 if (Copy(s,1,2) = './') then begin
1700 s := Copy(s, 3, Length(s) - 2);
1701 end else begin
1702 Break;
1703 end;
1704 end;
1705 r := '';
1706 b := ExtractUrlPath(BaseUrl);
1707 b := Copy(b,7,Length(b));
1708 l := TStringList.Create;
1709 ExtractHTTPFields(['/'],[],PChar(b), l);
1710 for i := 0 to l.Count - count - 1 do begin
1711 r := r + '/'+ l[i];
1712 end;
1713 Result := 'http:/' + r + '/' + s;
1714 end;
1715
1716 procedure testMargeUrl;
1717 procedure mycheck(r{?炭???????辿????}: string; s1, s2{???????n?????e}: String);
1718 begin
1719 Check(r, MargeUrl(s1, s2));
1720 end;
1721 begin
1722 mycheck('http://www.2ch.net/dat',
1723 'http://www.2ch.net/test/',
1724 '../dat');
1725 mycheck('http://www.2ch.net/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/test/dat/',
1732 'http://www.2ch.net/test/data',
1733 './dat/');
1734 mycheck('http://www.2ch.net/',
1735 'http://www.2ch.net/test/',
1736 '../');
1737 mycheck('http://www.2ch.net/',
1738 'http://www.2ch.net/test/',
1739 '/');
1740 mycheck('http://www.2ch.net/test/a/',
1741 'http://www.2ch.net/test/',
1742 'a/');
1743 end;
1744
1745 //A HREF?^?O???????巽URL?????o???辿
1746 function ExtractHrefUrl(const s: string): string;
1747 var
1748 r : string;
1749 n : integer;
1750 begin
1751 n := AnsiPos('href', AnsiLowerCase(s));
1752 r := Copy(s, n, Length(s));
1753 n := AnsiPos('>', r);
1754 if (n > 0) then r := Copy(r, 1, n - 1);
1755 n := AnsiPos(' ', r);
1756 if (n > 0) then r := Copy(r, 1, n - 1);
1757 n := AnsiPos('=', r);
1758 r := Copy(r, n + 1, Length(r));
1759 n := AnsiPos('"', r);
1760 if (n > 0) then r := Copy(r, 2, Length(r) - 2);
1761 Result := r;
1762 end;
1763
1764 procedure testExtractHrefUrl;
1765 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
1766 begin
1767 Check(r, ExtractHrefUrl(s1));
1768 end;
1769 begin
1770 mycheck('http://www.2ch.net/dat/',
1771 '<A HREF="http://www.2ch.net/dat/">');
1772 mycheck('http://www.2ch.net/dat/',
1773 '<a href=http://www.2ch.net/dat/>');
1774 mycheck('http://www.2ch.net/dat/',
1775 '<a target=_blank href=http://www.2ch.net/dat/>');
1776 mycheck('http://www.2ch.net/dat/',
1777 '<a target=_blank href=http://www.2ch.net/dat/><a href=http://www.2ch.net/test/>');
1778 end;
1779
1780 function ZenToHan(const s: string): string;
1781 var
1782 Chr : array [0..255] of char;
1783 begin
1784 {$IFDEF LINUX}
1785 //**LINUX**
1786 {$ENDIF}
1787 {$IFDEF MSWINDOWS}
1788 Windows.LCMapString(
1789 GetUserDefaultLCID(),
1790 LCMAP_HALFWIDTH,
1791 PChar(s),
1792 Length(s) + 1,
1793 chr,
1794 Sizeof(chr)
1795 );
1796 Result := Chr;
1797 {$ENDIF}
1798 end;
1799
1800 procedure testZenToHan;
1801 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
1802 begin
1803 Check(r, ZenToHan(s1));
1804 end;
1805 begin
1806 mycheck('???卒直', '?A?C?E?G?I');
1807 mycheck('???卒直???卒直', '?A?C?E?G?I???卒直');
1808 mycheck('ABC', '?`?a?b');
1809 mycheck('?甜??', '?甜??');
1810 mycheck('?甜??ABC', '?甜???`?a?b');
1811 end;
1812
1813 function GetContentLength(S : string): integer;
1814 var
1815 p : PChar;
1816 p_end : PChar;
1817 n : integer;
1818 begin
1819 p := PChar(s);
1820 p_end := PChar(s) + Length(s);
1821 n := 0;
1822 while p < p_end do begin
1823 if p^ = #13 then begin
1824 //
1825 end else begin
1826 inc(n);
1827 end;
1828 Inc(p);
1829 end;
1830 Result := n;
1831 end;
1832
1833 procedure testGetContentLength;
1834 procedure mycheck(r{?炭???????辿????}: integer; s1{???????n?????e}: String);
1835 begin
1836 Check(r, GetContentLength(s1));
1837 end;
1838 begin
1839 mycheck(1, 'A');
1840 mycheck(0, '');
1841 mycheck(14, '<HTML>' + #13#10 + '</HTML>');
1842 mycheck(14, '<HTML>' + #10 + '</HTML>');
1843 mycheck(15, '<HTML>' + #13#10 + #9 + '</HTML>');
1844 mycheck(20, '<HTML>' + #13#10 + 'Hello' + #0 + '</HTML>'); //#0???J?E???g
1845 end;
1846
1847 function TrimTag(const s: string): string;
1848 var
1849 r : string;
1850 b : boolean;
1851 i : integer;
1852 begin
1853 r := '';
1854 b := False;
1855 for i := 1 to Length(s) do begin
1856 if (ByteType(s, i) = mbSingleByte) then begin
1857 if (s[i] = '<') then begin
1858 b := True;
1859 end else
1860 if (s[i] = '>') and (b) then begin
1861 b := False;
1862 end else
1863 if (not b) then begin
1864 r := r + s[i];
1865 end;
1866 end else begin
1867 if (not b) then begin
1868 r := r + s[i];
1869 end;
1870 end;
1871 end;
1872 Result := Trim(r);
1873 end;
1874
1875 procedure testTrimTag;
1876 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
1877 begin
1878 Check(r, TrimTag(s1));
1879 end;
1880 begin
1881 mycheck('?A?C?E?G?I', '<ABC>?A?C?E?G?I</ABC>');
1882 mycheck('?A?C?E?G?I', '<?????????直>?A?C?E?G?I</?I?}?G???i?[>');
1883 mycheck('????', '<<<a>>>????<<</a>>>');
1884 mycheck('?A?C?E?G?I', '?A?C?E?G?I');
1885 mycheck('', '<A HREF="?A?C?E?G?I">');
1886 mycheck('ABC', '<A HREF="?A?C?E?G?I">ABC</A>');
1887 end;
1888
1889 function AddTargetBlank(const Value: string): string;
1890 var
1891 Org, s, r : string;
1892 x, y, z, t : string;
1893 p, i : integer;
1894 begin
1895 r := '';
1896 Org := Value;
1897 while true do begin
1898 p := AnsiPos('<a', AnsiLowerCase(Org));
1899 if (p > 0) then begin
1900 //???????巽<A ???長?? --> r
1901 s := Copy(Org, 1, p - 1);
1902 r := r + s;
1903 //<A ???巽 > ???長?? --> s
1904
1905 // s = "<A xxxx xxxxxx>"
1906 //t := Copy(Org, p, Length(org));
1907 s := Copy(Org, p, Length(org));
1908 i := AnsiPos('>', s);
1909 t := Copy(s, i + 1, Length(s));
1910 s := Copy(S, 1, i);
1911
1912 if (AnsiPos('href', AnsiLowerCase(s)) > 0) then begin
1913 //TARGET=
1914 p := AnsiPos('TARGET=', AnsiUpperCase(s));
1915 if (p > 0) then begin
1916 x := Copy(s, 1, p - 1); //TARGET???長
1917 y := Copy(s, p, Length(s)); //TARGET???~
1918 i := AnsiPos(' ', y);
1919 if (i > 0) then begin
1920 y := Copy(y, 1, i - 1);
1921 end;
1922 i := AnsiPos('>', y);
1923 if (i > 0) then begin
1924 y := Copy(y, 1, i - 1);
1925 end;
1926 //TARGET ???? --> y
1927 z := Copy(s, Length(x) + Length(y) + 1, Length(s)); //TARGET???????谷
1928 //
1929 s := x + 'TARGET="_blank"' + z;
1930 r := r + s;
1931 //org := Copy(org, AnsiPos('>', Org) + 1, Length(org));
1932 Org := t;
1933 end else begin
1934 //<A xxxxxxx>
1935 s := Copy(s, 1, Length(S) - 1) + ' TARGET="_blank">';
1936 r := r + s;
1937 //org := Copy(org, AnsiPos('>', Org) + 1, Length(org));
1938 Org := t;
1939 end;
1940
1941
1942 end else begin
1943 r := r + s;
1944 org := t; //Copy(org, Length(t) + 1, Length(org));
1945 end;
1946
1947 end else begin;
1948 r := r + Org;
1949 Break;
1950 end;
1951 end;
1952 Result := r;
1953 end;
1954
1955 {
1956 function AddTargetBlank(const Value: string): string;
1957 var
1958 org , s, r, w, x, y, z : string;
1959 frx, tox, i : integer;
1960 b : boolean;
1961 begin
1962 org := Value;
1963 r := '';
1964 while true do begin
1965 //frx := AnsiPos('<A HREF=', AnsiUpperCase(org));
1966 frx := AnsiPos('<A ', AnsiUpperCase(org));
1967 if (frx > 0) then begin
1968 r := r + Copy(org, 1, frx);
1969 org := Copy(org, frx + 1, Length(org));
1970 tox := AnsiPos('>', AnsiUpperCase(org));
1971 if (tox > 0) then begin
1972 s := Copy(org, 1, tox - 1);
1973 if (AnsiPos('TARGET=', AnsiUpperCase(org)) = 0) then begin
1974 s := s + ' TARGET="_blank"';
1975 r := r + s;
1976 org := Copy(org, tox, Length(org));
1977 end else begin
1978 //
1979 // x = '<A HREF=xxxxxxxx |TARGET
1980 //x := Copy(S, 1, AnsiPos('TARGET=', S) - 1);
1981 //y := Copy(S, AnsiPos('TARGET=', S), Length(S));
1982 //z := Copy(y, AnsiPos(' ', y) + 1, Length(y));
1983 b := False;
1984 x := Copy(org, 1, AnsiPos('TARGET=', org) - 1);
1985 w := Trim(Copy(org, Length(x) + 1, Length(org)));
1986 i := AnsiPos(' ', w);
1987 if (i > 0) then begin
1988 y := Copy(w, 1, i - 1);
1989 end else begin
1990 y := w;
1991 b := True;
1992 end;
1993 i := AnsiPos('>', y);
1994 if (i > 0) then begin
1995 y := Copy(y, 1, i - 1);
1996 end;
1997 z := Copy(org, Length(x) + Length(y) + 1, Length(org));
1998
1999 if (Length(x) > 0) then begin
2000 if (Copy(x, Length(x), 1) <> ' ') then begin
2001 x := x + ' ';
2002 end;
2003 end;
2004 if (b) then begin
2005 s := x + 'TARGET="_blank"' + z;
2006 end else begin
2007 s := x + 'TARGET="_blank"';// + z;
2008 end;
2009
2010 //x := x + ' TARGET="_blank"';
2011 //s := s + ' TARGET="_blank"';
2012 r := r + s;
2013 org := Copy(org, Length(s), Length(org));
2014 if (Length(org) > 0) then begin
2015 if (org[1] = '"') then begin
2016 org := Copy(org, 2, Length(org));
2017 end;
2018 end;
2019 end;
2020 end else begin
2021 r := r + org;
2022 Break;
2023 end;
2024 end else begin
2025 r := r + org;
2026 Break;
2027 end;
2028 end;
2029 Result := r;
2030 end;
2031 }
2032 procedure testAddTargetBlank;
2033 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
2034 begin
2035 Check(r, AddTargetBlank(s1));
2036 end;
2037 begin
2038 mycheck('?泥???P???P?O?O?O???卒???????長?Q?????s???辿?????造?????長?B<BR><BR><BR>?P???????甜?長???B<BR><BR><a href=http://www.megabbs.com/cgi-bin/readres.cgi TARGET="_blank">????</a><BR>',
2039 '?泥???P???P?O?O?O???卒???????長?Q?????s???辿?????造?????長?B<BR><BR><BR>?P???????甜?長???B<BR><BR><a href=http://www.megabbs.com/cgi-bin/readres.cgi>????</a><BR>');
2040 mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2041 '<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>');
2042 mycheck('AAA<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2043 'AAA<A HREF="http://www.2ch.net">2ch</A>');
2044 mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2045 '<A HREF="http://www.2ch.net">2ch</A>');
2046 mycheck('<a href="http://www.2ch.net" TARGET="_blank">2ch</A>',
2047 '<a href="http://www.2ch.net">2ch</A>');
2048 mycheck('<a href=http://www.2ch.net TARGET="_blank">2ch</A>',
2049 '<a href=http://www.2ch.net>2ch</A>');
2050 mycheck('<A HREF="http://www.2ch.net" TARGET="_blank">2ch</A>',
2051 '<A HREF="http://www.2ch.net" TARGET="parent">2ch</A>');
2052 mycheck('<A TARGET="_blank" HREF="http://www.2ch.net">2ch</A>',
2053 '<A TARGET="_blank" HREF="http://www.2ch.net">2ch</A>');
2054 mycheck('<A TARGET="_blank" HREF=http://www.2ch.net>2ch</A>',
2055 '<A TARGET=_top HREF=http://www.2ch.net>2ch</A>');
2056 mycheck('<A NAME="AA">2ch</A>',
2057 '<A NAME="AA">2ch</A>');
2058 mycheck('<A>2ch</A>',
2059 '<A>2ch</A>');
2060 mycheck('2ch',
2061 '2ch');
2062 end;
2063
2064 function ExtractDatNo(const DatFileName: string): string;
2065 var
2066 s, ext : string;
2067 begin
2068 if (AnsiPos('http:', DatFileName) = 1) then begin
2069 s := ExtractUrlName(DatFileName);
2070 end else begin
2071 s := ExtractFileName(DatFileName);
2072 end;
2073 ext := ExtractFileExt(s);
2074 if (ext <> '') then begin
2075 s := Copy(s, 1, Length(s) - Length(ext));
2076 end;
2077 Result := s;
2078 end;
2079
2080 procedure testExtractDatNo;
2081 procedure mycheck(r{?炭???????辿????}: string; s1{???????n?????e}: String);
2082 begin
2083 Check(r, ExtractDatNo(s1));
2084 end;
2085 begin
2086 mycheck('123456789',
2087 '123456789.dat');
2088 mycheck('123456789',
2089 '123456789');
2090 mycheck('123456789',
2091 'http://www.2ch.net/tech/dat/123456789.dat');
2092 mycheck('123456789',
2093 'C:\monazilla\monaplorer\dat\123456789.dat');
2094 mycheck('123456789_1',
2095 '123456789_1.dat');
2096 mycheck('123456789_1',
2097 '123456789_1');
2098 mycheck('123456789_1',
2099 'http://www.2ch.net/tech/dat/123456789_1.dat');
2100 mycheck('123456789_1',
2101 'C:\monazilla\monaplorer\dat\123456789_1.dat');
2102 end;
2103
2104 //Tue, 17 Dec 2002 12:18:07 GMT ?即 TDateTime??
2105 function DateStrToDateTime(const DateStr: string): TDateTime;
2106 function StrMonthToMonth(const s: string): integer;
2107 const
2108 m: array[1..12] of string = ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec');
2109 var
2110 i: integer;
2111 begin
2112 Result := -1;
2113 for i := Low(m) to High(m) do begin
2114 if (SameText(s, m[i])) then begin
2115 Result := i;
2116 Break;
2117 end;
2118 end;
2119 end;
2120 var
2121 wDay, wMonth, wYear: word;
2122 wHour, wMinute, wSecond: word;
2123 sTime: string;
2124 d: TDateTime;
2125 begin
2126 wDay := StrToIntDef(ChooseString(DateStr, ' ', 1), 0);
2127 wMonth := StrMonthToMonth(ChooseString(DateStr, ' ', 2));
2128 wYear := StrToIntDef(ChooseString(DateStr, ' ', 3), 0);
2129 sTime := ChooseString(DateStr, ' ', 4);
2130 wHour := StrToIntDef(ChooseString(sTime, ':', 0), 0);
2131 wMinute := StrToIntDef(ChooseString(sTime, ':', 1), 0);
2132 wSecond := StrToIntDef(ChooseString(sTime, ':', 2), 0);
2133 d := EncodeDateTime(wYear, wMonth, wDay, wHour, wMinute, wSecond, 0);
2134 Result := d;
2135 end;
2136
2137 procedure testDateStrToDateTime;
2138 procedure mycheck(r{?炭???????辿????}: TDateTime; s1{???????n?????e}: String);
2139 begin
2140 Check(r, DateStrToDateTime(s1));
2141 end;
2142 begin
2143 mycheck(StrToDateTime('2002/12/17 12:18:07'),
2144 'Tue, 17 Dec 2002 12:18:07 GMT');
2145 mycheck(StrToDateTime('2003/1/10 23:15:10'),
2146 'Fri, 10 Jan 2003 23:15:10 GMT');
2147 mycheck(StrToDateTime('2004/2/29 00:00:00'),
2148 'Fri, 29 Feb 2004 00:00:00 GMT');
2149 mycheck(StrToDateTime('2001/11/11 11:22:33'),
2150 'Fri, 11 Nov 2001 11:22:33 JST');
2151 end;
2152
2153
2154 procedure testMonaUtils;
2155 begin
2156 ClearTestResult;
2157 try
2158 //testMonaHtmlParser;
2159 //testMonaProfiler;
2160 //testExtractUrlPath;
2161 //testExtractUrlName;
2162 //testMaxMin;
2163 //testIncludeTrailingSlash;
2164 //testExcludeTrailingSlash;
2165 //testIsUrlDelimiter;
2166 //testLoadSaveString;
2167 //testFindFile;
2168 //testAddHRefTag;
2169 //testTrimHRefTag;
2170 //testDecodeHtmlEsc;
2171 //testEncodeHtmlEsc;
2172 //testExtractHostName;
2173 //testGet2chDate;
2174 //testChooseString;
2175 //testExtractQuotedStr;
2176 //testExtractUrlLastPath;
2177 //testIsNumeric;
2178 //testFmt2chToDateTime;
2179 //testStrCount1;
2180 //testBackAnsiPos;
2181 //testIsFloat;
2182 //testUrlToDosPath;
2183 //testChooseValue;
2184 //testMargeUrl;
2185 //testExtractHrefUrl;
2186 //testZenToHan;
2187 //testGetContentLength;
2188 //testTrimTag;
2189 //testAddTargetBlank;
2190 //testExtractDatNo;
2191 //testAddTargetBlank;
2192 testDateStrToDateTime;
2193 except
2194 on E:ETestFailure do
2195 ;
2196 on E:Exception do
2197 Inc(TestResult.Error);
2198 end;
2199 end;
2200
2201 initialization
2202 if not QueryPerformanceFrequency(TMonaProfiler_FFrequency) then
2203 RaiseLastWin32Error;
2204
2205 end.

Back to OSDN">Back to OSDN
ViewVC Help
Powered by ViewVC 1.1.26