Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/GikoSystem.pas

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


Revision 1.14 - (show annotations) (download) (as text)
Mon Aug 18 12:50:03 2003 UTC (20 years, 8 months ago) by h677
Branch: MAIN
Changes since 1.13: +6 -4 lines
File MIME type: text/x-pascal
複数のNGワードファイルを使えるようにした。

1 unit GikoSystem;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
7 ComCtrls, IniFiles, ShellAPI, ActnList, Math,
8 {$IF Defined(DELPRO) }
9 SHDocVw,
10 MSHTML,
11 {$ELSE}
12 SHDocVw_TLB,
13 MSHTML_TLB,
14 {$IFEND}
15 {HttpApp,} YofUtils, URLMon, IdGlobal, IdURI, {Masks,}
16 Setting, BoardGroup, gzip, Dolib, bmRegExp, AbonUnit;
17
18 type
19 //BBS?帥?ゃ??
20 TGikoBBSType = (gbt2ch);
21 //???違?帥?ゃ??
22 TGikoLogType = (glt2chNew, glt2chOld);
23 //?<???祉?若?吾?≪?ゃ?潟??/span>
24 TGikoMessageIcon = (gmiOK, gmiSAD, gmiNG, gmiWhat, gmiNone);
25 //URL???若???潟???????吟?帥?ゃ??
26 TGikoBrowserType = (gbtIE, gbtUserApp, gbtAuto);
27
28
29 TStrTokSeparator = set of Char;
30 TStrTokRec = record
31 Str: string;
32 Pos: Integer;
33 end;
34
35 //?ゃ?潟???????鴻???<?ゃ?????潟?若??
36 TIndexRec = record
37 FNo: Integer;
38 FFileName: string;
39 FTitle: string;
40 FCount: Integer;
41 FSize: Integer;
42 // FRoundNo: Integer;
43 FRoundDate: TDateTime;
44 FLastModified: TDateTime;
45 FKokomade: Integer;
46 FNewReceive: Integer;
47 FMishiyou: Boolean; //??戎??/span>
48 FUnRead: Boolean;
49 FScrollTop: Integer;
50 //Index Ver 1.01
51 FAllResCount: Integer;
52 FNewResCount: Integer;
53 FAgeSage: TGikoAgeSage;
54 end;
55
56 //?泣???吾?с???????潟?若??
57 TSubjectRec = record
58 FFileName: string;
59 FTitle: string;
60 FCount: Integer;
61 end;
62
63 //???鴻???潟?若??
64 TResRec = record
65 FTitle: string;
66 FMailTo: string;
67 FName: string;
68 FDateTime: string;
69 FBody: string;
70 FType: TGikoLogType;
71 end;
72
73 //URLPath???潟?若??
74 TPathRec = record
75 FBBS: string; //BBSID
76 FKey: string; //ThreadID
77 FSt: Integer; //??紮????合??/span>
78 FTo: Integer; //腟?篋????合??/span>
79 FFirst: Boolean; //>>1??;腓?/span>
80 FStBegin: Boolean; //1??茵?ず
81 FToEnd: Boolean; //????緇??障?ц;腓?/span>
82 FDone: Boolean; //????
83 end;
84
85 TGikoSys = class(TObject)
86 private
87 { Private 絎h? }
88 FSetting: TSetting;
89 FDolib: TDolib;
90 FAWKStr: TAWKStr;
91 // FExitWrite: TStringList;
92 // function StrToFloatDef(s: string; Default: Double): Double;
93
94 public
95 { Public 絎h? }
96 FAbon : TAbon;
97 FSelectResFilter : TAbon;
98 constructor Create;
99
100 destructor Destroy; override;
101
102
103 // function MsgBox(Msg: string; Title: string; Flags: Longint): integer; overload;
104 // function MsgBox(Handle: THandle; Msg: string; Title: string; Flags: Longint): integer; overload;
105 function IsNumeric(s: string): boolean;
106 function IsFloat(s: string): boolean;
107 function DirectoryExistsEx(const Name: string): Boolean;
108 function ForceDirectoriesEx(Dir: string): Boolean;
109 // function GetVersion: string;
110
111 function GetBoardFileName: string;
112 function GetCustomBoardFileName: string;
113 function GetHtmlTempFileName: string;
114 function GetAppDir: string;
115 function GetTempFolder: string;
116 function GetSentFileName: string;
117 function GetConfigDir: string;
118 function GetStyleSheetDir: string;
119 function GetOutBoxFileName: string;
120 function GetURL(BBSID: string; FileName: string): string;
121 function GetUserAgent: string;
122
123 procedure ReadSubjectFile(Board: TBoard);
124 procedure CreateThreadDat(Board: TBoard);
125 procedure WriteThreadDat(Board: TBoard);
126 function ParseIndexLine(Line: string): TIndexRec;
127 procedure GetFileList(Path: string; Mask: string; List: TStringList; SubDir: Boolean; IsPathAdd: Boolean);
128
129 procedure CreateHTML2(doc: Variant; ThreadItem: TThreadItem; var sTitle: string);
130 function AddAnchorTag(s: string): string;
131
132 function DivideSubject(Line: string): TSubjectRec;
133 function DivideStrLine(Line: string): TResRec;
134
135 property Setting: TSetting read FSetting write FSetting;
136 property Dolib: TDolib read FDolib write FDolib;
137
138 function UrlToID(url: string): string;
139 function UrlToServer(url: string): string;
140
141 function StrTokFirst(const s:string; const sep:TStrTokSeparator; var Rec:TStrTokRec):string;
142 function StrTokNext(const sep:TStrTokSeparator; var Rec:TStrTokRec): string;
143
144 function GetFileSize(FileName : string) : longint;
145 function GetFileLineCount(FileName : string): longint;
146 function Get2chDate(aDate: TDateTime): string;
147 function IntToDateTime(val: Int64): TDateTime;
148 function DateTimeToInt(ADate: TDateTime): Integer;
149
150 function ReadThreadFile(FileName: string; Line: Integer): string;
151
152 procedure MenuFont(Font: TFont);
153
154 function RemoveToken(var s:string;delimiter:string):string;
155 function GetTokenIndex(s: string; delimiter: string; index: Integer): string;
156
157 function DeleteLink(const s: string): string;
158
159 function GetShortName(const LongName: string; ALength: integer): string;
160 function ConvRes(const Body, Bbs, Key, ParamBBS, ParamKey, ParamStart, ParamTo, ParamNoFirst, ParamTrue : string): string;
161
162 function ZenToHan(const s: string): string;
163 function VaguePos(const Substr, S: string): Integer;
164 function BoolToInt(b: Boolean): Integer;
165 function IntToBool(i: Integer): Boolean;
166 function GzipDecompress(ResStream: TStream; ContentEncoding: string): string;
167 procedure LoadKeySetting(ActionList: TActionList);
168 procedure SaveKeySetting(ActionList: TActionList);
169 procedure CreateProcess(const AppPath: string; const Param: string);
170 procedure OpenBrowser(URL: string; BrowserType: TGikoBrowserType);
171 function HTMLDecode(const AStr: String): String;
172 function GetHRefText(s: string): string;
173 function Is2chHost(Host: string): Boolean;
174 function Parse2chURL(const url: string; const path: string; const document: string; var BBSID: string; var BBSKey: string): Boolean;
175 function Parse2chURL2(URL: string): TPathRec;
176 procedure ParseURI(var URL, Protocol, Host, Path, Document, Port, Bookmark: string);
177 function GetVersionBuild: Integer;
178 end;
179
180 var
181 GikoSys: TGikoSys;
182 const
183 LENGTH_RESTITLE = 40;
184 ZERO_DATE: Integer = 25569;
185 BETA_VERSION_NAME_E = 'beta';
186 BETA_VERSION_NAME_J = '鐓?鐓?鐓?';
187 BETA_VERSION = 34;
188 BETA_VERSION_BUILD = ''; //debug??????/span>
189
190 implementation
191
192 uses
193 Giko, RoundData;
194
195 const
196 BOARD_FILE_NAME = 'board.2ch';
197 CUSTOMBOARD_FILE_NAME = 'custom.2ch';
198 KEY_SETTING_FILE_NAME = 'key.ini';
199 TEMP_FOLDER = 'Temp';
200 OUTBOX_FILE_NAME = 'outbox.ini';
201 SENT_FILE_NAME = 'sent.ini';
202 CONFIG_DIR_NAME = 'config';
203 CSS_DIR_NAME = 'css';
204 FOLDER_INDEX_VERSION = '1.01';
205 USER_AGENT = 'Monazilla';
206 APP_NAME = 'gikoNavi';
207 DEFAULT_NGWORD_FILE_NAME : String = 'NGword.txt';
208 NGWORDs_DIR_NAME : String = 'NGwords';
209
210 (*************************************************************************
211 *GikoSys?潟?潟?鴻????????/span>
212 *************************************************************************)
213 constructor TGikoSys.Create;
214 begin
215 FSetting := TSetting.Create;
216 FDolib := TDolib.Create;
217 FAWKStr := TAWKStr.Create(nil);
218 FAbon := TAbon.Create;
219 FAbon.Setroot(GetConfigDir+NGWORDs_DIR_NAME);
220 //FAbon.SetNGwordpath(DEFAULT_NGWORD_FILE_NAME);
221 FAbon.GoHome;
222 FSelectResFilter := TAbon.Create;
223 //FSelectResFilter.Setroot( GetAppDir );
224 // 腟????????翫??? False ?????с????????
225 // FSelectResFilter.Reverse := True;
226 // 腟???莨若????????サ??筝?荀с??荀????????祉???????????т????????????/span>
227 FSelectResFilter.AbonString := '';
228 end;
229
230 (*************************************************************************
231 *GikoSys???鴻????????/span>
232 *************************************************************************)
233 destructor TGikoSys.Destroy;
234 var
235 i: Integer;
236 FileList: TStringList;
237 begin
238 //?鴻?????????若?帥???<?ゃ?????贋??/span>
239 // FlashExitWrite;
240
241 // FExitWrite.Free;
242 FAWKStr.Free;
243 FSetting.Free;
244 FDolib.Free;
245
246 //???潟??????TML??????/span>
247 FileList := TStringList.Create;
248 try
249 GetFileList(GetTempFolder, '*.html', FileList, False, True);
250 for i := 0 to FileList.Count - 1 do begin
251 DeleteFile(FileList[i]);
252 end;
253 finally
254 FileList.Free;
255 end;
256 inherited;
257 end;
258
259 (*************************************************************************
260 *??絖????医????с????/span>
261 *************************************************************************)
262 {$HINTS OFF}
263 function TGikoSys.IsNumeric(s: string): boolean;
264 var
265 e: integer;
266 v: integer;
267 begin
268 Val(s, v, e);
269 Result := e = 0;
270 end;
271 {$HINTS ON}
272
273 (*************************************************************************
274 *??絖???羌???絨?亥?号?医????с????/span>
275 *************************************************************************)
276 function TGikoSys.IsFloat(s: string): boolean;
277 var
278 v: Extended;
279 begin
280 Result := TextToFloat(PChar(s), v, fvExtended);
281 end;
282
283 (*************************************************************************
284 *???若?????<?ゃ??????緇?鐚????刻????<?ゃ????鐚?
285 *************************************************************************)
286 function TGikoSys.GetBoardFileName: string;
287 begin
288 Result := GetAppDir + CONFIG_DIR_NAME + '\' + BOARD_FILE_NAME;
289 end;
290
291 (*************************************************************************
292 *???若?????<?ゃ??????緇?鐚????刻????<?ゃ????鐚?
293 *************************************************************************)
294 function TGikoSys.GetCustomBoardFileName: string;
295 begin
296 Result := GetAppDir + CONFIG_DIR_NAME + '\' + CUSTOMBOARD_FILE_NAME;
297 end;
298
299 (*************************************************************************
300 *???潟???????????????弱????緇?
301 *************************************************************************)
302 function TGikoSys.GetHtmlTempFileName: string;
303 begin
304 Result := TEMP_FOLDER;
305 end;
306
307
308 (*************************************************************************
309 *絎?茵????<?ゃ????????????緇?
310 *************************************************************************)
311 function TGikoSys.GetAppDir: string;
312 begin
313 Result := ExtractFilePath(Application.ExeName);
314 end;
315
316 (*************************************************************************
317 *TempHtml???<?ゃ??????緇?鐚????刻????<?ゃ????鐚?
318 *************************************************************************)
319 function TGikoSys.GetTempFolder: string;
320 begin
321 Result := GetAppDir + TEMP_FOLDER;
322 end;
323
324 (*************************************************************************
325 *sent.ini???<?ゃ??????緇?鐚????刻????<?ゃ????鐚?
326 *************************************************************************)
327 function TGikoSys.GetSentFileName: string;
328 begin
329 Result := GetAppDir + SENT_FILE_NAME;
330 end;
331
332 (*************************************************************************
333 *outbox.ini???<?ゃ??????緇?鐚????刻????<?ゃ????鐚?
334 *************************************************************************)
335 function TGikoSys.GetOutBoxFileName: string;
336 begin
337 Result := GetAppDir + OUTBOX_FILE_NAME;
338 end;
339
340 (*************************************************************************
341 *Config??????????緇?
342 *************************************************************************)
343 function TGikoSys.GetConfigDir: string;
344 begin
345 Result := IncludeTrailingPathDelimiter(GetAppDir + CONFIG_DIR_NAME);
346 end;
347
348 function TGikoSys.GetStyleSheetDir: string;
349 begin
350 Result := IncludeTrailingPathDelimiter(GetConfigDir + CSS_DIR_NAME);
351 end;
352
353 (*************************************************************************
354 *URL??篏???(?潟??????
355 *************************************************************************)
356 function TGikoSys.GetURL(BBSID: string; FileName: string): string;
357 var
358 Board: TBoard;
359 begin
360 Board := BoardGroup.BBS2ch.GetBoardFromBBSID(BBSID);
361 Result := UrlToServer(Board.URL) + 'test/read.cgi/' + UrlToID(Board.URL) + '/' + ChangeFileExt(FileName, '') + '/l50';
362 //http://teri.2ch.net/test/read.cgi?bbs=accuse&key=974619522&ls=50
363 //http://pc.2ch.net/test/read.cgi/tech/1003664165/l50
364 end;
365
366 // UserAgent??緇?
367 function TGikoSys.GetUserAgent: string;
368 begin
369 if Dolib.Connected then begin
370 Result := Format('%s %s/%s%d%s', [
371 Dolib.UserAgent,
372 APP_NAME,
373 //MAJOR_VERSION,
374 //MINOR_VERSION,
375 BETA_VERSION_NAME_E,
376 BETA_VERSION,
377 BETA_VERSION_BUILD]);
378 end else begin
379 Result := Format('%s/%s %s/%s%d%s', [
380 USER_AGENT,
381 Dolib.Version,
382 APP_NAME,
383 //MAJOR_VERSION,
384 //MINOR_VERSION,
385 BETA_VERSION_NAME_E,
386 BETA_VERSION,
387 BETA_VERSION_BUILD]);
388 end;
389 end;
390
391 (*************************************************************************
392 *鐚??<?????????劫????糸??
393 *************************************************************************)
394 function TGikoSys.Get2chDate(aDate: TDateTime): string;
395 var
396 d1: TDateTime;
397 d2: TDateTime;
398 begin
399 d1 := EncodeDate(1970, 1, 1);
400 d2 := aDate - EncodeTime(9, 0, 0, 0);
401 Result := FloatToStr(Trunc((d2 - d1) * 24 * 60 * 60));
402 end;
403
404
405 function TGikoSys.IntToDateTime(val: Int64): TDateTime;
406 var
407 d1: tdatetime;
408 d2: tdatetime;
409 begin
410 d1 := EncodeDate(1970, 1, 1);
411 d2 := (val * 1000) / (24 * 60 * 60 * 1000);
412 Result := d1 + d2;
413 end;
414
415 function TGikoSys.DateTimeToInt(ADate: TDateTime): Integer;
416 var
417 d: TDateTime;
418 c: Currency;
419 begin
420 d := EncodeDate(1970, 1, 1);
421 c := (ADate - d) * 24 * 60 * 60;
422 Result := Trunc(c);
423 end;
424
425
426 (*************************************************************************
427 *Subject???<?ゃ??ead
428 *************************************************************************)
429 procedure TGikoSys.ReadSubjectFile(Board: TBoard);
430 var
431 ThreadItem: TThreadItem;
432 FileName: string;
433 FileList: TStringList;
434 TmpFileList: TStringList;
435 // SrchRec: TSearchRec;
436 // R: integer;
437 Index: Integer;
438 sl: TStringList;
439 i: Integer;
440 Rec: TIndexRec;
441 UnRead: Integer;
442 TmpUpdate: Boolean;
443 ini: TMemIniFile;
444 ResRec: TResRec;
445 RoundItem: TRoundItem;
446 idx: Integer;
447 begin
448 Board.Clear;
449 UnRead := 0;
450 TmpUpdate := False;
451
452 FileName := Board.GetFolderIndexFileName;
453 if not FileExists(FileName) then CreateThreadDat(Board);
454 // if not FileExists(FileName) then Exit;
455
456 //IsLogFile??AT???<?ゃ?????鴻??
457 FileList := TStringList.Create;
458 FileList.Sorted := True;
459 GetFileList(ExtractFileDir(Board.GetFolderIndexFileName), '*.dat', FileList, False, False);
460
461 //?????医幻腟?篋?????mp???<?ゃ?????鴻??
462 TmpFileList := TStringList.Create;
463 TmpFileList.Sorted := True;
464 GetFileList(ExtractFileDir(Board.GetFolderIndexFileName), '*.tmp', TmpFileList, False, False);
465
466 { R := FindFirst(ExtractFileDir(Board.GetFolderIndexFileName) + '\*.dat', 0, SrchRec);
467 while R = 0 do begin
468 FileList.Add(SrchRec.Name);
469 R := FindNext(SrchRec);
470 end;
471 FindClose(SrchRec);}
472
473 sl := TStringList.Create;
474 try
475 if FileExists(FileName) then
476 sl.LoadFromFile(FileName);
477
478 //鐚?茵???????鐚?鐚?茵????????若?吾?с?鰹?
479 for i := 1 to sl.Count - 1 do begin
480 Rec := ParseIndexLine(sl[i]);
481
482 ThreadItem := TThreadItem.Create;
483 ThreadItem.BeginUpdate;
484 ThreadItem.No := Rec.FNo;
485 ThreadItem.FileName := Rec.FFileName;
486 ThreadItem.Title := Rec.FTitle;
487 ThreadItem.Count := Rec.FCount;
488 ThreadItem.Size := Rec.FSize;
489 // ThreadItem.RoundNo := Rec.FRoundNo;
490 ThreadItem.RoundDate := Rec.FRoundDate;
491 ThreadItem.LastModified := Rec.FLastModified;
492 ThreadItem.Kokomade := Rec.FKokomade;
493 ThreadItem.NewReceive := Rec.FNewReceive;
494 // ThreadItem.Round := Rec.FRound;
495 ThreadItem.UnRead := Rec.FUnRead;
496 ThreadItem.ScrollTop := Rec.FScrollTop;
497 ThreadItem.AllResCount := Rec.FAllResCount;
498 ThreadItem.NewResCount := Rec.FNewResCount;
499 ThreadItem.AgeSage := Rec.FAgeSage;
500 ThreadItem.ParentBoard := Board;
501
502 //IsLogFile???с????/span>
503 ThreadItem.IsLogFile := False;
504 if FileList.Count <> 0 then begin
505 if FileList.Find(ThreadItem.FileName, Index) then begin
506 ThreadItem.IsLogFile := True;
507 FileList.Delete(Index);
508 end;
509 end;
510
511 //綏≦?????鴻?????????????綏≦???????違?祉????
512 if ThreadItem.IsLogFile then begin
513 idx := RoundList.Find(ThreadItem);
514 if idx <> -1 then begin
515 RoundItem := RoundList.Items[idx, grtItem];
516 ThreadItem.RoundName := RoundItem.RoundName;
517 ThreadItem.Round := True;
518 end;
519 end;
520
521 //?????医幻腟?篋??????с????/span>
522 if TmpFileList.Count <> 0 then begin
523 if TmpFileList.Find(ChangeFileExt(ThreadItem.FileName, '.tmp'), Index) then begin
524 ini := TMemIniFile.Create(ChangeFileExt(ThreadItem.GetThreadFileName, '.tmp'));
525 try
526 ThreadItem.RoundDate := ini.ReadDateTime('Setting', 'RoundDate', ZERO_DATE);
527 ThreadItem.LastModified := ini.ReadDateTime('Setting', 'LastModified', ZERO_DATE);
528 ThreadItem.Size := ini.ReadInteger('Setting', 'Size', 0);
529 ThreadItem.Count := ini.ReadInteger('Setting', 'Count', 0);
530 ThreadItem.NewReceive := ini.ReadInteger('Setting', 'NewReceive', 0);
531 ThreadItem.Round := ini.ReadBool('Setting', 'Round', False);
532 ThreadItem.UnRead := False;//ini.ReadBool('Setting', 'UnRead', False);
533 ThreadItem.ScrollTop := ini.ReadInteger('Setting', 'ScrollTop', 0);
534 ThreadItem.AllResCount := ini.ReadInteger('Setting', 'AllResCount', 0);
535 ThreadItem.NewResCount := ini.ReadInteger('Setting', 'NewResCount', 0);
536 ThreadItem.AgeSage := TGikoAgeSage(ini.ReadInteger('Setting', 'AgeSage', Ord(gasNone)));
537 finally
538 ini.Free;
539 end;
540 TmpFileList.Delete(Index);
541 end;
542 end;
543
544 ThreadItem.EndUpdate;
545 Board.Add(ThreadItem);
546
547 // if (ThreadItem.IsLogFile) and (ThreadItem.Count > ThreadItem.Kokomade) then
548 if (ThreadItem.IsLogFile) and (ThreadItem.UnRead) then
549 Inc(UnRead);
550 end;
551 if UnRead <> Board.UnRead then
552 Board.UnRead := UnRead;
553
554 //?ゃ?潟???????鴻???<???c?????違??菴遵??鐚??????ゃ?潟???????劫?綽?鐚?
555 for i := 0 to FileList.Count - 1 do begin
556 FileName := ExtractFileDir(Board.GetFolderIndexFileName) + '\' + FileList[i];
557
558 ResRec := DivideStrLine(ReadThreadFile(FileName, 1));
559 ThreadItem := TThreadItem.Create;
560 ThreadItem.No := Board.Count + 1;
561 ThreadItem.FileName := FileList[i];
562 ThreadItem.Title := ResRec.FTitle;
563 ThreadItem.Count := GetFileLineCount(FileName);
564 ThreadItem.AllResCount := ThreadItem.Count;
565 ThreadItem.NewResCount := 0;
566 ThreadItem.Size := 0;
567 ThreadItem.RoundDate := ZERO_DATE;
568 ThreadItem.LastModified := ZERO_DATE;
569 ThreadItem.Kokomade := -1;
570 ThreadItem.NewReceive := 0;
571 ThreadItem.ParentBoard := Board;
572 ThreadItem.IsLogFile := True;
573 ThreadItem.Round := False;
574 ThreadItem.UnRead := False;
575 ThreadItem.ScrollTop := 0;
576 ThreadItem.AgeSage := gasNone;
577 Board.Add(ThreadItem);
578 end;
579 finally
580 sl.Free;
581 end;
582 FileList.Free;
583 TmpFileList.Free;
584 Board.IsThreadDatRead := True;
585 end;
586
587 (*************************************************************************
588 *?鴻???????ゃ?潟???????鴻???<?ゃ??Folder.idx)篏???
589 *************************************************************************)
590 procedure TGikoSys.CreateThreadDat(Board: TBoard);
591 var
592 i: integer;
593 s: string;
594 SubjectList: TStringList;
595 sl: TStringList;
596 Rec: TSubjectRec;
597 FileName: string;
598 cnt: Integer;
599 begin
600 if not FileExists(Board.GetSubjectFileName) then Exit;
601 FileName := Board.GetFolderIndexFileName;
602
603 SubjectList := TStringList.Create;
604 try
605 SubjectList.LoadFromFile(Board.GetSubjectFileName);
606 sl := TStringList.Create;
607 try
608 cnt := 1;
609 sl.Add(FOLDER_INDEX_VERSION);
610 for i := 0 to SubjectList.Count - 1 do begin
611 Rec := DivideSubject(SubjectList[i]);
612
613 if (Trim(Rec.FFileName) = '') or (Trim(Rec.FTitle) = '') then
614 Continue;
615
616 s := Format('%x', [cnt]) + #1 //???/span>
617 + Rec.FFileName + #1 //???<?ゃ????
618 + Rec.FTitle + #1 //?帥?ゃ????/span>
619 + Format('%x', [Rec.FCount]) + #1 //?????潟??
620 + Format('%x', [0]) + #1 //size
621 + Format('%x', [0]) + #1 //RoundDate
622 + Format('%x', [0]) + #1 //LastModified
623 + Format('%x', [0]) + #1 //Kokomade
624 + Format('%x', [0]) + #1 //NewReceive
625 + '0' + #1 //??戎??/span>
626 + Format('%x', [0]) + #1 //UnRead
627 + Format('%x', [0]) + #1 //ScrollTop
628 + Format('%x', [Rec.FCount]) + #1 //AllResCount
629 + Format('%x', [0]) + #1 //NewResCount
630 + Format('%x', [0]); //AgeSage
631
632 sl.Add(s);
633 inc(cnt);
634 end;
635 sl.SaveToFile(FileName);
636 finally
637 sl.Free;
638 end;
639 finally
640 SubjectList.Free;
641 end;
642 end;
643
644 (*************************************************************************
645 *?鴻???????ゃ?潟????????Thread.dat)?吾??莨若??/span>
646 *Public
647 *************************************************************************)
648 procedure TGikoSys.WriteThreadDat(Board: TBoard);
649 //const
650 // Values: array[Boolean] of string = ('0', '1');
651 var
652 i: integer;
653 FileName: string;
654 sl: TStringList;
655 s: string;
656 FileList: TStringList;
657 begin
658 if not Board.IsThreadDatRead then
659 Exit;
660 FileName := Board.GetFolderIndexFileName;
661 ForceDirectoriesEx(Board.ParentCategory.ParentBBS2ch.GetLogFolder + Board.BBSID);
662
663 sl := TStringList.Create;
664 try
665 sl.Add(FOLDER_INDEX_VERSION);
666 for i := 0 to Board.Count - 1 do begin
667 if Board.Items[i].No = 0 then
668 Board.Items[i].No := i + 1;
669
670 s := Format('%x', [Board.Items[i].No]) + #1
671 + Board.Items[i].FileName + #1
672 + Board.Items[i].Title + #1
673 + Format('%x', [Board.Items[i].Count]) + #1
674 + Format('%x', [Board.Items[i].Size]) + #1
675 + Format('%x', [DateTimeToInt(Board.Items[i].RoundDate)]) + #1
676 + Format('%x', [DateTimeToInt(Board.Items[i].LastModified)]) + #1
677 + Format('%x', [Board.Items[i].Kokomade]) + #1
678 + Format('%x', [Board.Items[i].NewReceive]) + #1
679 + '0' + #1 //??戎??/span>
680 + Format('%x', [BoolToInt(Board.Items[i].UnRead)]) + #1
681 + Format('%x', [Board.Items[i].ScrollTop]) + #1
682 + Format('%x', [Board.Items[i].AllResCount]) + #1
683 + Format('%x', [Board.Items[i].NewResCount]) + #1
684 + Format('%x', [Ord(Board.Items[i].AgeSage)]);
685
686 sl.Add(s);
687 end;
688
689 sl.SaveToFile(FileName);
690
691 FileList := TStringList.Create;
692 try
693 GetFileList(ExtractFileDir(Board.GetFolderIndexFileName), '*.tmp', FileList, False, True);
694 for i := 0 to FileList.Count - 1 do begin
695 DeleteFile(FileList[i]);
696 end;
697 finally
698 FileList.Free;
699 end;
700 finally
701 sl.Free;
702 end;
703 end;
704
705 function TGikoSys.ParseIndexLine(Line: string): TIndexRec;
706 var
707 s: string;
708 i: Integer;
709 begin
710 for i := 0 to 14 do begin
711 s := GetTokenIndex(Line, #1, i);
712 case i of
713 0: Result.FNo := StrToIntDef('$' + s, 0);
714 1: Result.FFileName := s;
715 2: Result.FTitle := s;
716 3: Result.FCount := StrToIntDef('$' + s, 0);
717 4: Result.FSize := StrToIntDef('$' + s, 0);
718 5: Result.FRoundDate := IntToDateTime(StrToIntDef('$' + s, ZERO_DATE));
719 6: Result.FLastModified := IntToDateTime(StrToIntDef('$' + s, ZERO_DATE));
720 7: Result.FKokomade := StrToIntDef('$' + s, -1);
721 8: Result.FNewReceive := StrToIntDef('$' + s, 0);
722 9: ; //??戎??/span>
723 10: Result.FUnRead := IntToBool(StrToIntDef('$' + s, 0));
724 11: Result.FScrollTop := StrToIntDef('$' + s, 0);
725 12: Result.FAllResCount := StrToIntDef('$' + s, 0);
726 13: Result.FNewResCount := StrToIntDef('$' + s, 0);
727 14: Result.FAgeSage := TGikoAgeSage(StrToIntDef('$' + s, 0));
728 end;
729 end;
730 end;
731
732 //??絎???????????????絎????<?ゃ???荀с????緇?????
733 // ListFiles('c:\', '*.txt', list, True);
734 procedure TGikoSys.GetFileList(Path: string; Mask: string; List: TStringList; SubDir: Boolean; IsPathAdd: Boolean);
735 var
736 rc: Integer;
737 SearchRec : TSearchRec;
738 s: string;
739 begin
740 Path := IncludeTrailingPathDelimiter(Path);
741 rc := FindFirst(Path + '*.*', faAnyfile, SearchRec);
742 try
743 while rc = 0 do begin
744 if (SearchRec.Name <> '..') and (SearchRec.Name <> '.') then begin
745 s := Path + SearchRec.Name;
746 //if (SearchRec.Attr and faDirectory > 0) then
747 // s := IncludeTrailingPathDelimiter(s)
748
749 if (SearchRec.Attr and faDirectory = 0) and (MatchesMask(s, Mask)) then
750 if IsPathAdd then
751 List.Add(s)
752 else
753 List.Add(SearchRec.Name);
754 if SubDir and (SearchRec.Attr and faDirectory > 0) then
755 GetFileList(s, Mask, List, True, IsPathAdd);
756 end;
757 rc := FindNext(SearchRec);
758 end;
759 finally
760 SysUtils.FindClose(SearchRec);
761 end;
762 end;
763
764 procedure TGikoSys.CreateHTML2(doc: Variant; ThreadItem: TThreadItem; var sTitle: string);
765 var
766 i: integer;
767 No: string;
768 //bufList : TStringList;
769 ReadList: TStringList;
770 SaveList: TStringList;
771 CSSFileName: string;
772 BBSID: string;
773 FileName: string;
774 NewReceiveNo: Integer;
775 Res: TResRec;
776 begin
777 ShortDayNames[1] := '??#39;; ShortDayNames[2] := '??';
778 ShortDayNames[3] := '??#39;; ShortDayNames[4] := '羂?#39;;
779 ShortDayNames[5] := '??#39;; ShortDayNames[6] := '??';
780 ShortDayNames[7] := '??';
781 BBSID := ThreadItem.ParentBoard.BBSID;
782 FileName := ThreadItem.FileName;
783 NewReceiveNo := ThreadItem.NewReceive;
784 FileName := ThreadItem.GetThreadFileName;
785 ReadList := TStringList.Create;
786 FAbon.Deleterlo := FSetting.AbonDeleterlo;
787 FAbon.Replaceul := FSetting.AbonReplaceul;
788 FAbon.AbonPopupRes := FSetting.PopUpAbon;
789 try
790 if ThreadItem.IsLogFile then begin
791 ReadList.LoadFromFile(FileName);
792 FAbon.Execute(ReadList); // ???若????????/span>
793 FSelectResFilter.Execute(ReadList); //???鴻?????c???帥???潟?違??????
794 Res := DivideStrLine(ReadList[0]);
795 Res.FTitle := StringReplace(Res.FTitle, '鐚?鐔?', ',', [rfReplaceAll]);
796 sTitle := Res.FTitle;
797
798 end else begin
799 sTitle := StringReplace(ThreadItem.Title, '鐚?鐔?', ',', [rfReplaceAll]);
800 end;
801 SaveList := TStringList.Create;
802 try
803 doc.open;
804 doc.charset := 'Shift_JIS';
805
806 CSSFileName := GetStyleSheetDir + Setting.CSSFileName;
807 if GikoSys.Setting.UseCSS and FileExists(CSSFileName) then begin
808 //CSS篏睡??/span>
809 //CSSFileName := GetAppDir + CSS_FILE_NAME;
810 // SaveList.Add('<html lang="ja"><head>');
811 SaveList.Add('<html><head>');
812 SaveList.Add('<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">');
813 SaveList.Add('<title>' + sTitle + '</title>');
814 SaveList.Add('<style type="text/css">');
815 SaveList.Add('@import url(' + CSSFileName + ');');
816 SaveList.Add('</style>');
817 SaveList.Add('</head>');
818 SaveList.Add('<body>');
819 SaveList.Add('<a name="top"></a>');
820 SaveList.Add('<div class="title">' + sTitle + '</div>');
821 //doc.Write(SaveList.Text);
822 //SaveList.Clear;
823 //Application.ProcessMessages;
824 for i := 0 to ReadList.Count - 1 do begin
825 if (Trim(ReadList[i]) <> '') then begin
826 No := IntToStr(i + 1);
827 if (NewReceiveNo = (i + 1)) or ((NewReceiveNo = 0) and (i = 0)) then begin
828 SaveList.Add('<a name="new"></a><div class="new">?亥????? <span class="newdate">' + FormatDateTime('yyyy/mm/dd(ddd) hh:mm', ThreadItem.RoundDate) + '</span></div>');
829 end;
830 Res := DivideStrLine(ReadList[i]);
831 Res.FBody := ConvRes(Res.FBody, ThreadItem.ParentBoard.BBSID, ChangeFileExt(ThreadItem.FileName, ''), 'bbs', 'key', 'st', 'to', 'nofirst', 'true');
832
833 if Res.FType = glt2chOld then begin
834 Res.FMailTo := StringReplace(Res.FMailTo, '鐚?鐔?', ',', [rfReplaceAll]);
835 Res.FName := StringReplace(Res.FName, '鐚?鐔?', ',', [rfReplaceAll]);
836 Res.FBody := StringReplace(Res.FBody, '鐚?鐔?', ',', [rfReplaceAll]);
837 end;
838 //Res.FBody := StringReplace(Res.FBody, '&amphearts;', '&hearts;', [rfReplaceAll]);
839 //Res.FBody := StringReplace(Res.FBody, '&ampnbsp;', '&nbsp;', [rfReplaceAll]);
840 //Res.FBody := StringReplace(Res.FBody, '&amp#', '&#', [rfReplaceAll]);
841 //Res.FBody := StringReplace(Res.FBody, '&amp', '&amp;', [rfReplaceAll]);
842 Res.FBody := AddAnchorTag(Res.FBody);
843 if Res.FName = '' then
844 Res.FName := '&nbsp;';
845 if Res.FMailTo = '' then
846 SaveList.Add('<a name="' + No + '"></a>'
847 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span> '
848 + '<span class="name_label">????鐚?</span> '
849 + '<span class="name"><b>' + Res.FName + '</b></span> '
850 + '<span class="date_label">??腮炊?ワ?</span> '
851 + '<span class="date">' + Res.FDateTime+ '</span></div>'
852 + '<div class="mes">' + Res.FBody + ' </div>')
853 else
854 if GikoSys.Setting.ShowMail then
855 SaveList.Add('<a name="' + No + '"></a>'
856 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span>'
857 + '<span class="name_label"> ????鐚? </span>'
858 + '<a class="name_mail" href="mailto:' + Res.FMailTo + '">'
859 + '<b>' + Res.FName + '</a></b><span class="mail"> [' + Res.FMailTo + ']</span>'
860 + '<span class="date_label"> ??腮炊?ワ?</span>'
861 + '<span class="date"> ' + Res.FDateTime+ '</span></div>'
862 + '<div class="mes">' + Res.FBody + ' </div>')
863 else
864 SaveList.Add('<a name="' + No + '"></a>'
865 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span>'
866 + '<span class="name_label"> ????鐚? </span>'
867 + '<a class="name_mail" href="mailto:' + Res.FMailTo + '">'
868 + '<b>' + Res.FName + '</a></b>'
869 + '<span class="date_label"> ??腮炊?ワ?</span>'
870 + '<span class="date"> ' + Res.FDateTime+ '</span></div>'
871 + '<div class="mes">' + Res.FBody + ' </div>');
872 if ThreadItem.Kokomade = (i + 1) then begin
873 SaveList.Add('<a name="koko"></a><div class="koko">?潟?潟?障?ц?????</div>');
874 end;
875 end;
876 //if SaveList.Count > 50 then begin
877 if i = 20 then begin
878 //Sleep(1);
879 //Application.ProcessMessages;
880
881 doc.Write(SaveList.Text);
882 //while GikoForm.Browser.Busy do begin
883 // Sleep(1);
884 // Application.ProcessMessages;
885 //end;
886 while (GikoForm.Browser.ReadyState <> READYSTATE_COMPLETE) and
887 (GikoForm.Browser.ReadyState <> READYSTATE_INTERACTIVE) do begin
888 //Sleep(1);
889 //Application.ProcessMessages;
890 end;
891 SaveList.Clear;
892 end;
893 end;
894 SaveList.Add('<a name="bottom"></a>');
895 SaveList.Add('</body></html>');
896 SaveList.Add('</dl>');
897 SaveList.Add('<a name="last"></a>');
898 SaveList.Add('</body></html>');
899 doc.Write(SaveList.Text);
900 end else begin
901 //CSS??篏睡??/span>
902 // SaveList.Add('<html lang="ja"><head>');
903 SaveList.Add('<html><head>');
904 SaveList.Add('<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">');
905 SaveList.Add('<title>' + sTitle + '</title></head>');
906 SaveList.Add('<body TEXT="#000000" BGCOLOR="#EFEFEF" link="#0000FF" alink="#FF0000" vlink="#660099">');
907 SaveList.Add('<a name="top"></a>');
908 SaveList.Add('<font size=+1 color="#FF0000">' + sTitle + '</font>');
909 SaveList.Add('<dl>');
910 doc.Write(SaveList.Text);
911 SaveList.Clear;
912 //Application.ProcessMessages;
913 for i := 0 to ReadList.Count - 1 do begin
914 if (Trim(ReadList[i]) <> '') then begin
915 No := IntToStr(i + 1);
916
917 if (NewReceiveNo = (i + 1)) or ((NewReceiveNo = 0) and (i = 0)) then begin
918 SaveList.Add('</dl>');
919 SaveList.Add('<a name="new"></a>');
920 SaveList.Add('<table width="100%" bgcolor="#3333CC" cellpadding="0" cellspacing="1"><tr><td align="center" bgcolor="#6666FF" valign="middle"><font size="-1" color="#ffffff"><b>?亥????? ' + FormatDateTime('yyyy/mm/dd(ddd) hh:mm', ThreadItem.RoundDate) + '</b></font></td></tr></table>');
921 SaveList.Add('<dl>');
922 end;
923 Res := DivideStrLine(ReadList[i]);
924 Res.FBody := ConvRes(Res.FBody, ThreadItem.ParentBoard.BBSID, ChangeFileExt(ThreadItem.FileName, ''), 'bbs', 'key', 'st', 'to', 'nofirst', 'true');
925 if Res.FType = glt2chOld then begin
926 Res.FMailTo := StringReplace(Res.FMailTo, '鐚?鐔?', ',', [rfReplaceAll]);
927 Res.FName := StringReplace(Res.FName, '鐚?鐔?', ',', [rfReplaceAll]);
928 Res.FBody := StringReplace(Res.FBody, '鐚?鐔?', ',', [rfReplaceAll]);
929 end;
930 //Res.FBody := StringReplace(Res.FBody, '&amphearts;', '&hearts;', [rfReplaceAll]);
931 //Res.FBody := StringReplace(Res.FBody, '&ampnbsp;', '&nbsp;', [rfReplaceAll]);
932 //Res.FBody := StringReplace(Res.FBody, '&amp#', '&#', [rfReplaceAll]);
933 //Res.FBody := StringReplace(Res.FBody, '&amp', '&amp;', [rfReplaceAll]);
934 Res.FBody := AddAnchorTag(Res.FBody);
935 if Res.FMailTo = '' then
936 SaveList.Add('<a name="' + No + '"></a><dt><a href="giko://?no=' + No + '">' + No + '</a> ????鐚?<font color="forestgreen"><b> ' + Res.FName + ' </b></font> ??腮炊?ワ? ' + Res.FDateTime+ '<br><dd>' + Res.Fbody + ' <br><br><br>')
937 else
938 if GikoSys.Setting.ShowMail then
939 SaveList.Add('<a name="' + No + '"></a><dt><a href="giko://?no=' + No + '">' + No + '</a> ????鐚?<a href="mailto:' + Res.FMailTo + '"><b> ' + Res.FName + ' </B></a> [' + Res.FMailTo + '] ??腮炊?ワ? ' + Res.FDateTime+ '<br><dd>' + Res.Fbody + ' <br><br><br>')
940 else
941 SaveList.Add('<a name="' + No + '"></a><dt><a href="giko://?no=' + No + '">' + No + '</a> ????鐚?<a href="mailto:' + Res.FMailTo + '"><b> ' + Res.FName + ' </B></a> ??腮炊?ワ? ' + Res.FDateTime+ '<br><dd>' + Res.Fbody + ' <br><br><br>');
942 if ThreadItem.Kokomade = (i + 1) then begin
943 SaveList.Add('</dl>');
944 SaveList.Add('<a name="koko"></a><table width="100%" bgcolor="#55AA55" cellpadding="0" cellspacing="1"><tr><td align="center" bgcolor="#77CC77" valign="middle"><font size="-1" color="#ffffff"><b>?潟?潟?障?ц?????</b></font></td></tr></table>');
945 SaveList.Add('<dl>');
946 end;
947 end;
948 if SaveList.Count > 50 then begin
949 doc.Write(SaveList.Text);
950 SaveList.Clear;
951 //Application.ProcessMessages;
952 end;
953 end;
954 SaveList.Add('</dl>');
955 SaveList.Add('<a name="bottom"></a>');
956 SaveList.Add('</body></html>');
957 doc.Write(SaveList.Text);
958 end;
959 finally
960 SaveList.Free;
961 doc.Close;
962 end;
963 finally
964 ReadList.Free;
965 end;
966 end;
967
968 (*************************************************************************
969 *http://????絖?????anchor?帥?遺???????????
970 *************************************************************************)
971 function TGikoSys.AddAnchorTag(s: string): string;
972 const
973 URL_CHAR: string = '0123456789'
974 + 'abcdefghijklmnopqrstuvwxyz'
975 + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
976 + '#$%&()*+,-./:;=?@[]^_`{|}~!''\';
977 var
978 wkIdx: array[0..9] of Integer;
979 url: string;
980 href: string;
981 i: Integer;
982 idx: Integer;
983 begin
984 Result := '';
985
986 while True do begin
987 wkIdx[0] := AnsiPos('http://', s);
988 wkIdx[1] := AnsiPos('ttp://', s);
989 wkIdx[2] := AnsiPos('tp://', s);
990 wkIdx[3] := AnsiPos('ms-help://', s);
991 wkIdx[4] := AnsiPos('p://', s);
992 wkIdx[5] := AnsiPos('https://', s);
993 wkIdx[6] := AnsiPos('www.', s);
994 wkIdx[7] := AnsiPos('ftp://', s);
995 wkIdx[8] := AnsiPos('news://', s);
996 wkIdx[9] := AnsiPos('rtsp://', s);
997
998 idx := MaxInt;
999 for i := 0 to 8 do
1000 if wkIdx[i] <> 0 then idx := Min(wkIdx[i], idx);
1001
1002 if idx = MaxInt then begin
1003 //???潟?????<??????
1004 Result := Result + s;
1005 Break;
1006 end;
1007
1008 if (idx > 1) and (Copy(s, idx - 1, 1) = '"') then begin
1009 //?≪?????潟???帥?違???ゃ?????????c?純????????????/span>
1010 Result := Result + Copy(s, 0, idx + Length('http://') - 1);
1011 s := Copy(s, idx + Length('http://'), length(s));
1012 Continue;
1013 end;
1014
1015 Result := Result + Copy(s, 0, idx - 1);
1016
1017 s := Copy(s, idx, length(s));
1018
1019 for i := 0 to Length(s) do begin
1020 idx := AnsiPos(s[i + 1], URL_CHAR);
1021 if (idx = 0) or (i = (Length(s))) then begin
1022 //URL??????????絖??肴?鐚?????????絖?????????c????
1023 url := Copy(s, 0, i);
1024
1025 if AnsiPos('ttp://', url) = 1 then
1026 href := 'h' + url
1027 else if AnsiPos('tp://', url) = 1 then
1028 href := 'ht' + url
1029 else if AnsiPos('p://', url) = 1 then
1030 href := 'htt' + url
1031 else if AnsiPos('www.', url) = 1 then
1032 href := 'http://' + url
1033 else
1034 href := url;
1035 Result := Result + '<a href="' + href + '" target="_blank">' + url + '</a>';
1036 s := Copy(s, i + 1, Length(s));
1037 Break;
1038 end;
1039 end;
1040 end;
1041 end;
1042
1043 (*************************************************************************
1044 *?泣???吾?с????筝?茵???????/span>
1045 *************************************************************************)
1046 function TGikoSys.DivideSubject(Line: string): TSubjectRec;
1047 var
1048 i: integer;
1049 ws: WideString;
1050 Delim: string;
1051 LeftK: string;
1052 RightK: string;
1053 begin
1054 Result.FCount := 0;
1055
1056 if Pos('<>', Line) = 0 then
1057 Delim := ','
1058 else
1059 Delim := '<>';
1060
1061 Result.FFileName := GetTokenIndex(Line, Delim, 0);
1062 Result.FTitle := GetTokenIndex(Line, Delim, 1);
1063
1064 ws := Trim(Result.FTitle);
1065
1066 if Copy(ws, Length(ws), 1) = ')' then begin
1067 LeftK := '(';
1068 RightK := ')';
1069 end else if Copy(ws, Length(ws), 1) = '鐚?' then begin
1070 LeftK := '鐚?';
1071 RightK := '鐚?';
1072 end else if Copy(ws, Length(ws), 1) = '<' then begin
1073 LeftK := '<';
1074 RightK := '>';
1075 end;
1076
1077 for i := Length(ws) - 1 downto 1 do begin
1078 if ws[i] = LeftK then begin
1079 ws := Copy(ws, i + 1, Length(ws) - i - 1);
1080 if IsNumeric(ws) then
1081 Result.FCount := StrToInt(ws);
1082 Result.FTitle := Trim(StringReplace(Result.FTitle, LeftK + ws + RightK, '', [rfReplaceAll]));
1083 break;
1084 end;
1085 end;
1086 end;
1087
1088 (*************************************************************************
1089 * dat???<?ゃ????????ゃ?潟????茹?/span>
1090 *************************************************************************)
1091 function TGikoSys.DivideStrLine(Line: string): TResRec;
1092 var
1093 Delim: string;
1094 bufbody : String;
1095 begin
1096 if Pos('<>', Line) = 0 then begin
1097 Delim := ',';
1098 Result.FType := glt2chOld;
1099 end else begin
1100 Delim := '<>';
1101 Result.FType := glt2chNew;
1102 end;
1103 Result.FName := Trim(GetTokenIndex(Line, Delim, 0));
1104 Result.FMailTo := Trim(GetTokenIndex(Line, Delim, 1));
1105 Result.FDateTime := Trim(GetTokenIndex(Line, Delim, 2));
1106 bufBody := Trim(GetTokenIndex(Line, Delim, 3));
1107 if bufbody = '' then begin
1108 Insert('&nbsp;',bufbody, 1);
1109 end;
1110 Result.FBody := bufBody;
1111 Result.FTitle := Trim(GetTokenIndex(Line, Delim, 4));
1112
1113 end;
1114
1115 (*************************************************************************
1116 * URL????BBSID????緇?
1117 *************************************************************************)
1118 function TGikoSys.UrlToID(url: string): string;
1119 var
1120 i: integer;
1121 begin
1122 Result := '';
1123 url := Trim(url);
1124
1125 if url = '' then Exit;
1126
1127 url := Copy(url, 0, Length(url) - 1);
1128 for i := Length(url) downto 0 do begin
1129 if url[i] = '/' then begin
1130 Result := Copy(url, i + 1, Length(url));
1131 Break;
1132 end;
1133 end;
1134 end;
1135
1136 (*************************************************************************
1137 *URL????BBSID篁ュ???????(http://teri.2ch.net/)????緇?
1138 *************************************************************************)
1139 function TGikoSys.UrlToServer(url: string): string;
1140 var
1141 i: integer;
1142 wsURL: WideString;
1143 begin
1144 Result := '';
1145 wsURL := url;
1146 wsURL := Trim(wsURL);
1147
1148 if wsURL = '' then exit;
1149
1150 if Copy(wsURL, Length(wsURL), 1) = '/' then
1151 wsURL := Copy(wsURL, 0, Length(wsURL) - 1);
1152
1153 for i := Length(wsURL) downto 0 do begin
1154 if wsURL[i] = '/' then begin
1155 Result := Copy(wsURL, 0, i);
1156 break;
1157 end;
1158 end;
1159 end;
1160
1161 (*************************************************************************
1162 *???c??????????絖????????????с????/span>
1163 *************************************************************************)
1164 function TGikoSys.DirectoryExistsEx(const Name: string): Boolean;
1165 var
1166 Code: Integer;
1167 begin
1168 Code := GetFileAttributes(PChar(Name));
1169 Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
1170 end;
1171
1172 (*************************************************************************
1173 *???c???????????鐚?茲??育??韻絲上?鐚?
1174 *************************************************************************)
1175 function TGikoSys.ForceDirectoriesEx(Dir: string): Boolean;
1176 begin
1177 Result := True;
1178 if Length(Dir) = 0 then
1179 raise Exception.Create('??????????篏????堺?ャ?障????');
1180 Dir := ExcludeTrailingPathDelimiter(Dir);
1181 if (Length(Dir) < 3) or DirectoryExistsEx(Dir)
1182 or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
1183 Result := ForceDirectoriesEx(ExtractFilePath(Dir)) and CreateDir(Dir);
1184 end;
1185
1186 (*************************************************************************
1187 *??絖??????????若???潟???????冴??鐚?????????鐚?
1188 *FDelphi????????????/span>
1189 *************************************************************************)
1190 function TGikoSys.StrTokFirst(const s:string; const sep: TStrTokSeparator; var Rec: TStrTokRec): string;
1191 begin
1192 Rec.Str := s;
1193 Rec.Pos := 1;
1194 Result := StrTokNext(sep, Rec);
1195 end;
1196
1197 (*************************************************************************
1198 *??絖??????????若???潟???????冴??
1199 *FDelphi????????????/span>
1200 *************************************************************************)
1201 function TGikoSys.StrTokNext(const sep: TStrTokSeparator; var Rec: TStrTokRec): string;
1202 var
1203 Len, I: Integer;
1204 begin
1205 with Rec do begin
1206 Len := Length(Str);
1207 Result := '';
1208 if Len >= Pos then begin
1209 while (Pos <= Len) and (Str[Pos] in sep) do begin
1210 Inc(Pos);
1211 end;
1212 I := Pos;
1213 while (Pos<= Len) and not (Str[Pos] in sep) do begin
1214 if IsDBCSLeadByte(Byte(Str[Pos])) then begin
1215 Inc(Pos);
1216 end;
1217 Inc(Pos);
1218 end;
1219 Result := Copy(Str, I, Pos - I);
1220 while (Pos <= Len) and (Str[Pos] in sep) do begin// ????????絅純??/span>
1221 Inc(Pos);
1222 end;
1223 end;
1224 end;
1225 end;
1226
1227 (*************************************************************************
1228 *???<?ゃ???泣?ゃ?阪??
1229 *************************************************************************)
1230 function TGikoSys.GetFileSize(FileName : string): longint;
1231 var
1232 F : File;
1233 begin
1234 try
1235 if not FileExists(FileName) then begin
1236 Result := 0;
1237 Exit;
1238 end;
1239 Assign(F, FileName);
1240 Reset(F, 1);
1241 Result := FileSize(F);
1242 CloseFile(F);
1243 except
1244 Result := 0;
1245 end;
1246 end;
1247
1248 (*************************************************************************
1249 *???<?ゃ????医??
1250 *************************************************************************)
1251 function TGikoSys.GetFileLineCount(FileName : string): longint;
1252 var
1253 sl: TStringList;
1254 begin
1255 Result := 0;
1256 sl := TStringList.Create;
1257 try
1258 sl.LoadFromFile(FileName);
1259 Result := sl.Count;
1260 finally
1261 sl.Free;
1262 end;
1263 end;
1264
1265 (*************************************************************************
1266 *?鴻?????????<?ゃ????????絎?茵?????緇?
1267 *************************************************************************)
1268 function TGikoSys.ReadThreadFile(FileName: string; Line: Integer): string;
1269 const
1270 BUFFER_SIZE = 1024;
1271 var
1272 f: TextFile;
1273 s: string;
1274 num: Integer;
1275 ArrBuff: array [1..BUFFER_SIZE] of Char;
1276 begin
1277 Result := '';
1278 if FileExists(FileName) then begin
1279 AssignFile(f, FileName);
1280 System.SetTextBuf(f, ArrBuff);
1281 try
1282 Reset(f);
1283 num := 1;
1284 while not Eof(f) do begin
1285 Readln(f, s);
1286 if Line = num then begin
1287 Result := s;
1288 // CloseFile(f);
1289 Break;
1290 end;
1291 inc(num);
1292 end;
1293 finally
1294 CloseFile(f);
1295 end;
1296 end;
1297 end;
1298
1299 (*************************************************************************
1300 *?激?鴻?????<???ャ?若?????潟??????с????緇?
1301 *************************************************************************)
1302 procedure TGikoSys.MenuFont(Font: TFont);
1303 var
1304 lf: LOGFONT;
1305 nm: NONCLIENTMETRICS;
1306 begin
1307 nm.cbSize := sizeof(NONCLIENTMETRICS);
1308
1309 SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @nm, 0);
1310 lf := nm.lfMenuFont;
1311
1312 Font.Name := lf.lfFaceName;
1313 Font.Height := lf.lfHeight;
1314 Font.Style := [];
1315 if lf.lfWeight >= 700 then
1316 Font.Style := Font.Style + [fsBold];
1317 if lf.lfItalic = 1 then
1318 Font.Style := Font.Style + [fsItalic];
1319 end;
1320
1321 (*************************************************************************
1322 *
1323 *?????????泣?ゃ??????????????/span>
1324 *************************************************************************)
1325 function TGikoSys.RemoveToken(var s: string; delimiter: string): string;
1326 var
1327 p: Integer;
1328 begin
1329 p := AnsiPos(delimiter, s);
1330 if p = 0 then
1331 Result := s
1332 else
1333 Result := Copy(s, 1, p - 1);
1334 s := Copy(s, Length(Result) + Length(delimiter) + 1, Length(s));
1335 end;
1336
1337 (*************************************************************************
1338 *
1339 *?????????泣?ゃ??????????????/span>
1340 *************************************************************************)
1341 function TGikoSys.GetTokenIndex(s: string; delimiter: string; index: Integer): string;
1342 var
1343 i: Integer;
1344 begin
1345 Result := '';
1346 for i := 0 to index do
1347 Result := RemoveToken(s, delimiter);
1348 end;
1349
1350 (*************************************************************************
1351 *
1352 *************************************************************************)
1353 function TGikoSys.DeleteLink(const s: string): string;
1354 var
1355 s1: string;
1356 s2: string;
1357 idx: Integer;
1358 i: Integer;
1359 begin
1360 i := 0;
1361 Result := '';
1362 while True do begin
1363 s1 := GetTokenIndex(s, '<a href="', i);
1364 s2 := GetTokenIndex(s, '<a href="', i + 1);
1365
1366 idx := Pos('">', s1);
1367 if idx <> 0 then
1368 Delete(s1, 1, idx + 1);
1369 idx := Pos('">', s2);
1370 if idx <> 0 then
1371 Delete(s2, 1, idx + 1);
1372
1373 Result := Result + s1 + s2;
1374
1375 if s2 = '' then
1376 Break;
1377
1378 inc(i, 2);
1379 end;
1380 end;
1381
1382 //?ゃ?潟???????号???贋?違???????<?????????激?ワ?
1383 {procedure TGikoSys.FlashExitWrite;
1384 var
1385 i: Integer;
1386 begin
1387 //?鴻?????????若?帥???<?ゃ?????贋??/span>
1388 for i := 0 to FExitWrite.Count - 1 do
1389 WriteThreadDat(FExitWrite[i]);
1390 FExitWrite.Clear;
1391 end;}
1392
1393 (*************************************************************************
1394 *?鴻???????????????????????????
1395 *from HotZonu
1396 *************************************************************************)
1397 function TGikoSys.GetShortName(const LongName: string; ALength: integer): string;
1398 const
1399 ERASECHAR : array [1..39] of string =
1400 ('??','??','??','??#39;,'??','??','鐚?#39;,'鐚?','??#39;,'??#39;,
1401 '??#39;,'??#39;,'??39;,'??','??#39;,'??','??','??#39;,'??','??',
1402 '??','??','??','??','??','??','鐚?','鐚?','??#39;,'??#39;,
1403 '鐔?','鐔?','??','??','??#39;,'??39;,'??','??#39;, '??');
1404 var
1405 Chr : array [0..255] of char;
1406 S : string;
1407 i : integer;
1408 begin
1409 s := Trim(LongName);
1410 if (Length(s) <= ALength) then begin
1411 Result := s;
1412 end else begin
1413 S := s;
1414 for i := Low(ERASECHAR) to High(ERASECHAR) do begin
1415 S := StringReplace(S, ERASECHAR[i], '', [rfReplaceAll]);
1416 end;
1417 if (Length(S) <= ALength) then begin
1418 Result := S;
1419 end else begin
1420 Windows.LCMapString(
1421 GetUserDefaultLCID(),
1422 LCMAP_HALFWIDTH,
1423 PChar(S),
1424 Length(S) + 1,
1425 chr,
1426 Sizeof(chr)
1427 );
1428 S := Chr;
1429 S := Copy(S,1,ALength);
1430 while true do begin
1431 if (ByteType(S, Length(S)) = mbLeadByte ) then begin
1432 S := Copy(S, 1, Length(S) - 1);
1433 end else begin
1434 Break;
1435 end;
1436 end;
1437 Result := S;
1438 end;
1439 end;
1440 end;
1441
1442 (*************************************************************************
1443 *
1444 * from HotZonu
1445 *************************************************************************)
1446 function TGikoSys.ConvRes(const Body, Bbs, Key,
1447 ParamBBS, ParamKey, ParamStart, ParamTo, ParamNoFirst, ParamTrue : string): string;
1448 type
1449 PIndex = ^TIndex;
1450 TIndex = record
1451 FIndexFrom : integer;
1452 FIndexTo : integer;
1453 FNo : string;
1454 end;
1455 const
1456 GT = '&gt;';
1457 SN = '0123456789-';
1458 ZN = '鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚???';
1459 var
1460 i : integer;
1461 s,r : string;
1462 b : TMbcsByteType;
1463 sw: boolean;
1464 sp: integer;
1465 No: string;
1466 sx: string;
1467 List: TList;
1468 oc : string;
1469 st, et: string;
1470 chk : boolean;
1471 al : boolean;
1472 procedure Add(IndexFrom, IndexTo: integer; const No: string);
1473 var
1474 FIndex : PIndex;
1475 begin
1476 New(FIndex);
1477 FIndex.FIndexFrom := IndexFrom;
1478 FIndex.FIndexTo := IndexTo;
1479 FIndex.FNo := No;
1480 List.Add(FIndex);
1481 end;
1482 function ChooseString(const Text, Separator: string; Index: integer): string;
1483 var
1484 S : string;
1485 i, p : integer;
1486 begin
1487 S := Text;
1488 for i := 0 to Index - 1 do begin
1489 if (AnsiPos(Separator, S) = 0) then S := ''
1490 else S := Copy(S, AnsiPos(Separator, S) + Length(Separator), Length(S));
1491 end;
1492 p := AnsiPos(Separator, S);
1493 if (p > 0) then Result := Copy(S, 1, p - 1) else Result := S;
1494 end;
1495 begin
1496 { v1.0 b2 - 03 }
1497 s := Body;
1498 r := Body;
1499 i := 1;
1500 sw := False;
1501 No := '';
1502 List:= TList.Create;
1503 oc := '';
1504 sp := 0;
1505 chk := False;
1506 al := False;
1507 while true do begin
1508 b := ByteType(s, i);
1509 case b of
1510 mbSingleByte : begin
1511 if (not sw) and (Copy(s,i,8) = GT + GT) then begin
1512 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 0) then begin
1513 sw := True;
1514 sp := i;
1515 i := i + 7;
1516 oc:='';
1517 chk := True;
1518 end;
1519 end else
1520 if (not sw) and (Copy(s,i,8) = GT + GT) then begin
1521 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 1) then begin
1522 i := i + 7;
1523 oc:='';
1524 chk := True;
1525 end;
1526 end else
1527 if (not sw) and (Copy(s,i,4) = GT) then begin
1528 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 0) then begin
1529 sw := True;
1530 sp := i;
1531 i := i + 3;
1532 oc:='';
1533 chk := True;
1534 end;
1535 end else
1536 if ((not sw) and (Copy(s,i,1) = ',')) or
1537 ((not sw) and (Copy(s,i,1) = '=')) then begin
1538 if ((not Chk) and (AnsiLowerCase(oc) = '</a>')) or
1539 ((Chk) and (oc = '')) or
1540 ((not Chk) and (al)) then
1541 begin
1542 sw := True;
1543 sp := i;
1544 //i := i + 1;
1545 oc:='';
1546 end;
1547 end else
1548 if (sw) then begin
1549 sx := Copy(s,i,1);
1550 if (AnsiPos(sx, SN) > 0) then begin
1551 No := No + sx;
1552 end else begin
1553 if (No <> '') and (No <> '-') then begin
1554 Add(sp, i, No);
1555 al := True;
1556 end;
1557 sw := False;
1558 //
1559 i := i - 1;
1560 //
1561 No := '';
1562 oc:='';
1563 //chk := False;
1564 end;
1565 end else begin
1566 if Copy(s,i,1) = '<' then oc := '';
1567 oc := oc + Copy(s,i,1);
1568 chk := False;
1569 al := False;
1570 end;
1571 end;
1572 mbLeadByte : begin
1573 if (not sw) and (Copy(s,i,4) = '鐚?鐚?') then begin
1574 sw := True;
1575 sp := i;
1576 i := i + 3;
1577 chk := True;
1578 end else
1579 if (not sw) and (Copy(s,i,2) = '鐚?') then begin
1580 sw := True;
1581 sp := i;
1582 i := i + 1;
1583 chk := True;
1584 end else
1585 if (sw) then begin
1586 sx := Copy(s,i,2);
1587 if (AnsiPos(sx, ZN) > 0) then begin
1588 No := No + ZenToHan(sx);
1589 end else begin
1590 if (No <> '') and (No <> '-') and (No <> '??') then begin
1591 Add(sp, i, No);
1592 end;
1593 sw := False;
1594 i := i - 1;
1595 No := '';
1596 end;
1597 end else begin
1598 oc := '';
1599 chk := False;
1600 end;
1601 al := False;
1602 end;
1603 end;
1604 inc(i);
1605 if (i > Length(Body)) then begin
1606 if (sw) then begin
1607 if (No <> '') then Add(sp, i, No);
1608 end;
1609 Break;
1610 end;
1611 end;
1612 for i := List.Count - 1 downto 0 do begin
1613 if (AnsiPos('-', PIndex(List[i]).FNo) > 0) then begin
1614 st := ChooseString(PIndex(List[i]).FNo, '-', 0);
1615 et := ChooseString(PIndex(List[i]).FNo, '-', 1);
1616 end else begin
1617 st := PIndex(List[i]).FNo;
1618 et := PIndex(List[i]).FNo;
1619 end;
1620 r := Copy(r,0, PIndex(List[i]).FIndexFrom - 1) +
1621 Format('<a href="../test/read.cgi?%s=%s&%s=%s&%s=%s&%s=%s&%s=%s" target="_blank">',
1622 [ParamBBS, Bbs, ParamKey, Key, ParamStart, st, ParamTo, et, ParamNoFirst, ParamTrue]) +
1623 Copy(r,PIndex(List[i]).FIndexFrom, PIndex(List[i]).FIndexTo - PIndex(List[i]).FIndexFrom) + '</A>' +
1624 Copy(r,PIndex(List[i]).FIndexTo,Length(r));
1625 Dispose(PIndex(List[i]));
1626 end;
1627 List.Free;
1628 Result := r;
1629 end;
1630
1631 (*************************************************************************
1632 * ???????茹?
1633 * from HotZonu
1634 *************************************************************************)
1635 function TGikoSys.ZenToHan(const s: string): string;
1636 var
1637 Chr: array [0..255] of char;
1638 begin
1639 Windows.LCMapString(
1640 GetUserDefaultLCID(),
1641 // LCMAP_HALFWIDTH,
1642 LCMAP_HALFWIDTH or LCMAP_KATAKANA or LCMAP_LOWERCASE,
1643 PChar(s),
1644 Length(s) + 1,
1645 chr,
1646 Sizeof(chr)
1647 );
1648 Result := Chr;
1649 end;
1650
1651 (*************************************************************************
1652 * ?????茹??蚊?????????????????阪?ャ??????????Pos
1653 *************************************************************************)
1654 function TGikoSys.VaguePos(const Substr, S: string): Integer;
1655 begin
1656 Result := Pos(ZenToHan(Substr), ZenToHan(S));
1657 end;
1658
1659 function TGikoSys.BoolToInt(b: Boolean): Integer;
1660 begin
1661 Result := IfThen(b, 1, 0);
1662 end;
1663
1664 function TGikoSys.IntToBool(i: Integer): Boolean;
1665 begin
1666 Result := i = 1;
1667 end;
1668
1669 //gzip?у?х軒???????????祉??
1670 function TGikoSys.GzipDecompress(ResStream: TStream; ContentEncoding: string): string;
1671 const
1672 BUF_SIZE = 4096;
1673 var
1674 GZipStream: TGzipDecompressStream;
1675 TextStream: TStringStream;
1676 buf: array[0..BUF_SIZE - 1] of Byte;
1677 cnt: Integer;
1678 s: string;
1679 i: Integer;
1680 begin
1681 Result := '';
1682 TextStream := TStringStream.Create('');
1683 try
1684 //???若???潟???潟?????c????003絲丞?(x-gzip???????????帥????)
1685 // if LowerCase(Trim(ContentEncoding)) = 'gzip' then begin
1686 if AnsiPos('gzip', LowerCase(Trim(ContentEncoding))) > 0 then begin
1687 ResStream.Position := 0;
1688 GZipStream := TGzipDecompressStream.Create(TextStream);
1689 try
1690 repeat
1691 FillChar(buf, BUF_SIZE, 0);
1692 cnt := ResStream.Read(buf, BUF_SIZE);
1693 if cnt > 0 then
1694 GZipStream.Write(buf, BUF_SIZE);
1695 until cnt = 0;
1696 finally
1697 GZipStream.Free;
1698 end;
1699 end else begin
1700 ResStream.Position := 0;
1701 repeat
1702 FillChar(buf, BUF_SIZE, 0);
1703 cnt := ResStream.Read(buf, BUF_SIZE);
1704 if cnt > 0 then
1705 TextStream.Write(buf, BUF_SIZE);
1706 until cnt = 0;
1707 end;
1708
1709 //NULL??絖???"*"??????
1710 s := TextStream.DataString;
1711 i := Length(s);
1712 while (i > 0) and (s[i] = #0) do
1713 Dec(i);
1714 s := Copy(s, 1, i);
1715
1716 i := Pos(#0, s);
1717 while i <> 0 do begin
1718 s[i] := '*';
1719 i := Pos(#0, s);
1720 end;
1721 Result := s;
1722 finally
1723 TextStream.Free;
1724 end;
1725 end;
1726
1727 procedure TGikoSys.LoadKeySetting(ActionList: TActionList);
1728 const
1729 STD_SEC = 'KeySetting';
1730 var
1731 i: Integer;
1732 ini: TMemIniFile;
1733 ActionName: string;
1734 ActionKey: Integer;
1735 SecList: TStringList;
1736 Component: TComponent;
1737 begin
1738 if not FileExists(GetConfigDir + KEY_SETTING_FILE_NAME) then
1739 Exit;
1740 SecList := TStringList.Create;
1741 ini := TMemIniFile.Create(GetConfigDir + KEY_SETTING_FILE_NAME);
1742 try
1743 ini.ReadSection(STD_SEC, SecList);
1744 for i := 0 to SecList.Count - 1 do begin
1745 ActionName := SecList[i];
1746 ActionKey := ini.ReadInteger(STD_SEC, ActionName, -1);
1747 if ActionKey <> -1 then begin
1748 Component := ActionList.Owner.FindComponent(ActionName);
1749 if TObject(Component) is TAction then begin
1750 TAction(Component).ShortCut := ActionKey;
1751 end;
1752 end;
1753 end;
1754 finally
1755 ini.Free;
1756 SecList.Free;
1757 end;
1758 end;
1759
1760 procedure TGikoSys.SaveKeySetting(ActionList: TActionList);
1761 const
1762 STD_SEC = 'KeySetting';
1763 var
1764 i: Integer;
1765 ini: TMemIniFile;
1766 begin
1767 ini := TMemIniFile.Create(GetConfigDir + KEY_SETTING_FILE_NAME);
1768 try
1769 for i := 0 to ActionList.ActionCount - 1 do begin
1770 if ActionList.Actions[i].Tag = -1 then
1771 Continue;
1772 ini.WriteInteger(STD_SEC, ActionList.Actions[i].Name, TAction(ActionList.Actions[i]).ShortCut);
1773 end;
1774 ini.UpdateFile;
1775 finally
1776 ini.Free;
1777 end;
1778 end;
1779
1780 //
1781 procedure TGikoSys.CreateProcess(const AppPath: string; const Param: string);
1782 var
1783 PI: TProcessInformation;
1784 SI: TStartupInfo;
1785 Path: string;
1786 begin
1787 Path := '"' + AppPath + '"';
1788 if Param <> '' then
1789 Path := Path + ' ' + Param;
1790
1791 SI.Cb := SizeOf(Si);
1792 SI.lpReserved := nil;
1793 SI.lpDesktop := nil;
1794 SI.lpTitle := nil;
1795 SI.dwFlags := 0;
1796 SI.cbReserved2 := 0;
1797 SI.lpReserved2 := nil;
1798 SI.dwysize := 0;
1799 Windows.CreateProcess(nil,
1800 PChar(Path),
1801 nil,
1802 nil,
1803 False,
1804 0,
1805 nil,
1806 nil,
1807 SI,
1808 PI);
1809 end;
1810
1811 procedure TGikoSys.OpenBrowser(URL: string; BrowserType: TGikoBrowserType);
1812 begin
1813 case BrowserType of
1814 gbtIE:
1815 HlinkNavigateString(nil, PWideChar(WideString(URL)));
1816 gbtUserApp, gbtAuto:
1817 if (Setting.URLApp) and (FileExists(Setting.URLAppFile)) then
1818 GikoSys.CreateProcess(Setting.URLAppFile, URL)
1819 else
1820 HlinkNavigateString(nil, PWideChar(WideString(URL)));
1821 end;
1822 end;
1823
1824 function TGikoSys.HTMLDecode(const AStr: String): String;
1825 var
1826 Sp, Rp, Cp, Tp: PChar;
1827 S: String;
1828 I, Code: Integer;
1829 Num: Boolean;
1830 begin
1831 SetLength(Result, Length(AStr));
1832 Sp := PChar(AStr);
1833 Rp := PChar(Result);
1834 Cp := Sp;
1835 try
1836 while Sp^ <> #0 do begin
1837 case Sp^ of
1838 '&': begin
1839 Cp := Sp;
1840 Inc(Sp);
1841 case Sp^ of
1842 'a': if AnsiStrPos(Sp, 'amp;') = Sp then
1843 begin
1844 Inc(Sp, 3);
1845 Rp^ := '&';
1846 end;
1847 'l',
1848 'g': if (AnsiStrPos(Sp, 'lt;') = Sp) or (AnsiStrPos(Sp, 'gt;') = Sp) then
1849 begin
1850 Cp := Sp;
1851 Inc(Sp, 2);
1852 while (Sp^ <> ';') and (Sp^ <> #0) do
1853 Inc(Sp);
1854 if Cp^ = 'l' then
1855 Rp^ := '<'
1856 else
1857 Rp^ := '>';
1858 end;
1859 'q': if AnsiStrPos(Sp, 'quot;') = Sp then
1860 begin
1861 Inc(Sp,4);
1862 Rp^ := '"';
1863 end;
1864 '#': begin
1865 Tp := Sp;
1866 Inc(Tp);
1867 Num := IsNumeric(Copy(Tp, 1, 1));
1868 while (Sp^ <> ';') and (Sp^ <> #0) do begin
1869 if (Num) and (not IsNumeric(Copy(Sp, 1, 1))) then
1870 Break;
1871 Inc(Sp);
1872 end;
1873 SetString(S, Tp, Sp - Tp);
1874 Val(S, I, Code);
1875 Rp^ := Chr((I));
1876 end;
1877 // else
1878 //raise EConvertError.CreateFmt(sInvalidHTMLEncodedChar,
1879 //[Cp^ + Sp^, Cp - PChar(AStr)])
1880 end;
1881 end
1882 else
1883 Rp^ := Sp^;
1884 end;
1885 Inc(Rp);
1886 Inc(Sp);
1887 end;
1888 except
1889 // on E:EConvertError do
1890 // raise EConvertError.CreateFmt(sInvalidHTMLEncodedChar,
1891 // [Cp^ + Sp^, Cp - PChar(AStr)])
1892 end;
1893 SetLength(Result, Rp - PChar(Result));
1894 end;
1895
1896 function TGikoSys.GetHRefText(s: string): string;
1897 var
1898 Index: Integer;
1899 Index2: Integer;
1900 begin
1901 Result := '';
1902 s := Trim(s);
1903 if s = '' then
1904 Exit;
1905
1906 Index := AnsiPos('href', LowerCase(s));
1907 if Index = 0 then
1908 Exit;
1909 s := Trim(Copy(s, Index + 4, Length(s)));
1910 s := Trim(Copy(s, 2, Length(s)));
1911
1912 //紮???????絖???'"'?????????ゃ??span>
1913 if Copy(s, 1, 1) = '"' then begin
1914 s := Trim(Copy(s, 2, Length(s)));
1915 end;
1916
1917 Index := AnsiPos('"', s);
1918 if Index <> 0 then begin
1919 //'"'?障??RL??????
1920 s := Copy(s, 1, Index - 1);
1921 end else begin
1922 //'"'???<?????違?鴻???若?鴻??">"???????鴻?障?с??URL??????
1923 Index := AnsiPos(' ', s);
1924 Index2 := AnsiPos('>', s);
1925 if Index = 0 then
1926 Index := Index2;
1927 if Index > Index2 then
1928 Index := Index2;
1929 if Index <> 0 then
1930 s := Copy(s, 1, Index - 1)
1931 else
1932 //????篁ヤ??????ャ??????/span>
1933 ;
1934 end;
1935 Result := Trim(s);
1936 end;
1937
1938 //???鴻??????鐚?鐔?鐔????????????с????????
1939 function TGikoSys.Is2chHost(Host: string): Boolean;
1940 const
1941 HOST_NAME: array[0..1] of string = ('2ch.net', 'bbspink.com');
1942 var
1943 i: Integer;
1944 Len: Integer;
1945 begin
1946 Result := False;
1947 OutputDebugString(pchar(HOST_NAME[0]));
1948 for i := 0 to Length(HOST_NAME) - 1 do begin
1949 Len := Length(HOST_NAME[i]);
1950 if AnsiPos(HOST_NAME[i], Host) = (Length(Host) - Length(HOST_NAME[i]) + 1) then begin
1951 Result := True;
1952 Exit;
1953 end;
1954 end;
1955 end;
1956
1957 function TGikoSys.Parse2chURL(const url: string; const path: string; const document: string; var BBSID: string; var BBSKey: string): Boolean;
1958 const
1959 READ_PATH: string = '/test/read.cgi/';
1960 OLD_READ_PATH: string = '/test/read.cgi?';
1961 KAKO_PATH: string = '/kako/';
1962 var
1963 Index: Integer;
1964 s: string;
1965 SList: TStringList;
1966 begin
1967 BBSID := '';
1968 BBSKey := '';
1969 Result := False;
1970
1971 Index := AnsiPos(READ_PATH, path);
1972 if Index <> 0 then begin
1973 s := Copy(path, Length(READ_PATH) + 1, Length(path));
1974 BBSID := GetTokenIndex(s, '/', 0);
1975 BBSKey := GetTokenIndex(s, '/', 1);
1976 if BBSKey = '' then
1977 BBSKey := Document;
1978 Result := (BBSID <> '') or (BBSKey <> '');
1979 Exit;
1980 end;
1981 Index := AnsiPos(KAKO_PATH, path);
1982 if Index <> 0 then begin
1983 s := Copy(path, 2, Length(path));
1984 BBSID := GetTokenIndex(s, '/', 0);
1985 if (BBSID = 'log') and (GetTokenIndex(s, '/', 2) = 'kako') then
1986 BBSID := GetTokenIndex(s, '/', 1);
1987 BBSKey := ChangeFileExt(Document, '');
1988 Result := (BBSID <> '') or (BBSKey <> '');
1989 Exit;
1990 end;
1991 Index := AnsiPos('read.cgi?', URL);
1992 if Index <> 0 then begin
1993 SList := TStringList.Create;
1994 try
1995 try
1996 // s := HTMLDecode(Document);
1997 ExtractHTTPFields(['?', '&'], [], PChar(URL), SList, False);
1998 BBSID := SList.Values['bbs'];
1999 BBSKey := SList.Values['key'];
2000 Result := (BBSID <> '') or (BBSKey <> '');
2001 Exit;
2002 except
2003 Exit;
2004 end;
2005 finally
2006 SList.Free;
2007 end;
2008 end;
2009 end;
2010
2011 function TGikoSys.Parse2chURL2(URL: string): TPathRec;
2012 var
2013 i: Integer;
2014 s: string;
2015 wk: string;
2016 wkMin: Integer;
2017 wkMax: Integer;
2018 wkInt: Integer;
2019 RStart: Integer;
2020 RLength: Integer;
2021 SList: TStringList;
2022 begin
2023 URL := Trim(LowerCase(URL));
2024 Result.FBBS := '';
2025 Result.FKey := '';
2026 Result.FSt := 0;
2027 Result.FTo := 0;
2028 Result.FFirst := False;
2029 Result.FStBegin := False;
2030 Result.FToEnd := False;
2031 Result.FDone := False;
2032
2033 wkMin := 0;
2034 wkMax := 1;
2035
2036 FAWKStr.RegExp := 'http://.+\.(2ch\.net|bbspink\.com)/';
2037 if FAWKStr.Match(FAWKStr.ProcessEscSeq(URL), RStart, RLength) = 0 then
2038 Exit;
2039 s := Copy(URL, RStart + RLength - 1, Length(URL));
2040
2041 //罔?羣??後?
2042 //??緇???50, 10, 10-20, 10n, 10-20n, -10, 10-, 10n- ????/span>
2043 //http://xxx.2ch.net/test/read.cgi/bbsid/1000000000/
2044 FAWKStr.RegExp := '/test/read.cgi/.+/[0-9]+/.*';
2045 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2046 s := Copy(s, 15, Length(s));
2047
2048 SList := TStringList.Create;
2049 try
2050 SList.Clear;
2051 FAWKStr.RegExp := '/';
2052 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 2 then begin
2053 Result.FBBS := SList[1];
2054 Result.FKey := SList[2];
2055 if SList.Count >= 3 then
2056 s := SList[3]
2057 else
2058 s := '';
2059 end else
2060 Exit;
2061
2062 SList.Clear;
2063 FAWKStr.LineSeparator := mcls_CRLF;
2064 FAWKStr.RegExp := '-';
2065 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) = 0 then begin
2066 Result.FFirst := True;
2067 end else begin
2068 FAWKStr.RegExp := 'l[0-9]+';
2069 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2070 Result.FFirst := True;
2071 end else begin
2072 for i := 0 to SList.Count - 1 do begin
2073 if Trim(SList[i]) = '' then begin
2074 if i = 0 then
2075 Result.FStBegin := True;
2076 if i = (SList.Count - 1) then
2077 Result.FToEnd := True;
2078 end else if IsNumeric(SList[i]) then begin
2079 wkInt := StrToInt(SList[i]);
2080 wkMax := Max(wkMax, wkInt);
2081 if wkMin = 0 then
2082 wkMin := wkInt
2083 else
2084 wkMin := Min(wkMin, wkInt);
2085 end else if Trim(SList[i]) = 'n' then begin
2086 Result.FFirst := True;
2087 end else begin
2088 FAWKStr.RegExp := '^n[0-9]+$|^[0-9]+n$';
2089 if FAWKStr.Match(FAWKStr.ProcessEscSeq(SList[i]), RStart, RLength) > 0 then begin
2090 if Copy(SList[i], 1, 1) = 'n' then
2091 wkInt := StrToInt(Copy(SList[i], 2, Length(SList[i])))
2092 else
2093 wkInt := StrToInt(Copy(SList[i], 1, Length(SList[i]) - 1));
2094 Result.FFirst := True;
2095 wkMax := Max(wkMax, wkInt);
2096 if wkMin = 1 then
2097 wkMin := wkInt
2098 else
2099 wkMin := Min(wkMin, wkInt);
2100 end;
2101 end;
2102 end;
2103 if Result.FStBegin and (not Result.FToEnd) then
2104 Result.FSt := wkMin
2105 else if (not Result.FStBegin) and Result.FToEnd then
2106 Result.FTo := wkMax
2107 else if (not Result.FStBegin) and (not Result.FToEnd) then begin
2108 Result.FSt := wkMin;
2109 Result.FTo := wkMax;
2110 end;
2111 //Result.FSt := wkMin;
2112 //Result.FTo := wkMax;
2113 end;
2114 end;
2115 finally
2116 SList.Free;
2117 end;
2118 Result.FDone := True;
2119 Exit;
2120 end;
2121
2122 //??ako?後?
2123 //http://server.2ch.net/ITA_NAME/kako/1000/10000/1000000000.html
2124 FAWKStr.RegExp := '/.+/kako/[0-9]+/[0-9]+/[0-9]+\.html';
2125 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2126 SList := TStringList.Create;
2127 try
2128 SList.Clear;
2129 FAWKStr.RegExp := '/';
2130 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 6 then begin
2131 Result.FBBS := SList[1];
2132 Result.FKey := ChangeFileExt(SList[5], '');
2133 Result.FFirst := True;
2134 end else
2135 Exit;
2136 finally
2137 SList.Free;
2138 end;
2139 Result.FDone := True;
2140 Exit;
2141 end;
2142
2143 //??ako?後?
2144 //http://server.2ch.net/ITA_NAME/kako/999/999999999.html
2145 FAWKStr.RegExp := '/.+/kako/[0-9]+/[0-9]+\.html';
2146 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2147 SList := TStringList.Create;
2148 try
2149 SList.Clear;
2150 FAWKStr.RegExp := '/';
2151 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 5 then begin
2152 Result.FBBS := SList[1];
2153 Result.FKey := ChangeFileExt(SList[4], '');
2154 Result.FFirst := True;
2155 end else
2156 Exit;
2157 finally
2158 SList.Free;
2159 end;
2160 Result.FDone := True;
2161 Exit;
2162 end;
2163
2164 //log????og2?後?
2165 //http://server.2ch.net/log/ITA_NAME/kako/999/999999999.html
2166 //http://server.2ch.net/log2/ITA_NAME/kako/999/999999999.html
2167 FAWKStr.RegExp := '/log2?/.+/kako/[0-9]+/[0-9]+\.html';
2168 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2169 SList := TStringList.Create;
2170 try
2171 SList.Clear;
2172 FAWKStr.RegExp := '/';
2173 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 6 then begin
2174 Result.FBBS := SList[2];
2175 Result.FKey := ChangeFileExt(SList[5], '');
2176 Result.FFirst := True;
2177 end else
2178 Exit;
2179 finally
2180 SList.Free;
2181 end;
2182 Result.FDone := True;
2183 Exit;
2184 end;
2185
2186
2187 //??RL?後?
2188 //http://server.2ch.net/test/read.cgi?bbs=ITA_NAME&key=1000000000&st=1&to=5&nofirst=true
2189 FAWKStr.RegExp := '/test/read\.cgi\?';
2190 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2191 s := Copy(s, 16, Length(s));
2192 SList := TStringList.Create;
2193 try
2194 SList.Clear;
2195 FAWKStr.RegExp := '&';
2196 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 2 then begin
2197 Result.FFirst := True;
2198 for i := 0 to SList.Count - 1 do begin
2199 if Pos('bbs=', SList[i]) = 1 then begin
2200 Result.FBBS := Copy(SList[i], 5, Length(SList[i]));
2201 end else if Pos('key=', SList[i]) = 1 then begin
2202 Result.FKey := Copy(SList[i], 5, Length(SList[i]));
2203 end else if Pos('st=', SList[i]) = 1 then begin
2204 wk := Copy(SList[i], 4, Length(SList[i]));
2205 if IsNumeric(wk) then
2206 Result.FSt := StrToInt(wk)
2207 else if wk = '' then
2208 Result.FStBegin := True;
2209 end else if Pos('to=', SList[i]) = 1 then begin
2210 wk := Copy(SList[i], 4, Length(SList[i]));
2211 if IsNumeric(wk) then
2212 Result.FTo := StrToInt(wk)
2213 else if wk = '' then
2214 Result.FToEnd := True;
2215 end else if Pos('nofirst=', SList[i]) = 1 then begin
2216 Result.FFirst := False;
2217 end;
2218 end;
2219 end else
2220 Exit;
2221 finally
2222 SList.Free;
2223 end;
2224
2225 if (Result.FBBS <> '') and (Result.FKey <> '') then begin
2226 Result.FDone := True;
2227 end;
2228 Exit;
2229 end;
2230 end;
2231
2232 procedure TGikoSys.ParseURI(var URL, Protocol, Host, Path, Document, Port, Bookmark: string);
2233 var
2234 URI: TIdURI;
2235 begin
2236 Protocol := '';
2237 Host := '';
2238 Path := '';
2239 Document := '';
2240 Port := '';
2241 Bookmark := '';
2242 URI := TIdURI.Create(URL);
2243 try
2244 Protocol := URI.Protocol;
2245 Host := URI.Host;
2246 Path := URI.Path;
2247 Document := URI.Document;
2248 Port := URI.Port;
2249 Bookmark := URI.Bookmark;
2250 finally
2251 URI.Free;
2252 end;
2253 end;
2254
2255 function TGikoSys.GetVersionBuild: Integer;
2256 var
2257 FixedFileInfo: PVSFixedFileInfo;
2258 VersionHandle, VersionSize: DWORD;
2259 pVersionInfo: Pointer;
2260 ItemLen : UInt;
2261 AppFile: string;
2262 begin
2263 Result := 0;
2264 AppFile := Application.ExeName;
2265 VersionSize := GetFileVersionInfoSize(pChar(AppFile), VersionHandle);
2266 if VersionSize = 0 then
2267 Exit;
2268 GetMem(pVersionInfo, VersionSize);
2269 try
2270 if GetFileVersionInfo(PChar(AppFile),VersionHandle,VersionSize, pVersionInfo) then
2271 if VerQueryValue(pVersionInfo, '\', Pointer(FixedFileInfo), ItemLen) then
2272 Result := LOWORD(FixedFileInfo^.dwFileVersionLS);
2273 finally
2274 FreeMem(pVersionInfo, VersionSize);
2275 end;
2276 end;
2277
2278 initialization
2279 GikoSys := TGikoSys.Create;
2280
2281 finalization
2282 if GikoSys <> nil then begin
2283 GikoSys.Free;
2284 GikoSys := nil;
2285 end;
2286 end.

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