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.19 - (show annotations) (download) (as text)
Thu Sep 4 08:22:07 2003 UTC (20 years, 7 months ago) by h677
Branch: MAIN
Changes since 1.18: +13 -9 lines
File MIME type: text/x-pascal
コンパイル時に[警告][ヒント]がなるべく出ないように修正。

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 = 36;
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 if DirectoryExists(GetConfigDir) = false then begin
219 CreateDir(GetConfigDir);
220 end;
221 FAbon := TAbon.Create;
222 FAbon.Setroot(GetConfigDir+NGWORDs_DIR_NAME);
223 //FAbon.SetNGwordpath(DEFAULT_NGWORD_FILE_NAME);
224 FAbon.GoHome;
225 FSelectResFilter := TAbon.Create;
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.IndividualAbon(ReadList, ChangeFileExt(FileName,'.NG'));
793 FAbon.Execute(ReadList); // ???若????????/span>
794 FSelectResFilter.Execute(ReadList); //???鴻?????c???帥???潟?違??????
795 Res := DivideStrLine(ReadList[0]);
796 Res.FTitle := StringReplace(Res.FTitle, '鐚?鐔?', ',', [rfReplaceAll]);
797 sTitle := Res.FTitle;
798
799 end else begin
800 sTitle := StringReplace(ThreadItem.Title, '鐚?鐔?', ',', [rfReplaceAll]);
801 end;
802 SaveList := TStringList.Create;
803 try
804 doc.open;
805 doc.charset := 'Shift_JIS';
806
807 CSSFileName := GetStyleSheetDir + Setting.CSSFileName;
808 if GikoSys.Setting.UseCSS and FileExists(CSSFileName) then begin
809 //CSS篏睡??/span>
810 //CSSFileName := GetAppDir + CSS_FILE_NAME;
811 // SaveList.Add('<html lang="ja"><head>');
812 SaveList.Add('<html><head>');
813 SaveList.Add('<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">');
814 SaveList.Add('<title>' + sTitle + '</title>');
815 SaveList.Add('<style type="text/css">');
816 SaveList.Add('@import url(' + CSSFileName + ');');
817 SaveList.Add('</style>');
818 SaveList.Add('</head>');
819 SaveList.Add('<body>');
820 SaveList.Add('<a name="top"></a>');
821 SaveList.Add('<div class="title">' + sTitle + '</div>');
822 //doc.Write(SaveList.Text);
823 //SaveList.Clear;
824 //Application.ProcessMessages;
825 for i := 0 to ReadList.Count - 1 do begin
826 if (Trim(ReadList[i]) <> '') then begin
827 No := IntToStr(i + 1);
828 if (NewReceiveNo = (i + 1)) or ((NewReceiveNo = 0) and (i = 0)) then begin
829 SaveList.Add('<a name="new"></a><div class="new">?亥????? <span class="newdate">' + FormatDateTime('yyyy/mm/dd(ddd) hh:mm', ThreadItem.RoundDate) + '</span></div>');
830 end;
831 Res := DivideStrLine(ReadList[i]);
832 Res.FBody := ConvRes(Res.FBody, ThreadItem.ParentBoard.BBSID, ChangeFileExt(ThreadItem.FileName, ''), 'bbs', 'key', 'st', 'to', 'nofirst', 'true');
833
834 if Res.FType = glt2chOld then begin
835 Res.FMailTo := StringReplace(Res.FMailTo, '鐚?鐔?', ',', [rfReplaceAll]);
836 Res.FName := StringReplace(Res.FName, '鐚?鐔?', ',', [rfReplaceAll]);
837 Res.FBody := StringReplace(Res.FBody, '鐚?鐔?', ',', [rfReplaceAll]);
838 end;
839 //Res.FBody := StringReplace(Res.FBody, '&amphearts;', '&hearts;', [rfReplaceAll]);
840 //Res.FBody := StringReplace(Res.FBody, '&ampnbsp;', '&nbsp;', [rfReplaceAll]);
841 //Res.FBody := StringReplace(Res.FBody, '&amp#', '&#', [rfReplaceAll]);
842 //Res.FBody := StringReplace(Res.FBody, '&amp', '&amp;', [rfReplaceAll]);
843 Res.FBody := AddAnchorTag(Res.FBody);
844 if Res.FName = '' then
845 Res.FName := '&nbsp;';
846 if Res.FMailTo = '' then
847 SaveList.Add('<a name="' + No + '"></a>'
848 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span> '
849 + '<span class="name_label">????鐚?</span> '
850 + '<span class="name"><b>' + Res.FName + '</b></span> '
851 + '<span class="date_label">??腮炊?ワ?</span> '
852 + '<span class="date">' + Res.FDateTime+ '</span></div>'
853 + '<div class="mes">' + Res.FBody + ' </div>')
854 else
855 if GikoSys.Setting.ShowMail then
856 SaveList.Add('<a name="' + No + '"></a>'
857 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span>'
858 + '<span class="name_label"> ????鐚? </span>'
859 + '<a class="name_mail" href="mailto:' + Res.FMailTo + '">'
860 + '<b>' + Res.FName + '</a></b><span class="mail"> [' + Res.FMailTo + ']</span>'
861 + '<span class="date_label"> ??腮炊?ワ?</span>'
862 + '<span class="date"> ' + Res.FDateTime+ '</span></div>'
863 + '<div class="mes">' + Res.FBody + ' </div>')
864 else
865 SaveList.Add('<a name="' + No + '"></a>'
866 + '<div class="header"><span class="no"><a href="giko://?no=' + No + '">' + No + '</a></span>'
867 + '<span class="name_label"> ????鐚? </span>'
868 + '<a class="name_mail" href="mailto:' + Res.FMailTo + '">'
869 + '<b>' + Res.FName + '</a></b>'
870 + '<span class="date_label"> ??腮炊?ワ?</span>'
871 + '<span class="date"> ' + Res.FDateTime+ '</span></div>'
872 + '<div class="mes">' + Res.FBody + ' </div>');
873 if ThreadItem.Kokomade = (i + 1) then begin
874 SaveList.Add('<a name="koko"></a><div class="koko">?潟?潟?障?ц?????</div>');
875 end;
876 end;
877 //if SaveList.Count > 50 then begin
878 if i = 20 then begin
879 //Sleep(1);
880 //Application.ProcessMessages;
881
882 doc.Write(SaveList.Text);
883 //while GikoForm.Browser.Busy do begin
884 // Sleep(1);
885 // Application.ProcessMessages;
886 //end;
887 while (GikoForm.Browser.ReadyState <> READYSTATE_COMPLETE) and
888 (GikoForm.Browser.ReadyState <> READYSTATE_INTERACTIVE) do begin
889 //Sleep(1);
890 //Application.ProcessMessages;
891 end;
892 SaveList.Clear;
893 end;
894 end;
895 SaveList.Add('<a name="bottom"></a>');
896 SaveList.Add('</body></html>');
897 SaveList.Add('</dl>');
898 SaveList.Add('<a name="last"></a>');
899 SaveList.Add('</body></html>');
900 doc.Write(SaveList.Text);
901 end else begin
902 //CSS??篏睡??/span>
903 // SaveList.Add('<html lang="ja"><head>');
904 SaveList.Add('<html><head>');
905 SaveList.Add('<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">');
906 SaveList.Add('<title>' + sTitle + '</title></head>');
907 SaveList.Add('<body TEXT="#000000" BGCOLOR="#EFEFEF" link="#0000FF" alink="#FF0000" vlink="#660099">');
908 SaveList.Add('<a name="top"></a>');
909 SaveList.Add('<font size=+1 color="#FF0000">' + sTitle + '</font>');
910 SaveList.Add('<dl>');
911 doc.Write(SaveList.Text);
912 SaveList.Clear;
913 //Application.ProcessMessages;
914 for i := 0 to ReadList.Count - 1 do begin
915 if (Trim(ReadList[i]) <> '') then begin
916 No := IntToStr(i + 1);
917
918 if (NewReceiveNo = (i + 1)) or ((NewReceiveNo = 0) and (i = 0)) then begin
919 SaveList.Add('</dl>');
920 SaveList.Add('<a name="new"></a>');
921 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>');
922 SaveList.Add('<dl>');
923 end;
924 Res := DivideStrLine(ReadList[i]);
925 Res.FBody := ConvRes(Res.FBody, ThreadItem.ParentBoard.BBSID, ChangeFileExt(ThreadItem.FileName, ''), 'bbs', 'key', 'st', 'to', 'nofirst', 'true');
926 if Res.FType = glt2chOld then begin
927 Res.FMailTo := StringReplace(Res.FMailTo, '鐚?鐔?', ',', [rfReplaceAll]);
928 Res.FName := StringReplace(Res.FName, '鐚?鐔?', ',', [rfReplaceAll]);
929 Res.FBody := StringReplace(Res.FBody, '鐚?鐔?', ',', [rfReplaceAll]);
930 end;
931 //Res.FBody := StringReplace(Res.FBody, '&amphearts;', '&hearts;', [rfReplaceAll]);
932 //Res.FBody := StringReplace(Res.FBody, '&ampnbsp;', '&nbsp;', [rfReplaceAll]);
933 //Res.FBody := StringReplace(Res.FBody, '&amp#', '&#', [rfReplaceAll]);
934 //Res.FBody := StringReplace(Res.FBody, '&amp', '&amp;', [rfReplaceAll]);
935 Res.FBody := AddAnchorTag(Res.FBody);
936 if Res.FMailTo = '' then
937 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>')
938 else
939 if GikoSys.Setting.ShowMail then
940 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>')
941 else
942 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>');
943 if ThreadItem.Kokomade = (i + 1) then begin
944 SaveList.Add('</dl>');
945 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>');
946 SaveList.Add('<dl>');
947 end;
948 end;
949 if SaveList.Count > 50 then begin
950 doc.Write(SaveList.Text);
951 SaveList.Clear;
952 //Application.ProcessMessages;
953 end;
954 end;
955 SaveList.Add('</dl>');
956 SaveList.Add('<a name="bottom"></a>');
957 SaveList.Add('</body></html>');
958 doc.Write(SaveList.Text);
959 end;
960 finally
961 SaveList.Free;
962 doc.Close;
963 end;
964 finally
965 ReadList.Free;
966 end;
967 end;
968
969 (*************************************************************************
970 *http://????絖?????anchor?帥?遺???????????
971 *************************************************************************)
972 function TGikoSys.AddAnchorTag(s: string): string;
973 const
974 URL_CHAR: string = '0123456789'
975 + 'abcdefghijklmnopqrstuvwxyz'
976 + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
977 + '#$%&()*+,-./:;=?@[]^_`{|}~!''\';
978 var
979 wkIdx: array[0..9] of Integer;
980 url: string;
981 href: string;
982 i: Integer;
983 idx: Integer;
984 begin
985 Result := '';
986
987 while True do begin
988 wkIdx[0] := AnsiPos('http://', s);
989 wkIdx[1] := AnsiPos('ttp://', s);
990 wkIdx[2] := AnsiPos('tp://', s);
991 wkIdx[3] := AnsiPos('ms-help://', s);
992 wkIdx[4] := AnsiPos('p://', s);
993 wkIdx[5] := AnsiPos('https://', s);
994 wkIdx[6] := AnsiPos('www.', s);
995 wkIdx[7] := AnsiPos('ftp://', s);
996 wkIdx[8] := AnsiPos('news://', s);
997 wkIdx[9] := AnsiPos('rtsp://', s);
998
999 idx := MaxInt;
1000 for i := 0 to 8 do
1001 if wkIdx[i] <> 0 then idx := Min(wkIdx[i], idx);
1002
1003 if idx = MaxInt then begin
1004 //???潟?????<??????
1005 Result := Result + s;
1006 Break;
1007 end;
1008
1009 if (idx > 1) and (Copy(s, idx - 1, 1) = '"') then begin
1010 //?≪?????潟???帥?違???ゃ?????????c?純????????????/span>
1011 Result := Result + Copy(s, 0, idx + Length('http://') - 1);
1012 s := Copy(s, idx + Length('http://'), length(s));
1013 Continue;
1014 end;
1015
1016 Result := Result + Copy(s, 0, idx - 1);
1017
1018 s := Copy(s, idx, length(s));
1019
1020 for i := 0 to Length(s) do begin
1021 idx := AnsiPos(s[i + 1], URL_CHAR);
1022 if (idx = 0) or (i = (Length(s))) then begin
1023 //URL??????????絖??肴?鐚?????????絖?????????c????
1024 url := Copy(s, 0, i);
1025
1026 if AnsiPos('ttp://', url) = 1 then
1027 href := 'h' + url
1028 else if AnsiPos('tp://', url) = 1 then
1029 href := 'ht' + url
1030 else if AnsiPos('p://', url) = 1 then
1031 href := 'htt' + url
1032 else if AnsiPos('www.', url) = 1 then
1033 href := 'http://' + url
1034 else
1035 href := url;
1036 Result := Result + '<a href="' + href + '" target="_blank">' + url + '</a>';
1037 s := Copy(s, i + 1, Length(s));
1038 Break;
1039 end;
1040 end;
1041 end;
1042 end;
1043
1044 (*************************************************************************
1045 *?泣???吾?с????筝?茵???????/span>
1046 *************************************************************************)
1047 function TGikoSys.DivideSubject(Line: string): TSubjectRec;
1048 var
1049 i: integer;
1050 ws: WideString;
1051 Delim: string;
1052 LeftK: string;
1053 RightK: string;
1054 begin
1055 Result.FCount := 0;
1056
1057 if Pos('<>', Line) = 0 then
1058 Delim := ','
1059 else
1060 Delim := '<>';
1061
1062 Result.FFileName := GetTokenIndex(Line, Delim, 0);
1063 Result.FTitle := GetTokenIndex(Line, Delim, 1);
1064
1065 ws := Trim(Result.FTitle);
1066
1067 if Copy(ws, Length(ws), 1) = ')' then begin
1068 LeftK := '(';
1069 RightK := ')';
1070 end else if Copy(ws, Length(ws), 1) = '鐚?' then begin
1071 LeftK := '鐚?';
1072 RightK := '鐚?';
1073 end else if Copy(ws, Length(ws), 1) = '<' then begin
1074 LeftK := '<';
1075 RightK := '>';
1076 end;
1077
1078 for i := Length(ws) - 1 downto 1 do begin
1079 if ws[i] = LeftK then begin
1080 ws := Copy(ws, i + 1, Length(ws) - i - 1);
1081 if IsNumeric(ws) then
1082 Result.FCount := StrToInt(ws);
1083 Result.FTitle := Trim(StringReplace(Result.FTitle, LeftK + ws + RightK, '', [rfReplaceAll]));
1084 break;
1085 end;
1086 end;
1087 end;
1088
1089 (*************************************************************************
1090 * dat???<?ゃ????????ゃ?潟????茹?/span>
1091 *************************************************************************)
1092 function TGikoSys.DivideStrLine(Line: string): TResRec;
1093 var
1094 Delim: string;
1095 bufbody : String;
1096 begin
1097 if Pos('<>', Line) = 0 then begin
1098 Delim := ',';
1099 Result.FType := glt2chOld;
1100 end else begin
1101 Delim := '<>';
1102 Result.FType := glt2chNew;
1103 end;
1104 Result.FName := Trim(GetTokenIndex(Line, Delim, 0));
1105 Result.FMailTo := Trim(GetTokenIndex(Line, Delim, 1));
1106 Result.FDateTime := Trim(GetTokenIndex(Line, Delim, 2));
1107 bufBody := Trim(GetTokenIndex(Line, Delim, 3));
1108 if bufbody = '' then begin
1109 Insert('&nbsp;',bufbody, 1);
1110 end;
1111 Result.FBody := bufBody;
1112 Result.FTitle := Trim(GetTokenIndex(Line, Delim, 4));
1113
1114 end;
1115
1116 (*************************************************************************
1117 * URL????BBSID????緇?
1118 *************************************************************************)
1119 function TGikoSys.UrlToID(url: string): string;
1120 var
1121 i: integer;
1122 begin
1123 Result := '';
1124 url := Trim(url);
1125
1126 if url = '' then Exit;
1127
1128 url := Copy(url, 0, Length(url) - 1);
1129 for i := Length(url) downto 0 do begin
1130 if url[i] = '/' then begin
1131 Result := Copy(url, i + 1, Length(url));
1132 Break;
1133 end;
1134 end;
1135 end;
1136
1137 (*************************************************************************
1138 *URL????BBSID篁ュ???????(http://teri.2ch.net/)????緇?
1139 *************************************************************************)
1140 function TGikoSys.UrlToServer(url: string): string;
1141 var
1142 i: integer;
1143 wsURL: WideString;
1144 begin
1145 Result := '';
1146 wsURL := url;
1147 wsURL := Trim(wsURL);
1148
1149 if wsURL = '' then exit;
1150
1151 if Copy(wsURL, Length(wsURL), 1) = '/' then
1152 wsURL := Copy(wsURL, 0, Length(wsURL) - 1);
1153
1154 for i := Length(wsURL) downto 0 do begin
1155 if wsURL[i] = '/' then begin
1156 Result := Copy(wsURL, 0, i);
1157 break;
1158 end;
1159 end;
1160 end;
1161
1162 (*************************************************************************
1163 *???c??????????絖????????????с????/span>
1164 *************************************************************************)
1165 function TGikoSys.DirectoryExistsEx(const Name: string): Boolean;
1166 var
1167 Code: Integer;
1168 begin
1169 Code := GetFileAttributes(PChar(Name));
1170 Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
1171 end;
1172
1173 (*************************************************************************
1174 *???c???????????鐚?茲??育??韻絲上?鐚?
1175 *************************************************************************)
1176 function TGikoSys.ForceDirectoriesEx(Dir: string): Boolean;
1177 begin
1178 Result := True;
1179 if Length(Dir) = 0 then
1180 raise Exception.Create('??????????篏????堺?ャ?障????');
1181 Dir := ExcludeTrailingPathDelimiter(Dir);
1182 if (Length(Dir) < 3) or DirectoryExistsEx(Dir)
1183 or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
1184 Result := ForceDirectoriesEx(ExtractFilePath(Dir)) and CreateDir(Dir);
1185 end;
1186
1187 (*************************************************************************
1188 *??絖??????????若???潟???????冴??鐚?????????鐚?
1189 *FDelphi????????????/span>
1190 *************************************************************************)
1191 function TGikoSys.StrTokFirst(const s:string; const sep: TStrTokSeparator; var Rec: TStrTokRec): string;
1192 begin
1193 Rec.Str := s;
1194 Rec.Pos := 1;
1195 Result := StrTokNext(sep, Rec);
1196 end;
1197
1198 (*************************************************************************
1199 *??絖??????????若???潟???????冴??
1200 *FDelphi????????????/span>
1201 *************************************************************************)
1202 function TGikoSys.StrTokNext(const sep: TStrTokSeparator; var Rec: TStrTokRec): string;
1203 var
1204 Len, I: Integer;
1205 begin
1206 with Rec do begin
1207 Len := Length(Str);
1208 Result := '';
1209 if Len >= Pos then begin
1210 while (Pos <= Len) and (Str[Pos] in sep) do begin
1211 Inc(Pos);
1212 end;
1213 I := Pos;
1214 while (Pos<= Len) and not (Str[Pos] in sep) do begin
1215 if IsDBCSLeadByte(Byte(Str[Pos])) then begin
1216 Inc(Pos);
1217 end;
1218 Inc(Pos);
1219 end;
1220 Result := Copy(Str, I, Pos - I);
1221 while (Pos <= Len) and (Str[Pos] in sep) do begin// ????????絅純??/span>
1222 Inc(Pos);
1223 end;
1224 end;
1225 end;
1226 end;
1227
1228 (*************************************************************************
1229 *???<?ゃ???泣?ゃ?阪??
1230 *************************************************************************)
1231 function TGikoSys.GetFileSize(FileName : string): longint;
1232 var
1233 F : File;
1234 begin
1235 try
1236 if not FileExists(FileName) then begin
1237 Result := 0;
1238 Exit;
1239 end;
1240 Assign(F, FileName);
1241 Reset(F, 1);
1242 Result := FileSize(F);
1243 CloseFile(F);
1244 except
1245 Result := 0;
1246 end;
1247 end;
1248
1249 (*************************************************************************
1250 *???<?ゃ????医??
1251 *************************************************************************)
1252 function TGikoSys.GetFileLineCount(FileName : string): longint;
1253 var
1254 sl: TStringList;
1255 begin
1256 sl := TStringList.Create;
1257 try
1258 try
1259 sl.LoadFromFile(FileName);
1260 Result := sl.Count;
1261 except
1262 Result := 0;
1263 end;
1264 finally
1265 sl.Free;
1266 end;
1267
1268 end;
1269
1270 (*************************************************************************
1271 *?鴻?????????<?ゃ????????絎?茵?????緇?
1272 *************************************************************************)
1273 function TGikoSys.ReadThreadFile(FileName: string; Line: Integer): string;
1274 const
1275 BUFFER_SIZE = 1024;
1276 var
1277 f: TextFile;
1278 s: string;
1279 num: Integer;
1280 ArrBuff: array [1..BUFFER_SIZE] of Char;
1281 begin
1282 Result := '';
1283 if FileExists(FileName) then begin
1284 AssignFile(f, FileName);
1285 System.SetTextBuf(f, ArrBuff);
1286 try
1287 Reset(f);
1288 num := 1;
1289 while not Eof(f) do begin
1290 Readln(f, s);
1291 if Line = num then begin
1292 Result := s;
1293 // CloseFile(f);
1294 Break;
1295 end;
1296 inc(num);
1297 end;
1298 finally
1299 CloseFile(f);
1300 end;
1301 end;
1302 end;
1303
1304 (*************************************************************************
1305 *?激?鴻?????<???ャ?若?????潟??????с????緇?
1306 *************************************************************************)
1307 procedure TGikoSys.MenuFont(Font: TFont);
1308 var
1309 lf: LOGFONT;
1310 nm: NONCLIENTMETRICS;
1311 begin
1312 nm.cbSize := sizeof(NONCLIENTMETRICS);
1313
1314 SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @nm, 0);
1315 lf := nm.lfMenuFont;
1316
1317 Font.Name := lf.lfFaceName;
1318 Font.Height := lf.lfHeight;
1319 Font.Style := [];
1320 if lf.lfWeight >= 700 then
1321 Font.Style := Font.Style + [fsBold];
1322 if lf.lfItalic = 1 then
1323 Font.Style := Font.Style + [fsItalic];
1324 end;
1325
1326 (*************************************************************************
1327 *
1328 *?????????泣?ゃ??????????????/span>
1329 *************************************************************************)
1330 function TGikoSys.RemoveToken(var s: string; delimiter: string): string;
1331 var
1332 p: Integer;
1333 begin
1334 p := AnsiPos(delimiter, s);
1335 if p = 0 then
1336 Result := s
1337 else
1338 Result := Copy(s, 1, p - 1);
1339 s := Copy(s, Length(Result) + Length(delimiter) + 1, Length(s));
1340 end;
1341
1342 (*************************************************************************
1343 *
1344 *?????????泣?ゃ??????????????/span>
1345 *************************************************************************)
1346 function TGikoSys.GetTokenIndex(s: string; delimiter: string; index: Integer): string;
1347 var
1348 i: Integer;
1349 begin
1350 Result := '';
1351 for i := 0 to index do
1352 Result := RemoveToken(s, delimiter);
1353 end;
1354
1355 (*************************************************************************
1356 *
1357 *************************************************************************)
1358 function TGikoSys.DeleteLink(const s: string): string;
1359 var
1360 s1: string;
1361 s2: string;
1362 idx: Integer;
1363 i: Integer;
1364 begin
1365 i := 0;
1366 Result := '';
1367 while True do begin
1368 s1 := GetTokenIndex(s, '<a href="', i);
1369 s2 := GetTokenIndex(s, '<a href="', i + 1);
1370
1371 idx := Pos('">', s1);
1372 if idx <> 0 then
1373 Delete(s1, 1, idx + 1);
1374 idx := Pos('">', s2);
1375 if idx <> 0 then
1376 Delete(s2, 1, idx + 1);
1377
1378 Result := Result + s1 + s2;
1379
1380 if s2 = '' then
1381 Break;
1382
1383 inc(i, 2);
1384 end;
1385 end;
1386
1387 //?ゃ?潟???????号???贋?違???????<?????????激?ワ?
1388 {procedure TGikoSys.FlashExitWrite;
1389 var
1390 i: Integer;
1391 begin
1392 //?鴻?????????若?帥???<?ゃ?????贋??/span>
1393 for i := 0 to FExitWrite.Count - 1 do
1394 WriteThreadDat(FExitWrite[i]);
1395 FExitWrite.Clear;
1396 end;}
1397
1398 (*************************************************************************
1399 *?鴻???????????????????????????
1400 *from HotZonu
1401 *************************************************************************)
1402 function TGikoSys.GetShortName(const LongName: string; ALength: integer): string;
1403 const
1404 ERASECHAR : array [1..39] of string =
1405 ('??','??','??','??#39;,'??','??','鐚?#39;,'鐚?','??#39;,'??#39;,
1406 '??#39;,'??#39;,'??39;,'??','??#39;,'??','??','??#39;,'??','??',
1407 '??','??','??','??','??','??','鐚?','鐚?','??#39;,'??#39;,
1408 '鐔?','鐔?','??','??','??#39;,'??39;,'??','??#39;, '??');
1409 var
1410 Chr : array [0..255] of char;
1411 S : string;
1412 i : integer;
1413 begin
1414 s := Trim(LongName);
1415 if (Length(s) <= ALength) then begin
1416 Result := s;
1417 end else begin
1418 S := s;
1419 for i := Low(ERASECHAR) to High(ERASECHAR) do begin
1420 S := StringReplace(S, ERASECHAR[i], '', [rfReplaceAll]);
1421 end;
1422 if (Length(S) <= ALength) then begin
1423 Result := S;
1424 end else begin
1425 Windows.LCMapString(
1426 GetUserDefaultLCID(),
1427 LCMAP_HALFWIDTH,
1428 PChar(S),
1429 Length(S) + 1,
1430 chr,
1431 Sizeof(chr)
1432 );
1433 S := Chr;
1434 S := Copy(S,1,ALength);
1435 while true do begin
1436 if (ByteType(S, Length(S)) = mbLeadByte ) then begin
1437 S := Copy(S, 1, Length(S) - 1);
1438 end else begin
1439 Break;
1440 end;
1441 end;
1442 Result := S;
1443 end;
1444 end;
1445 end;
1446
1447 (*************************************************************************
1448 *
1449 * from HotZonu
1450 *************************************************************************)
1451 function TGikoSys.ConvRes(const Body, Bbs, Key,
1452 ParamBBS, ParamKey, ParamStart, ParamTo, ParamNoFirst, ParamTrue : string): string;
1453 type
1454 PIndex = ^TIndex;
1455 TIndex = record
1456 FIndexFrom : integer;
1457 FIndexTo : integer;
1458 FNo : string;
1459 end;
1460 const
1461 GT = '&gt;';
1462 SN = '0123456789-';
1463 ZN = '鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚?鐚???';
1464 var
1465 i : integer;
1466 s,r : string;
1467 b : TMbcsByteType;
1468 sw: boolean;
1469 sp: integer;
1470 No: string;
1471 sx: string;
1472 List: TList;
1473 oc : string;
1474 st, et: string;
1475 chk : boolean;
1476 al : boolean;
1477 procedure Add(IndexFrom, IndexTo: integer; const No: string);
1478 var
1479 FIndex : PIndex;
1480 begin
1481 New(FIndex);
1482 FIndex.FIndexFrom := IndexFrom;
1483 FIndex.FIndexTo := IndexTo;
1484 FIndex.FNo := No;
1485 List.Add(FIndex);
1486 end;
1487 function ChooseString(const Text, Separator: string; Index: integer): string;
1488 var
1489 S : string;
1490 i, p : integer;
1491 begin
1492 S := Text;
1493 for i := 0 to Index - 1 do begin
1494 if (AnsiPos(Separator, S) = 0) then S := ''
1495 else S := Copy(S, AnsiPos(Separator, S) + Length(Separator), Length(S));
1496 end;
1497 p := AnsiPos(Separator, S);
1498 if (p > 0) then Result := Copy(S, 1, p - 1) else Result := S;
1499 end;
1500 begin
1501 { v1.0 b2 - 03 }
1502 s := Body;
1503 r := Body;
1504 i := 1;
1505 sw := False;
1506 No := '';
1507 List:= TList.Create;
1508 oc := '';
1509 sp := 0;
1510 chk := False;
1511 al := False;
1512 while true do begin
1513 b := ByteType(s, i);
1514 case b of
1515 mbSingleByte : begin
1516 if (not sw) and (Copy(s,i,8) = GT + GT) then begin
1517 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 0) then begin
1518 sw := True;
1519 sp := i;
1520 i := i + 7;
1521 oc:='';
1522 chk := True;
1523 end;
1524 end else
1525 if (not sw) and (Copy(s,i,8) = GT + GT) then begin
1526 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 1) then begin
1527 i := i + 7;
1528 oc:='';
1529 chk := True;
1530 end;
1531 end else
1532 if (not sw) and (Copy(s,i,4) = GT) then begin
1533 if (AnsiPos('<A HREF', AnsiUpperCase(oc)) = 0) then begin
1534 sw := True;
1535 sp := i;
1536 i := i + 3;
1537 oc:='';
1538 chk := True;
1539 end;
1540 end else
1541 if ((not sw) and (Copy(s,i,1) = ',')) or
1542 ((not sw) and (Copy(s,i,1) = '=')) then begin
1543 if ((not Chk) and (AnsiLowerCase(oc) = '</a>')) or
1544 ((Chk) and (oc = '')) or
1545 ((not Chk) and (al)) then
1546 begin
1547 sw := True;
1548 sp := i;
1549 //i := i + 1;
1550 oc:='';
1551 end;
1552 end else
1553 if (sw) then begin
1554 sx := Copy(s,i,1);
1555 if (AnsiPos(sx, SN) > 0) then begin
1556 No := No + sx;
1557 end else begin
1558 if (No <> '') and (No <> '-') then begin
1559 Add(sp, i, No);
1560 al := True;
1561 end;
1562 sw := False;
1563 //
1564 i := i - 1;
1565 //
1566 No := '';
1567 oc:='';
1568 //chk := False;
1569 end;
1570 end else begin
1571 if Copy(s,i,1) = '<' then oc := '';
1572 oc := oc + Copy(s,i,1);
1573 chk := False;
1574 al := False;
1575 end;
1576 end;
1577 mbLeadByte : begin
1578 if (not sw) and (Copy(s,i,4) = '鐚?鐚?') then begin
1579 sw := True;
1580 sp := i;
1581 i := i + 3;
1582 chk := True;
1583 end else
1584 if (not sw) and (Copy(s,i,2) = '鐚?') then begin
1585 sw := True;
1586 sp := i;
1587 i := i + 1;
1588 chk := True;
1589 end else
1590 if (sw) then begin
1591 sx := Copy(s,i,2);
1592 if (AnsiPos(sx, ZN) > 0) then begin
1593 No := No + ZenToHan(sx);
1594 end else begin
1595 if (No <> '') and (No <> '-') and (No <> '??') then begin
1596 Add(sp, i, No);
1597 end;
1598 sw := False;
1599 i := i - 1;
1600 No := '';
1601 end;
1602 end else begin
1603 oc := '';
1604 chk := False;
1605 end;
1606 al := False;
1607 end;
1608 end;
1609 inc(i);
1610 if (i > Length(Body)) then begin
1611 if (sw) then begin
1612 if (No <> '') then Add(sp, i, No);
1613 end;
1614 Break;
1615 end;
1616 end;
1617 for i := List.Count - 1 downto 0 do begin
1618 if (AnsiPos('-', PIndex(List[i]).FNo) > 0) then begin
1619 st := ChooseString(PIndex(List[i]).FNo, '-', 0);
1620 et := ChooseString(PIndex(List[i]).FNo, '-', 1);
1621 end else begin
1622 st := PIndex(List[i]).FNo;
1623 et := PIndex(List[i]).FNo;
1624 end;
1625 r := Copy(r,0, PIndex(List[i]).FIndexFrom - 1) +
1626 Format('<a href="../test/read.cgi?%s=%s&%s=%s&%s=%s&%s=%s&%s=%s" target="_blank">',
1627 [ParamBBS, Bbs, ParamKey, Key, ParamStart, st, ParamTo, et, ParamNoFirst, ParamTrue]) +
1628 Copy(r,PIndex(List[i]).FIndexFrom, PIndex(List[i]).FIndexTo - PIndex(List[i]).FIndexFrom) + '</A>' +
1629 Copy(r,PIndex(List[i]).FIndexTo,Length(r));
1630 Dispose(PIndex(List[i]));
1631 end;
1632 List.Free;
1633 Result := r;
1634 end;
1635
1636 (*************************************************************************
1637 * ???????茹?
1638 * from HotZonu
1639 *************************************************************************)
1640 function TGikoSys.ZenToHan(const s: string): string;
1641 var
1642 Chr: array [0..255] of char;
1643 begin
1644 Windows.LCMapString(
1645 GetUserDefaultLCID(),
1646 // LCMAP_HALFWIDTH,
1647 LCMAP_HALFWIDTH or LCMAP_KATAKANA or LCMAP_LOWERCASE,
1648 PChar(s),
1649 Length(s) + 1,
1650 chr,
1651 Sizeof(chr)
1652 );
1653 Result := Chr;
1654 end;
1655
1656 (*************************************************************************
1657 * ?????茹??蚊?????????????????阪?ャ??????????Pos
1658 *************************************************************************)
1659 function TGikoSys.VaguePos(const Substr, S: string): Integer;
1660 begin
1661 Result := Pos(ZenToHan(Substr), ZenToHan(S));
1662 end;
1663
1664 function TGikoSys.BoolToInt(b: Boolean): Integer;
1665 begin
1666 Result := IfThen(b, 1, 0);
1667 end;
1668
1669 function TGikoSys.IntToBool(i: Integer): Boolean;
1670 begin
1671 Result := i = 1;
1672 end;
1673
1674 //gzip?у?х軒???????????祉??
1675 function TGikoSys.GzipDecompress(ResStream: TStream; ContentEncoding: string): string;
1676 const
1677 BUF_SIZE = 4096;
1678 var
1679 GZipStream: TGzipDecompressStream;
1680 TextStream: TStringStream;
1681 buf: array[0..BUF_SIZE - 1] of Byte;
1682 cnt: Integer;
1683 s: string;
1684 i: Integer;
1685 begin
1686 Result := '';
1687 TextStream := TStringStream.Create('');
1688 try
1689 //???若???潟???潟?????c????003絲丞?(x-gzip???????????帥????)
1690 // if LowerCase(Trim(ContentEncoding)) = 'gzip' then begin
1691 if AnsiPos('gzip', LowerCase(Trim(ContentEncoding))) > 0 then begin
1692 ResStream.Position := 0;
1693 GZipStream := TGzipDecompressStream.Create(TextStream);
1694 try
1695 repeat
1696 FillChar(buf, BUF_SIZE, 0);
1697 cnt := ResStream.Read(buf, BUF_SIZE);
1698 if cnt > 0 then
1699 GZipStream.Write(buf, BUF_SIZE);
1700 until cnt = 0;
1701 finally
1702 GZipStream.Free;
1703 end;
1704 end else begin
1705 ResStream.Position := 0;
1706 repeat
1707 FillChar(buf, BUF_SIZE, 0);
1708 cnt := ResStream.Read(buf, BUF_SIZE);
1709 if cnt > 0 then
1710 TextStream.Write(buf, BUF_SIZE);
1711 until cnt = 0;
1712 end;
1713
1714 //NULL??絖???"*"??????
1715 s := TextStream.DataString;
1716 i := Length(s);
1717 while (i > 0) and (s[i] = #0) do
1718 Dec(i);
1719 s := Copy(s, 1, i);
1720
1721 i := Pos(#0, s);
1722 while i <> 0 do begin
1723 s[i] := '*';
1724 i := Pos(#0, s);
1725 end;
1726 Result := s;
1727 finally
1728 TextStream.Free;
1729 end;
1730 end;
1731
1732 procedure TGikoSys.LoadKeySetting(ActionList: TActionList);
1733 const
1734 STD_SEC = 'KeySetting';
1735 var
1736 i: Integer;
1737 ini: TMemIniFile;
1738 ActionName: string;
1739 ActionKey: Integer;
1740 SecList: TStringList;
1741 Component: TComponent;
1742 begin
1743 if not FileExists(GetConfigDir + KEY_SETTING_FILE_NAME) then
1744 Exit;
1745 SecList := TStringList.Create;
1746 ini := TMemIniFile.Create(GetConfigDir + KEY_SETTING_FILE_NAME);
1747 try
1748 ini.ReadSection(STD_SEC, SecList);
1749 for i := 0 to SecList.Count - 1 do begin
1750 ActionName := SecList[i];
1751 ActionKey := ini.ReadInteger(STD_SEC, ActionName, -1);
1752 if ActionKey <> -1 then begin
1753 Component := ActionList.Owner.FindComponent(ActionName);
1754 if TObject(Component) is TAction then begin
1755 TAction(Component).ShortCut := ActionKey;
1756 end;
1757 end;
1758 end;
1759 finally
1760 ini.Free;
1761 SecList.Free;
1762 end;
1763 end;
1764
1765 procedure TGikoSys.SaveKeySetting(ActionList: TActionList);
1766 const
1767 STD_SEC = 'KeySetting';
1768 var
1769 i: Integer;
1770 ini: TMemIniFile;
1771 begin
1772 ini := TMemIniFile.Create(GetConfigDir + KEY_SETTING_FILE_NAME);
1773 try
1774 for i := 0 to ActionList.ActionCount - 1 do begin
1775 if ActionList.Actions[i].Tag = -1 then
1776 Continue;
1777 ini.WriteInteger(STD_SEC, ActionList.Actions[i].Name, TAction(ActionList.Actions[i]).ShortCut);
1778 end;
1779 ini.UpdateFile;
1780 finally
1781 ini.Free;
1782 end;
1783 end;
1784
1785 //
1786 procedure TGikoSys.CreateProcess(const AppPath: string; const Param: string);
1787 var
1788 PI: TProcessInformation;
1789 SI: TStartupInfo;
1790 Path: string;
1791 begin
1792 Path := '"' + AppPath + '"';
1793 if Param <> '' then
1794 Path := Path + ' ' + Param;
1795
1796 SI.Cb := SizeOf(Si);
1797 SI.lpReserved := nil;
1798 SI.lpDesktop := nil;
1799 SI.lpTitle := nil;
1800 SI.dwFlags := 0;
1801 SI.cbReserved2 := 0;
1802 SI.lpReserved2 := nil;
1803 SI.dwysize := 0;
1804 Windows.CreateProcess(nil,
1805 PChar(Path),
1806 nil,
1807 nil,
1808 False,
1809 0,
1810 nil,
1811 nil,
1812 SI,
1813 PI);
1814 end;
1815
1816 procedure TGikoSys.OpenBrowser(URL: string; BrowserType: TGikoBrowserType);
1817 begin
1818 case BrowserType of
1819 gbtIE:
1820 HlinkNavigateString(nil, PWideChar(WideString(URL)));
1821 gbtUserApp, gbtAuto:
1822 if (Setting.URLApp) and (FileExists(Setting.URLAppFile)) then
1823 GikoSys.CreateProcess(Setting.URLAppFile, URL)
1824 else
1825 HlinkNavigateString(nil, PWideChar(WideString(URL)));
1826 end;
1827 end;
1828
1829 function TGikoSys.HTMLDecode(const AStr: String): String;
1830 var
1831 Sp, Rp, Cp, Tp: PChar;
1832 S: String;
1833 I, Code: Integer;
1834 Num: Boolean;
1835 begin
1836 SetLength(Result, Length(AStr));
1837 Sp := PChar(AStr);
1838 Rp := PChar(Result);
1839 //Cp := Sp;
1840 try
1841 while Sp^ <> #0 do begin
1842 case Sp^ of
1843 '&': begin
1844 //Cp := Sp;
1845 Inc(Sp);
1846 case Sp^ of
1847 'a': if AnsiStrPos(Sp, 'amp;') = Sp then
1848 begin
1849 Inc(Sp, 3);
1850 Rp^ := '&';
1851 end;
1852 'l',
1853 'g': if (AnsiStrPos(Sp, 'lt;') = Sp) or (AnsiStrPos(Sp, 'gt;') = Sp) then
1854 begin
1855 Cp := Sp;
1856 Inc(Sp, 2);
1857 while (Sp^ <> ';') and (Sp^ <> #0) do
1858 Inc(Sp);
1859 if Cp^ = 'l' then
1860 Rp^ := '<'
1861 else
1862 Rp^ := '>';
1863 end;
1864 'q': if AnsiStrPos(Sp, 'quot;') = Sp then
1865 begin
1866 Inc(Sp,4);
1867 Rp^ := '"';
1868 end;
1869 '#': begin
1870 Tp := Sp;
1871 Inc(Tp);
1872 Num := IsNumeric(Copy(Tp, 1, 1));
1873 while (Sp^ <> ';') and (Sp^ <> #0) do begin
1874 if (Num) and (not IsNumeric(Copy(Sp, 1, 1))) then
1875 Break;
1876 Inc(Sp);
1877 end;
1878 SetString(S, Tp, Sp - Tp);
1879 Val(S, I, Code);
1880 Rp^ := Chr((I));
1881 end;
1882 // else
1883 //raise EConvertError.CreateFmt(sInvalidHTMLEncodedChar,
1884 //[Cp^ + Sp^, Cp - PChar(AStr)])
1885 end;
1886 end
1887 else
1888 Rp^ := Sp^;
1889 end;
1890 Inc(Rp);
1891 Inc(Sp);
1892 end;
1893 except
1894 // on E:EConvertError do
1895 // raise EConvertError.CreateFmt(sInvalidHTMLEncodedChar,
1896 // [Cp^ + Sp^, Cp - PChar(AStr)])
1897 end;
1898 SetLength(Result, Rp - PChar(Result));
1899 end;
1900
1901 function TGikoSys.GetHRefText(s: string): string;
1902 var
1903 Index: Integer;
1904 Index2: Integer;
1905 begin
1906 Result := '';
1907 s := Trim(s);
1908 if s = '' then
1909 Exit;
1910
1911 Index := AnsiPos('href', LowerCase(s));
1912 if Index = 0 then
1913 Exit;
1914 s := Trim(Copy(s, Index + 4, Length(s)));
1915 s := Trim(Copy(s, 2, Length(s)));
1916
1917 //紮???????絖???'"'?????????ゃ??span>
1918 if Copy(s, 1, 1) = '"' then begin
1919 s := Trim(Copy(s, 2, Length(s)));
1920 end;
1921
1922 Index := AnsiPos('"', s);
1923 if Index <> 0 then begin
1924 //'"'?障??RL??????
1925 s := Copy(s, 1, Index - 1);
1926 end else begin
1927 //'"'???<?????違?鴻???若?鴻??">"???????鴻?障?с??URL??????
1928 Index := AnsiPos(' ', s);
1929 Index2 := AnsiPos('>', s);
1930 if Index = 0 then
1931 Index := Index2;
1932 if Index > Index2 then
1933 Index := Index2;
1934 if Index <> 0 then
1935 s := Copy(s, 1, Index - 1)
1936 else
1937 //????篁ヤ??????ャ??????/span>
1938 ;
1939 end;
1940 Result := Trim(s);
1941 end;
1942
1943 //???鴻??????鐚?鐔?鐔????????????с????????
1944 function TGikoSys.Is2chHost(Host: string): Boolean;
1945 const
1946 HOST_NAME: array[0..1] of string = ('2ch.net', 'bbspink.com');
1947 var
1948 i: Integer;
1949 // Len: Integer;
1950 begin
1951 Result := False;
1952 OutputDebugString(pchar(HOST_NAME[0]));
1953 for i := 0 to Length(HOST_NAME) - 1 do begin
1954 // Len := Length(HOST_NAME[i]);
1955 if AnsiPos(HOST_NAME[i], Host) = (Length(Host) - Length(HOST_NAME[i]) + 1) then begin
1956 Result := True;
1957 Exit;
1958 end;
1959 end;
1960 end;
1961
1962 function TGikoSys.Parse2chURL(const url: string; const path: string; const document: string; var BBSID: string; var BBSKey: string): Boolean;
1963 const
1964 READ_PATH: string = '/test/read.cgi/';
1965 OLD_READ_PATH: string = '/test/read.cgi?';
1966 KAKO_PATH: string = '/kako/';
1967 var
1968 Index: Integer;
1969 s: string;
1970 SList: TStringList;
1971 begin
1972 BBSID := '';
1973 BBSKey := '';
1974 Result := False;
1975
1976 Index := AnsiPos(READ_PATH, path);
1977 if Index <> 0 then begin
1978 s := Copy(path, Length(READ_PATH) + 1, Length(path));
1979 BBSID := GetTokenIndex(s, '/', 0);
1980 BBSKey := GetTokenIndex(s, '/', 1);
1981 if BBSKey = '' then
1982 BBSKey := Document;
1983 Result := (BBSID <> '') or (BBSKey <> '');
1984 Exit;
1985 end;
1986 Index := AnsiPos(KAKO_PATH, path);
1987 if Index <> 0 then begin
1988 s := Copy(path, 2, Length(path));
1989 BBSID := GetTokenIndex(s, '/', 0);
1990 if (BBSID = 'log') and (GetTokenIndex(s, '/', 2) = 'kako') then
1991 BBSID := GetTokenIndex(s, '/', 1);
1992 BBSKey := ChangeFileExt(Document, '');
1993 Result := (BBSID <> '') or (BBSKey <> '');
1994 Exit;
1995 end;
1996 Index := AnsiPos('read.cgi?', URL);
1997 if Index <> 0 then begin
1998 SList := TStringList.Create;
1999 try
2000 try
2001 // s := HTMLDecode(Document);
2002 ExtractHTTPFields(['?', '&'], [], PChar(URL), SList, False);
2003 BBSID := SList.Values['bbs'];
2004 BBSKey := SList.Values['key'];
2005 Result := (BBSID <> '') or (BBSKey <> '');
2006 Exit;
2007 except
2008 Exit;
2009 end;
2010 finally
2011 SList.Free;
2012 end;
2013 end;
2014 end;
2015
2016 function TGikoSys.Parse2chURL2(URL: string): TPathRec;
2017 var
2018 i: Integer;
2019 s: string;
2020 wk: string;
2021 wkMin: Integer;
2022 wkMax: Integer;
2023 wkInt: Integer;
2024 RStart: Integer;
2025 RLength: Integer;
2026 SList: TStringList;
2027 begin
2028 URL := Trim(LowerCase(URL));
2029 Result.FBBS := '';
2030 Result.FKey := '';
2031 Result.FSt := 0;
2032 Result.FTo := 0;
2033 Result.FFirst := False;
2034 Result.FStBegin := False;
2035 Result.FToEnd := False;
2036 Result.FDone := False;
2037
2038 wkMin := 0;
2039 wkMax := 1;
2040
2041 FAWKStr.RegExp := 'http://.+\.(2ch\.net|bbspink\.com)/';
2042 if FAWKStr.Match(FAWKStr.ProcessEscSeq(URL), RStart, RLength) = 0 then
2043 Exit;
2044 s := Copy(URL, RStart + RLength - 1, Length(URL));
2045
2046 //罔?羣??後?
2047 //??緇???50, 10, 10-20, 10n, 10-20n, -10, 10-, 10n- ????/span>
2048 //http://xxx.2ch.net/test/read.cgi/bbsid/1000000000/
2049 FAWKStr.RegExp := '/test/read.cgi/.+/[0-9]+/.*';
2050 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2051 s := Copy(s, 15, Length(s));
2052
2053 SList := TStringList.Create;
2054 try
2055 SList.Clear;
2056 FAWKStr.RegExp := '/';
2057 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 2 then begin
2058 Result.FBBS := SList[1];
2059 Result.FKey := SList[2];
2060 if SList.Count >= 3 then
2061 s := SList[3]
2062 else
2063 s := '';
2064 end else
2065 Exit;
2066
2067 SList.Clear;
2068 FAWKStr.LineSeparator := mcls_CRLF;
2069 FAWKStr.RegExp := '-';
2070 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) = 0 then begin
2071 Result.FFirst := True;
2072 end else begin
2073 FAWKStr.RegExp := 'l[0-9]+';
2074 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2075 Result.FFirst := True;
2076 end else begin
2077 for i := 0 to SList.Count - 1 do begin
2078 if Trim(SList[i]) = '' then begin
2079 if i = 0 then
2080 Result.FStBegin := True;
2081 if i = (SList.Count - 1) then
2082 Result.FToEnd := True;
2083 end else if IsNumeric(SList[i]) then begin
2084 wkInt := StrToInt(SList[i]);
2085 wkMax := Max(wkMax, wkInt);
2086 if wkMin = 0 then
2087 wkMin := wkInt
2088 else
2089 wkMin := Min(wkMin, wkInt);
2090 end else if Trim(SList[i]) = 'n' then begin
2091 Result.FFirst := True;
2092 end else begin
2093 FAWKStr.RegExp := '^n[0-9]+$|^[0-9]+n$';
2094 if FAWKStr.Match(FAWKStr.ProcessEscSeq(SList[i]), RStart, RLength) > 0 then begin
2095 if Copy(SList[i], 1, 1) = 'n' then
2096 wkInt := StrToInt(Copy(SList[i], 2, Length(SList[i])))
2097 else
2098 wkInt := StrToInt(Copy(SList[i], 1, Length(SList[i]) - 1));
2099 Result.FFirst := True;
2100 wkMax := Max(wkMax, wkInt);
2101 if wkMin = 1 then
2102 wkMin := wkInt
2103 else
2104 wkMin := Min(wkMin, wkInt);
2105 end;
2106 end;
2107 end;
2108 if Result.FStBegin and (not Result.FToEnd) then
2109 Result.FSt := wkMin
2110 else if (not Result.FStBegin) and Result.FToEnd then
2111 Result.FTo := wkMax
2112 else if (not Result.FStBegin) and (not Result.FToEnd) then begin
2113 Result.FSt := wkMin;
2114 Result.FTo := wkMax;
2115 end;
2116 //Result.FSt := wkMin;
2117 //Result.FTo := wkMax;
2118 end;
2119 end;
2120 finally
2121 SList.Free;
2122 end;
2123 Result.FDone := True;
2124 Exit;
2125 end;
2126
2127 //??ako?後?
2128 //http://server.2ch.net/ITA_NAME/kako/1000/10000/1000000000.html
2129 FAWKStr.RegExp := '/.+/kako/[0-9]+/[0-9]+/[0-9]+\.html';
2130 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2131 SList := TStringList.Create;
2132 try
2133 SList.Clear;
2134 FAWKStr.RegExp := '/';
2135 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 6 then begin
2136 Result.FBBS := SList[1];
2137 Result.FKey := ChangeFileExt(SList[5], '');
2138 Result.FFirst := True;
2139 end else
2140 Exit;
2141 finally
2142 SList.Free;
2143 end;
2144 Result.FDone := True;
2145 Exit;
2146 end;
2147
2148 //??ako?後?
2149 //http://server.2ch.net/ITA_NAME/kako/999/999999999.html
2150 FAWKStr.RegExp := '/.+/kako/[0-9]+/[0-9]+\.html';
2151 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2152 SList := TStringList.Create;
2153 try
2154 SList.Clear;
2155 FAWKStr.RegExp := '/';
2156 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 5 then begin
2157 Result.FBBS := SList[1];
2158 Result.FKey := ChangeFileExt(SList[4], '');
2159 Result.FFirst := True;
2160 end else
2161 Exit;
2162 finally
2163 SList.Free;
2164 end;
2165 Result.FDone := True;
2166 Exit;
2167 end;
2168
2169 //log????og2?後?
2170 //http://server.2ch.net/log/ITA_NAME/kako/999/999999999.html
2171 //http://server.2ch.net/log2/ITA_NAME/kako/999/999999999.html
2172 FAWKStr.RegExp := '/log2?/.+/kako/[0-9]+/[0-9]+\.html';
2173 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2174 SList := TStringList.Create;
2175 try
2176 SList.Clear;
2177 FAWKStr.RegExp := '/';
2178 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 6 then begin
2179 Result.FBBS := SList[2];
2180 Result.FKey := ChangeFileExt(SList[5], '');
2181 Result.FFirst := True;
2182 end else
2183 Exit;
2184 finally
2185 SList.Free;
2186 end;
2187 Result.FDone := True;
2188 Exit;
2189 end;
2190
2191
2192 //??RL?後?
2193 //http://server.2ch.net/test/read.cgi?bbs=ITA_NAME&key=1000000000&st=1&to=5&nofirst=true
2194 FAWKStr.RegExp := '/test/read\.cgi\?';
2195 if FAWKStr.Match(FAWKStr.ProcessEscSeq(s), RStart, RLength) > 0 then begin
2196 s := Copy(s, 16, Length(s));
2197 SList := TStringList.Create;
2198 try
2199 SList.Clear;
2200 FAWKStr.RegExp := '&';
2201 if FAWKStr.Split(FAWKStr.ProcessEscSeq(s), SList) >= 2 then begin
2202 Result.FFirst := True;
2203 for i := 0 to SList.Count - 1 do begin
2204 if Pos('bbs=', SList[i]) = 1 then begin
2205 Result.FBBS := Copy(SList[i], 5, Length(SList[i]));
2206 end else if Pos('key=', SList[i]) = 1 then begin
2207 Result.FKey := Copy(SList[i], 5, Length(SList[i]));
2208 end else if Pos('st=', SList[i]) = 1 then begin
2209 wk := Copy(SList[i], 4, Length(SList[i]));
2210 if IsNumeric(wk) then
2211 Result.FSt := StrToInt(wk)
2212 else if wk = '' then
2213 Result.FStBegin := True;
2214 end else if Pos('to=', SList[i]) = 1 then begin
2215 wk := Copy(SList[i], 4, Length(SList[i]));
2216 if IsNumeric(wk) then
2217 Result.FTo := StrToInt(wk)
2218 else if wk = '' then
2219 Result.FToEnd := True;
2220 end else if Pos('nofirst=', SList[i]) = 1 then begin
2221 Result.FFirst := False;
2222 end;
2223 end;
2224 end else
2225 Exit;
2226 finally
2227 SList.Free;
2228 end;
2229
2230 if (Result.FBBS <> '') and (Result.FKey <> '') then begin
2231 Result.FDone := True;
2232 end;
2233 Exit;
2234 end;
2235 end;
2236
2237 procedure TGikoSys.ParseURI(var URL, Protocol, Host, Path, Document, Port, Bookmark: string);
2238 var
2239 URI: TIdURI;
2240 begin
2241 Protocol := '';
2242 Host := '';
2243 Path := '';
2244 Document := '';
2245 Port := '';
2246 Bookmark := '';
2247 URI := TIdURI.Create(URL);
2248 try
2249 Protocol := URI.Protocol;
2250 Host := URI.Host;
2251 Path := URI.Path;
2252 Document := URI.Document;
2253 Port := URI.Port;
2254 Bookmark := URI.Bookmark;
2255 finally
2256 URI.Free;
2257 end;
2258 end;
2259
2260 function TGikoSys.GetVersionBuild: Integer;
2261 var
2262 FixedFileInfo: PVSFixedFileInfo;
2263 VersionHandle, VersionSize: DWORD;
2264 pVersionInfo: Pointer;
2265 ItemLen : UInt;
2266 AppFile: string;
2267 begin
2268 Result := 0;
2269 AppFile := Application.ExeName;
2270 VersionSize := GetFileVersionInfoSize(pChar(AppFile), VersionHandle);
2271 if VersionSize = 0 then
2272 Exit;
2273 GetMem(pVersionInfo, VersionSize);
2274 try
2275 if GetFileVersionInfo(PChar(AppFile),VersionHandle,VersionSize, pVersionInfo) then
2276 if VerQueryValue(pVersionInfo, '\', Pointer(FixedFileInfo), ItemLen) then
2277 Result := LOWORD(FixedFileInfo^.dwFileVersionLS);
2278 finally
2279 FreeMem(pVersionInfo, VersionSize);
2280 end;
2281 end;
2282
2283 initialization
2284 GikoSys := TGikoSys.Create;
2285
2286 finalization
2287 if GikoSys <> nil then begin
2288 GikoSys.Free;
2289 GikoSys := nil;
2290 end;
2291 end.

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