bottleclient/Logs.pas

   1 unit Logs;
   2
   3 interface
   4
   5 uses
   6   Contnrs, Controls, Classes, SysUtils, Dialogs, Forms, HttpThread, BottleDef,
   7   DateUtils, SsParser, XDOM_2_3_J3, Graphics, SppList;
   8
   9 type
  10
  11   TLogType = (ltBottle, ltSystemLog);
  12   TLogState = (lsUnopened, lsPlaying, lsOpened);
  13
  14   THasURL = (huUndefined, huYes, huNo);
  15
  16   TLogItem = class(TPersistent)
  17   private
  18     FScript: String;
  19     FChannel: String;
  20     FMID: String;
  21     FLogTime: TDateTime;
  22     FLogType: TLogType;
  23     FGhost: String;
  24     FVotes: Integer;
  25     FAgreements: Integer;
  26     FState: TLogState;
  27     FHasURL: THasURL;
  28     procedure SetChannel(const Value: String);
  29     procedure SetLogType(const Value: TLogType);
  30     procedure SetMID(const Value: String);
  31     procedure SetScript(const Value: String);
  32     procedure SetLogTime(const Value: TDateTime);
  33     procedure SetGhost(const Value: String);
  34     procedure SetVotes(const Value: Integer);
  35     procedure SetAgreements(const Value: Integer);
  36     procedure SetState(const Value: TLogState);
  37     procedure SetHasURL(const Value: THasURL);
  38   public
  39     constructor Create(LogType: TLogType; const MID, Channel, Script,
  40       Ghost: String; LogTime: TDateTime); overload;
  41     constructor Create(Source: TLogItem); overload;
  42     property LogType: TLogType read FLogType write SetLogType;
  43     property MID: String read FMID write SetMID;
  44     property Channel: String read FChannel write SetChannel;
  45     property LogTime: TDateTime read FLogTime write SetLogTime;
  46     property Script: String read FScript write SetScript;
  47     property Ghost: String read FGhost write SetGhost;
  48     property Votes: Integer read FVotes write SetVotes;
  49     property Agrees: Integer read FAgreements write SetAgreements;
  50     property State: TLogState read FState write SetState;
  51     property HasURL: THasURL read FHasURL write SetHasURL;
  52     procedure Assign(Source: TPersistent); override;
  53   end;
  54
  55   TBottleLogSortType = (stLogTime, stChannel, stGhost, stScript, stVote, stAgree);
  56   TBottleLogLoadFailureEvent = procedure(Sender: TObject; const Message: String) of object;
  57   TBottleLogHTMLOutputWork = procedure(Sender: TObject; const Count: integer;
  58     var Canceled: boolean) of object;
  59
  60   EXMLFileOpenException = class(Exception);
  61
  62   TBottleLogDownloadCondition = packed record
  63     IsRange: boolean;
  64     RecentCount: integer;
  65     DateLo: TDateTime;
  66     DateHi: TDateTime;
  67     MinVote: integer;
  68     MinAgree: integer;
  69     Channel: string;
  70   end;
  71
  72   TLogXMLThread = class(TThread)
  73   private
  74     FList: TObjectList;
  75     FFileName: String;
  76     FOnLoadFailure: TBottleLogLoadFailureEvent;
  77     FOnLoaded: TNotifyEvent;
  78     FLoadFailureMessage: String;
  79     procedure SetOnLoaded(const Value: TNotifyEvent);
  80     procedure SetOnLoadFailure(const Value: TBottleLogLoadFailureEvent);
  81   protected
  82     procedure Execute; override;
  83     procedure DoLoaded;
  84     procedure DoLoadFailure;
  85   public
  86     property OnLoaded: TNotifyEvent read FOnLoaded write SetOnLoaded;
  87     property OnLoadFailure: TBottleLogLoadFailureEvent
  88       read FOnLoadFailure write SetOnLoadFailure;
  89     property List: TObjectList read FList;
  90     constructor Create(FileName: String);
  91     destructor Destroy; override;
  92   end;
  93
  94   THTMLOutputUseColor = (ucUse, ucNoUse);
  95   THTMLOutputImageType = (itNone, itBMP, itPNG, itJPG);
  96   THTMLOutputRange = (orAll, orUpward, orSelected);
  97
  98   THTMLOutputOptions = record
  99     ImageDir: String;
 100     UseColor: THTMLOutputUseColor;
 101     ImageType: THTMLOutputImageType;
 102   end;
 103
 104   TBottleLogList = class(TObjectList)
 105   private
 106     FOnLoaded: TNotifyEvent;
 107     FHttpThread: THTTPDownloadThread;
 108     FXMLThread: TLogXMLThread;
 109     FLoadBytes: integer;
 110     FTitle: String;
 111     FOnLoadFailure: TBottleLogLoadFailureEvent;
 112     FOldSortColumn: TBottleLogSortType; // \83\8d\83O\91\8b
 113     FOldSortDesc: boolean;   // \83\8d\83O\91\8b
 114     FSelectedIndex: integer;
 115     FLastDownloadCondition: TBottleLogDownloadCondition;
 116     FOnLoadWork: TNotifyEvent; // \83\8d\83O\91\8b
 117     FImagePath: String; // HTML\8fo\97Í\8e\9e\82ÌIMG\83^\83O\82Ì\83p\83X(\91\8a\91Î\82Ü\82½\82Í\90â\91Î\83p\83X)
 118     FImageFiles: TStringList;
 119     FOnHTMLOutputWork: TBottleLogHTMLOutputWork; // \8fd\95¡\89æ\91\9c\8fo\97Í\82µ\82È\82¢\82½\82ß\82Ì\83`\83F\83b\83J
 120
 121     function GetBottles(Index: integer): TLogItem;
 122     procedure SetOnLoaded(const Value: TNotifyEvent);
 123     procedure HttpSuccess(Sender: TObject);
 124     procedure HttpFailure(Sender: TObject);
 125     procedure HttpWork(Sender: TObject; LoadBytes: integer);
 126     procedure XMLLoaded(Sener: TObject);
 127     procedure XMLLoadFailure(Sender: TObject; const Message: String);
 128     procedure SetTitle(const Value: String);
 129     procedure SetOnLoadFailure(const Value: TBottleLogLoadFailureEvent);
 130     procedure SetSelectedIndex(const Value: integer);
 131     procedure SetOnLoadWork(const Value: TNotifyEvent);
 132     procedure DoLoadFailure(const ErrorMessage: String);
 133     function ColorToHex(const Col: TColor): String;
 134     procedure PrintHTMLBottle(Strs: TStringList; Bottle: TLogItem;
 135       SsParser: TSsParser; const Options: THTMLOutputOptions);
 136     function PrintSurfaceImage(Strs: TStringList; const Ghost: String; ID: integer;
 137       const Options: THTMLOutputOptions): boolean;
 138     procedure SetOnHTMLOutputWork(const Value: TBottleLogHTMLOutputWork);
 139   public
 140     constructor Create(const Title: String);
 141     destructor Destroy; override;
 142     procedure SortBottles(LogSortType: TBottleLogSortType);
 143     function Bottle(MID: String): TLogItem;
 144     property Bottles[Index: integer]: TLogItem read GetBottles;
 145     procedure LoadFromWeb(const Cond: TBottleLogDownloadCondition);
 146     property Title: String read FTitle write SetTitle;
 147     procedure LoadFromStream(Stream: TStream);
 148     property OnLoaded: TNotifyEvent read FOnLoaded write SetOnLoaded;
 149     property OnLoadWork: TNotifyEvent read FOnLoadWork write SetOnLoadWork;
 150     property OnLoadFailure: TBottleLogLoadFailureEvent read FOnLoadFailure write SetOnLoadFailure;
 151     property SelectedIndex: integer read FSelectedIndex write SetSelectedIndex;
 152     procedure AddScriptLog(const Script, Channel, MID, Ghost: String);
 153     procedure AddSystemLog(const MessageString: String);
 154     procedure SaveToText(const FileName: String);
 155     procedure SaveToSstpLog(const FileName: String;
 156       const WithChannel: boolean = false);
 157     procedure SaveToXMLFile(const FileName: String);
 158     procedure LoadFromXMLFile(const FileName: String);
 159     procedure SaveToHTML(const FileName: String;
 160       const Options: THTMLOutputOptions; SsParser: TSsParser);
 161     procedure ExtractUniqueChannels(Target: TStrings);
 162     procedure ExtractUniqueGhosts(Target: TStrings);
 163     property OnHTMLOutputWork: TBottleLogHTMLOutputWork read FOnHTMLOutputWork write SetOnHTMLOutputWork;
 164   end;
 165
 166 var
 167   ASortType: TBottleLogSortType; //LogCompare\8aÖ\90\94\82©\82ç\8c©\82¦\82é\82æ\82¤\82É\88ê\8e\9e\91Þ\94ð\97p
 168   ASortDesc: boolean;
 169
 170 function LogCompare(Item1, Item2: Pointer): integer;
 171
 172
 173 ////////////////////////////////////////////////////////////////////////////////
 174 implementation
 175
 176 uses StrUtils;
 177
 178 function LogCompare(Item1, Item2: Pointer): Integer;
 179 var
 180   Log1, Log2: TLogItem;
 181 begin
 182   Log1 := TLogItem(Item1);
 183   Log2 := TLogItem(Item2);
 184   Result := 0;
 185   case ASortType of
 186     stLogTime: begin
 187       Result := AnsiCompareStr(Log2.MID, Log1.MID);
 188     end;
 189     stChannel: begin
 190       Result := AnsiCompareStr(Log1.Channel, Log2.Channel);
 191     end;
 192     stGhost: begin
 193       Result := AnsiCompareStr(Log1.Ghost, Log2.Ghost);
 194     end;
 195     stScript: begin
 196       Result := AnsiCompareStr(Log1.Script, Log2.Script);
 197     end;
 198     stVote: begin
 199       Result := Log2.Votes - Log1.Votes;
 200     end;
 201     stAgree: begin
 202       Result := Log2.Agrees - Log1.Agrees;
 203     end;
 204   end;
 205   if ASortDesc then Result := -Result; //\8f¸\8f\87
 206 end;
 207
 208 { TLogItem }
 209
 210 constructor TLogItem.Create(LogType: TLogType; const MID, Channel, Script,
 211   Ghost: String; LogTime: TDateTime);
 212 begin
 213   Self.LogType := LogType;
 214   Self.MID := MID;
 215   Self.Script := Script;
 216   Self.Channel := Channel;
 217   Self.Ghost := Ghost;
 218   Self.LogTime := LogTime;
 219   Self.State := lsUnopened;
 220 end;
 221
 222 procedure TLogItem.SetChannel(const Value: String);
 223 begin
 224   FChannel := Value;
 225 end;
 226
 227 procedure TLogItem.SetLogType(const Value: TLogType);
 228 begin
 229   FLogType := Value;
 230 end;
 231
 232 procedure TLogItem.SetMID(const Value: String);
 233 begin
 234   FMID := Value;
 235 end;
 236
 237 procedure TLogItem.SetScript(const Value: String);
 238 begin
 239   FScript := Value;
 240 end;
 241
 242 procedure TLogItem.SetLogTime(const Value: TDateTime);
 243 begin
 244   FLogTime := Value;
 245 end;
 246
 247 procedure TLogItem.SetAgreements(const Value: Integer);
 248 begin
 249   FAgreements := Value;
 250 end;
 251
 252 procedure TLogItem.SetVotes(const Value: Integer);
 253 begin
 254   FVotes := Value;
 255 end;
 256
 257 procedure TLogItem.SetGhost(const Value: String);
 258 begin
 259   FGhost := Value;
 260 end;
 261
 262
 263 procedure TLogItem.SetState(const Value: TLogState);
 264 begin
 265   FState := Value;
 266 end;
 267
 268 procedure TLogItem.Assign(Source: TPersistent);
 269 var Src: TLogItem;
 270 begin
 271   if not (Source is TLogItem) then
 272     inherited
 273   else begin
 274     Src := Source as TLogItem;
 275     self.FScript := Src.FScript;
 276     self.FChannel := Src.FChannel;
 277     self.FMID := Src.FMID;
 278     self.FLogTime := Src.FLogTime;
 279     self.FLogType := Src.FLogType;
 280     self.FGhost := Src.FGhost;
 281     self.FVotes := Src.FVotes;
 282     self.FAgreements := Src.FAgreements;
 283     self.FState := Src.FState;
 284     self.FHasURL := Src.FHasURL;
 285   end;
 286 end;
 287
 288 constructor TLogItem.Create(Source: TLogItem);
 289 begin
 290   self.Assign(Source);
 291 end;
 292
 293 procedure TLogItem.SetHasURL(const Value: THasURL);
 294 begin
 295   FHasURL := Value;
 296 end;
 297
 298 { TBottleLogList }
 299
 300 procedure TBottleLogList.AddScriptLog(const Script, Channel, MID,
 301   Ghost: String);
 302 var LogItem: TLogItem;
 303 begin
 304   LogItem := TLogItem.Create(ltBottle, MID, Channel, Script, Ghost, Now());
 305   try
 306     Insert(0, LogItem);
 307   except
 308     LogItem.Free;
 309     raise;
 310   end;
 311 end;
 312
 313 procedure TBottleLogList.AddSystemLog(const MessageString: String);
 314 var LogItem: TLogItem;
 315 begin
 316   LogItem := TLogItem.Create(ltSystemLog, '', '', MessageString, '', Now());
 317   try
 318     Insert(0, LogItem);
 319   except
 320     LogItem.Free;
 321     raise;
 322   end;
 323 end;
 324
 325 function TBottleLogList.Bottle(MID: String): TLogItem;
 326 var i: integer;
 327 begin
 328   Result := nil;
 329   for i := 0 to Count-1 do
 330     if (Items[i] as TLogItem).MID = MID then begin
 331       Result := Items[i] as TLogItem;
 332       exit;
 333     end;
 334 end;
 335
 336 function TBottleLogList.ColorToHex(const Col: TColor): String;
 337 var
 338   RGB: integer;
 339   R, G, B: byte;
 340 begin
 341   RGB := ColorToRGB(Col);
 342   R := RGB and $FF;
 343   G := (RGB and $FF00) shr 8;
 344   B := (RGB and $FF0000) shr 16;
 345   RGB := (R shl 16) or (G shl 8) or B;
 346   Result := '#' + IntToHex(RGB, 6);
 347 end;
 348
 349 constructor TBottleLogList.Create(const Title: String);
 350 begin
 351   inherited Create;
 352   FTitle := Title;
 353   OwnsObjects := true;
 354   FSelectedIndex := -1; // \91I\91ð\82³\82ê\82Ä\82¢\82È\82¢
 355 end;
 356
 357 destructor TBottleLogList.Destroy;
 358 begin
 359   inherited;
 360   // FHttpThread\82Í\8e©\95ª\82ðFree\82·\82é\81u\91O\81v\82ÉSynchronize\82Å\8eQ\8fÆ\82ª\8dí\8f\9c\82³\82ê\82é\82Ì\82Å\81A
 361   // FHttpThread <> nil \82È\82ç\8eÀ\91Ì\82ª\91¶\8dÝ\82·\82é\82±\82Æ\82Í\8am\8eÀ\82Å\82 \82é\81B
 362   if FHttpThread <> nil then begin
 363     FHttpThread.OnSuccess := nil;
 364     FHttpThread.OnConnectionFailed := nil;
 365   end;
 366 end;
 367
 368 procedure TBottleLogList.DoLoadFailure(const ErrorMessage: String);
 369 begin
 370   self.Clear;
 371   self.AddSystemLog(ErrorMessage);
 372   if Assigned(FOnLoadFailure) then FOnLoadFailure(self, ErrorMessage);
 373 end;
 374
 375 procedure TBottleLogList.ExtractUniqueChannels(Target: TStrings);
 376 var i: integer;
 377 begin
 378   // \82±\82Ì\83\8d\83O\92\86\82Ì\83`\83\83\83\93\83l\83\8b\82ð\8eæ\82è\8fo\82·
 379   // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
 380   for i := 0 to Count-1 do
 381     if Target.IndexOf(Bottles[i].Channel) < 0 then
 382       if Bottles[i].Channel <> '' then
 383         Target.Add(Bottles[i].Channel);
 384 end;
 385
 386 procedure TBottleLogList.ExtractUniqueGhosts(Target: TStrings);
 387 var i: integer;
 388 begin
 389   // \82±\82Ì\83\8d\83O\92\86\82Ì\83S\81[\83X\83g\82ð\8eæ\82è\8fo\82·
 390   // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
 391   for i := 0 to Count-1 do
 392     if Target.IndexOf(Bottles[i].Ghost) < 0 then
 393       if Bottles[i].Ghost <> '' then
 394         Target.Add(Bottles[i].Ghost);
 395 end;
 396
 397 function TBottleLogList.GetBottles(Index: integer): TLogItem;
 398 begin
 399   Result := Items[Index] as TLogItem;
 400 end;
 401
 402 procedure TBottleLogList.HttpFailure(Sender: TObject);
 403 begin
 404   if Assigned(FOnLoadFailure) then
 405     DoLoadFailure('\83T\81[\83o\82Ì\90Ú\91±\82É\8e¸\94s\82µ\82Ü\82µ\82½');
 406 end;
 407
 408 procedure TBottleLogList.HttpSuccess(Sender: TObject);
 409 var Stream: TStringStream;
 410     StrList: TStringList;
 411 begin
 412   Stream := TStringStream.Create(FHttpThread.RecvString);
 413   try
 414     StrList := TStringList.Create;
 415     try
 416       StrList.Text := Stream.DataString;
 417       if StrList[0] <> 'Result: OK' then begin
 418         if Assigned(FOnLoadFailure) then
 419           DoLoadFailure('\83T\81[\83o\82ª\83G\83\89\81[\82ð\95Ô\82µ\82Ü\82µ\82½'#13#10 + Stream.DataString);
 420       end else begin
 421         while StrList.Count > 0 do
 422           if StrList[0] <> '' then StrList.Delete(0) else Break; //\83w\83b\83_\81[\82ð\8dí\8f\9c\82·\82é
 423         if StrList.Count > 0 then StrList.Delete(0); //\83w\83b\83_\81[\8cã\82Ì\8bó\8ds\8dí\8f\9c
 424         Stream.Seek(0, soFromBeginning);
 425         Stream.Size := Length(StrList.Text);
 426         Stream.WriteString(StrList.Text);
 427         Stream.Seek(0, soFromBeginning);
 428         LoadFromStream(Stream);
 429       end;
 430     finally
 431       StrList.Free;
 432     end;
 433   finally
 434     Stream.Free;
 435     // nil\82Å\82È\82¢\8fê\8d\87\82É\82Í\8eÀ\91Ì\82ª\91¶\8dÝ\82·\82é\82±\82Æ\82ð\8am\8eÀ\82É\82·\82é
 436     // \82½\82¾\82µ nil \82¾\82©\82ç\82Æ\82¢\82Á\82Ä\8eÀ\91Ì\82ª\91¶\8dÝ\82µ\82È\82¢\82Æ\82Í\8cÀ\82ç\82È\82¢(FreeOnTerminate\82Ì\82½\82ß)
 437     FHttpThread := nil;
 438   end;
 439 end;
 440
 441 procedure TBottleLogList.HttpWork(Sender: TObject; LoadBytes: integer);
 442 begin
 443   self.Clear;
 444   AddSystemLog(Format('\83_\83E\83\93\83\8d\81[\83h\92\86\82Å\82· - %4d KB', [LoadBytes div 1024]));
 445   FLoadBytes := LoadBytes;
 446   if Assigned(FOnLoadWork) then FOnLoadWork(self);
 447 end;
 448
 449 procedure TBottleLogList.LoadFromStream(Stream: TStream);
 450 var i: integer;
 451     agree: integer;
 452     vote: integer;
 453     SourceStream: TStringStream;
 454     Source: TStringList;
 455     LogItem: TLogItem;
 456   function S2D (const S: String): TDateTime;
 457   begin
 458     Result := EncodeDateTime(
 459       StrToInt(Copy(S, 1, 4)), StrToInt(Copy(S, 5, 2)), StrToInt(Copy(S, 7, 2)),
 460       StrToInt(Copy(S, 9, 2)), StrToInt(Copy(S, 11, 2)), StrToInt(Copy(S, 13, 2)), 0);
 461   end;
 462 begin
 463   Source := nil;
 464   SourceStream := nil;
 465   try
 466     try
 467       SourceStream := TStringStream.Create('');
 468       SourceStream.Seek(0, soFromBeginning);
 469       SourceStream.CopyFrom(Stream, Stream.Size);
 470       Source := TStringList.Create;
 471       Source.Text := SourceStream.DataString;
 472       i := 0;
 473       if Source.Count = 0 then begin
 474         DoLoadFailure('\8ew\92è\8fð\8c\8f\82Ì\83\8d\83O\82Í\91¶\8dÝ\82µ\82Ü\82¹\82ñ');
 475         Exit;
 476       end;
 477       if Source[0] <> 'OK' then begin
 478       end;
 479       Self.Clear;
 480       while (i + 7) < Source.Count do begin
 481         vote := StrToInt(Source[i+5]);
 482         agree := StrToInt(Source[i+6]);
 483
 484         //\93\8a\95[\81E\93¯\88Ó\8fð\8c\8f\8ew\92è\82Í\82±\82±\82Å\8eÀ\8c»
 485         //FIXME FIXME - \97Í\8bZ\82·\82¬\82Ü\82·\81A\81A\81A
 486         if vote >= FLastDownloadCondition.MinVote then begin
 487           if agree >= FLastDownloadCondition.MinAgree then begin
 488             LogItem := TLogItem.Create(ltBottle, Source[i+1], Source[i+2],
 489               Source[i+7], Source[i+3], S2D(Source[i]));
 490
 491             LogItem.Votes  := vote;
 492             LogItem.Agrees := agree;
 493             LogItem.State  := lsOpened;
 494             Self.Add(LogItem);
 495           end;
 496         end;
 497
 498         i := i + 8;
 499       end;
 500     finally
 501       SourceStream.Free;
 502       Source.Free;
 503     end;
 504   except
 505     On EConvertError do begin
 506       DoLoadFailure('\83T\81[\83o\89\9e\93\9a\82Ì\8c`\8e®\82ª\95s\90³\82Å\82·');
 507       Self.Clear;
 508     end;
 509   end;
 510   FOldSortColumn := stLogTime;
 511   FOldSortDesc := false;
 512   if Assigned(FOnLoaded) then FOnLoaded(Self);
 513 end;
 514
 515 procedure TBottleLogList.LoadFromWeb(const Cond: TBottleLogDownloadCondition);
 516 var Param: String;
 517 begin
 518   Self.Clear;
 519   AddSystemLog('\83_\83E\83\93\83\8d\81[\83h\92\86\82Å\82· - \83T\81[\83o\82©\82ç\89\9e\93\9a\91Ò\82¿');
 520
 521   FLastDownloadCondition := Cond;
 522   with Cond do begin
 523     if Cond.IsRange then begin
 524       Param := Format('year_lo=%d&month_lo=%d&day_lo=%d&year_hi=%d&month_hi=%d&day_hi=%d&',
 525         [YearOf(DateLo), MonthOf(DateLo), DayOf(DateLo),
 526          YearOf(DateHi), MonthOf(DateHi), DayOf(DateHi)]);
 527     end else begin
 528       Param := Format('recent=%d&', [RecentCount]);
 529     end;
 530     Param := Param + Format('channel=%s&sort=timedesc&delimiter=%%0D%%0A',
 531       [ParamsEncode(Channel)]);
 532   end;
 533   FHttpThread := THTTPDownloadThread.Create(Pref.BottleServer, Pref.CgiFetchLog, Param);
 534   if Pref.UseHttpProxy then begin
 535     FHttpThread.ProxyServer := Pref.ProxyAddress;
 536     FHttpThread.ProxyPort   := Pref.ProxyPort;
 537   end;
 538   FHttpThread.FreeOnTerminate := true;
 539   FHttpThread.OnSuccess := HttpSuccess;
 540   FHttpThread.OnConnectionFailed := HttpFailure;
 541   FHttpThread.OnHttpWork := HttpWork;
 542
 543   FLoadBytes := 0;
 544   FHttpThread.Resume;
 545 end;
 546
 547 procedure TBottleLogList.LoadFromXMLFile(const FileName: String);
 548 begin
 549   Self.Clear;
 550   AddSystemLog('\83\8d\81[\83h\92\86...');
 551   FXMLThread := TLogXMLThread.Create(FileName);
 552   FXMLThread.FreeOnTerminate := true; // \8f\9f\8eè\82É\8fÁ\82¦\82Ä\82à\82ç\82¤
 553   with FXMLThread do
 554   begin
 555     OnLoaded := XMLLoaded;
 556     OnLoadFailure := XMLLoadFailure;
 557     Resume;
 558   end;
 559 end;
 560
 561 procedure TBottleLogList.PrintHTMLBottle(Strs: TStringList;
 562   Bottle: TLogItem; SsParser: TSsParser; const Options: THTMLOutputOptions);
 563 var
 564   i: integer;
 565   InScope1, InSync: boolean;
 566   Talk, Tag: String;
 567   sur0, sur1, sur: integer;
 568   procedure TalkEnd;
 569   var Cl: String;
 570   begin
 571     if Talk = '' then
 572       Exit;
 573     if InSync then Cl := 'synchronized'
 574     else if InScope1 then Cl := 'scope1'
 575     else Cl := 'scope0';
 576     if Options.ImageType = itNone then
 577     begin
 578       with Strs do
 579       begin
 580         Add('  <tr class="' + Cl + '">');
 581         Add('    <td class="talk">' + XMLEntity(Talk) + '</td>');
 582         Add('  </tr>');
 583       end;
 584     end else
 585     begin
 586       with Strs do
 587       begin
 588         Add('  <tr class="' + Cl + '">');
 589         Add('    <td class="surface">');
 590         if InSync then
 591         begin
 592           PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
 593           PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
 594         end else if InScope1 then
 595         begin
 596           PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
 597         end else
 598         begin
 599           PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
 600         end;
 601         Add('    </td>');
 602         Add('    <td class="talk">' + Talk + '</td>');
 603         Add('  </tr>');
 604       end;
 605     end;
 606     Talk := '';
 607   end; // of sub-procedure TalkEnd
 608 begin
 609   SsParser.EscapeInvalidMeta := false;
 610   SsParser.LeaveEscape := false;
 611   SsParser.InputString := Bottle.Script;
 612   InScope1 := false;
 613   InSync := false;
 614   sur0 := 0;
 615   sur1 := 10;
 616   for i := 0 to SsParser.Count-1 do
 617     case SsParser.MarkUpType[i] of
 618       mtStr, mtMeta:
 619         Talk := Talk + XMLEntity(SsParser.Str[i]);
 620       mtTag:
 621         begin
 622           Tag := SsParser.Str[i];
 623           if (Tag = '\h') then
 624           begin
 625             if InScope1 and not InSync then
 626               TalkEnd;
 627             InScope1 := false;
 628           end else if (Tag = '\u') then
 629           begin
 630             if not InScope1 and not InSync then
 631               TalkEnd;
 632             InScope1 := true;
 633           end else if Tag = '\_s' then
 634           begin
 635             TalkEnd;
 636             InSync := not InSync;
 637           end else if SsParser.Match(Tag, '\s%d') = 3 then
 638           begin
 639             TalkEnd;
 640             sur := Ord(Tag[3]) - Ord('0');
 641             if InSync then
 642             begin
 643               sur0 := sur;
 644               sur1 := sur;
 645             end else if InScope1 then
 646               sur1 := sur
 647             else
 648               sur0 := sur;
 649           end else if (SsParser.Match(Tag, '\s[%D]') > 0) or (Tag = '\s[-1]') then
 650           begin
 651             TalkEnd;
 652             sur := StrToInt(SsParser.GetParam(Tag, 1));
 653             if InSync then
 654             begin
 655               sur0 := sur;
 656               sur1 := sur;
 657             end else if InScope1 then
 658               sur1 := sur
 659             else
 660               sur0 := sur;
 661           end else if SsParser.Match(Tag, '\n') >= 2 then
 662           begin
 663             if Talk <> '' then
 664               Talk := Talk + '<br>';
 665           end else if Tag = '\c' then
 666           begin
 667             TalkEnd;
 668           end;
 669         end;
 670     end;
 671   TalkEnd;
 672 end;
 673
 674 function TBottleLogList.PrintSurfaceImage(Strs: TStringList; const Ghost: String;
 675   ID: integer; const Options: THTMLOutputOptions): boolean;
 676 var
 677   Bmp: TBitmap;
 678   Path, Ext, Name: String;
 679 begin
 680   Result := false;
 681   if (ID < 0) or (Ghost = '') then
 682     Exit;
 683   Ext := 'bmp';
 684   Name := Format('%s,%d.%s', [SafeFileName(Ghost), ID, Ext]);
 685   if FImageFiles.IndexOf(Name) >= 0 then
 686   begin
 687     Strs.Add(Format('      <img src="%s\%s" alt="%s,%d">',
 688       [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
 689     Result := true;
 690   end else
 691   begin
 692     Bmp := TBitmap.Create;
 693     try
 694       if Spps.TryGetImage(Ghost, ID, Bmp) then
 695       begin
 696         Path := Options.ImageDir + PathDelim + Name;
 697         Bmp.SaveToFile(Path);
 698         Strs.Add(Format('      <img src="%s\%s" alt="%s,%d">',
 699           [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
 700         Result := true;
 701         FImageFiles.Add(Name); // \8e\9f\89ñ\82©\82ç\8cÄ\82Ñ\8fo\82³\82È\82\82Ä\82¢\82¢\82æ\82¤\82É\82·\82é
 702       end else
 703         Strs.Add(Format('      [%d]', [ID]));
 704     finally
 705       Bmp.Free;
 706     end;
 707   end;
 708 end;
 709
 710 procedure TBottleLogList.SaveToHTML(const FileName: String;
 711   const Options: THTMLOutputOptions; SsParser: TSsParser);
 712 var
 713   i: integer;
 714   Strs: TStringList;
 715   ChannelAndGhost: String;
 716   Cancel: boolean;
 717 begin
 718   if ExtractFilePath(FileName) = ExtractFilePath(Options.ImageDir) then
 719     FImagePath := ExtractFileName(Options.ImageDir)
 720   else
 721     FImagePath := Options.ImageDir;
 722
 723   Screen.Cursor := crHourGlass;
 724   FImageFiles := TStringList.Create;
 725   try
 726     Strs := TStringList.Create;
 727     try
 728       with Strs do
 729       begin
 730         Add('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN">');
 731         Add('<html>');
 732         Add('<style type="text/css"><!--');
 733         Add('table.bottle td{font-family: monospace}');
 734         if Options.UseColor = ucUse then
 735         begin
 736           Add(Format('p.bottleattr {color: %s}', [ColorToHex(Pref.TalkColorH)]));
 737           Add(Format('body {background-color: %s}', [ColorToHex(Pref.BgColor)]));
 738           Add(Format('table.bottle tr.scope0 td.talk{color: %s}', [ColorToHex(Pref.TalkColorH)]));
 739           Add(Format('table.bottle tr.scope1 td.talk{color: %s}', [ColorToHex(Pref.TalkColorU)]));
 740           Add(Format('table.bottle tr.synchronized td.talk{color: %s}', [ColorToHex(Pref.TalkColorS)]));
 741           Add('table.bottle td.surface {text-align: center}');
 742         end;
 743         Add('--></style>');
 744         for i := 0 to Self.Count-1 do
 745         begin
 746           if Assigned(FOnHTMLOutputWork) then
 747           begin
 748             Cancel := false;
 749             FOnHTMLOutputWork(Self, i, Cancel);
 750             if Cancel then
 751               Exit;
 752           end;
 753           if Bottles[i].Ghost <> '' then
 754             ChannelAndGhost := XMLEntity(Bottles[i].Channel) + '/' + XMLEntity(Bottles[i].Ghost)
 755           else
 756             ChannelAndGhost := XMLEntity(Bottles[i].Channel);
 757           Add(Format('<p class="bottleattr">%s %s \93\8a\95[%d \93¯\88Ó%d</p>', [
 758             FormatDateTime('yyyy/mm/dd hh:nn:ss', Bottles[i].LogTime),
 759             ChannelAndGhost,
 760             Bottles[i].Votes,
 761             Bottles[i].Agrees
 762           ]));
 763           Add('<table class="bottle">');
 764           PrintHTMLBottle(Strs, Bottles[i], SsParser, Options);
 765           Add('</table>');
 766           Add('<hr>');
 767         end;
 768         Add('</html>');
 769         SaveToFile(FileName);
 770       end;
 771     finally
 772       Strs.Free;
 773     end;
 774   finally
 775     FImageFiles.Free;
 776     Screen.Cursor := crArrow;
 777   end;
 778 end;
 779
 780 procedure TBottleLogList.SaveToSstpLog(const FileName: String;
 781   const WithChannel: boolean = false);
 782 var i: integer;
 783     Str: TStringList;
 784     Item: TLogItem;
 785     Date: String;
 786 const
 787   DayStr: array[1..7] of String = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
 788 begin
 789   Str := nil;
 790   try
 791     Str := TStringList.Create;
 792     for i := 0 to Self.Count - 1 do begin
 793       Item := Self.Items[i] as TLogItem;
 794       if Item.LogType = ltBottle then begin
 795         Date := FormatDateTime('yyyy/mm/dd hh:nn:ss ', Item.LogTime);
 796         Date := Date + '(' + DayStr[DayOfWeek(Item.LogTime)] + ')';
 797         if WithChannel then
 798           Date := Date + ',' + Item.Channel +',SEND,' + Item.Script
 799         else
 800           Date := Date + ',0.0.0.0,SEND,' + Item.Script;
 801         Str.Add(Date);
 802       end;
 803     end;
 804     Str.SaveToFile(FileName);
 805   finally
 806     Str.Free;
 807   end;
 808 end;
 809
 810 procedure TBottleLogList.SaveToText(const FileName: String);
 811 var i: integer;
 812     Str: TStringList;
 813 begin
 814   Str := nil;
 815   try
 816     Str := TStringList.Create;
 817     for i := 0 to Self.Count - 1 do
 818       if (Self.Items[i] as TLogItem).LogType = ltBottle then
 819         Str.Add((Self.Items[i] as TLogItem).Script);
 820     Str.SaveToFile(FileName);
 821   finally
 822     Str.Free;
 823   end;
 824 end;
 825
 826 procedure TBottleLogList.SaveToXMLFile(const FileName: String);
 827 var i: integer;
 828     MessageNode, Child: TdomElement;
 829     Item: TLogItem;
 830     DOM: TdomDocument;
 831     Parser: TXmlToDomParser;
 832     Impl: TDomImplementation;
 833     FS: TFileStream;
 834 begin
 835   Impl := TDomImplementation.create(nil);
 836   try
 837     Parser := TXmlToDomParser.create(nil);
 838     Parser.DOMImpl := Impl;
 839     try
 840       try
 841         DOM := Parser.fileToDom(ExtractFilePath(Application.ExeName)+'xbtl.dat');
 842         // \82±\82ê\82Í\96¾\8e¦\93I\82ÉFree\82µ\82È\82\82Ä\82æ\82¢
 843         with DOM do
 844         begin
 845           documentElement.setAttribute('saved',
 846             FormatDateTime('yy/mm/dd hh:nn:ss', Now));
 847           documentElement.setAttribute('generator', VersionString);
 848           documentElement.setAttribute('version', '1.0');
 849           for i := 0 to Self.Count-1 do begin
 850             Item := Self.GetBottles(i);
 851             MessageNode := createElement('message');
 852             MessageNode.setAttribute('mid', Item.MID);
 853             documentElement.appendChild(MessageNode);
 854
 855             // \93ú\95t
 856             Child := createElement('date');
 857             Child.appendChild(createTextNode(FormatDateTime('yy/mm/dd hh:nn:ss', Item.LogTime)));
 858             MessageNode.appendChild(Child);
 859             // \83`\83\83\83\93\83l\83\8b
 860             Child := createElement('channel');
 861             Child.appendChild(createTextNode(Item.Channel));
 862             MessageNode.appendChild(Child);
 863             // \83X\83N\83\8a\83v\83g
 864             Child := createElement('script');
 865             Child.appendChild(createTextNode(Item.Script));
 866             MessageNode.appendChild(Child);
 867             // \93\8a\95[
 868             Child := createElement('votes');
 869             Child.appendChild(createTextNode(IntToStr(Item.Votes)));
 870             MessageNode.appendChild(Child);
 871             // \93¯\88Ó
 872             Child := createElement('agrees');
 873             Child.appendChild(createTextNode(IntToStr(Item.Agrees)));
 874             MessageNode.appendChild(Child);
 875             // \83S\81[\83X\83g
 876             Child := createElement('ghost');
 877             Child.appendChild(createTextNode(Item.Ghost));
 878             MessageNode.appendChild(Child);
 879
 880           end;
 881         end;
 882         FS := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
 883         try
 884           DOM.writeCodeAsShiftJIS(FS);
 885         finally
 886           FS.Free;
 887         end;
 888       except
 889         ShowMessage('xbtl.dat\82ð\8dÄ\83C\83\93\83X\83g\81[\83\8b\82µ\82Ä\82\82¾\82³\82¢\81B');
 890       end;
 891     finally
 892       Parser.DOMImpl.freeDocument(DOM);
 893       Parser.Free;
 894     end;
 895   finally
 896     Impl.Free;
 897   end;
 898 end;
 899
 900 procedure TBottleLogList.SetOnHTMLOutputWork(
 901   const Value: TBottleLogHTMLOutputWork);
 902 begin
 903   FOnHTMLOutputWork := Value;
 904 end;
 905
 906 procedure TBottleLogList.SetOnLoaded(const Value: TNotifyEvent);
 907 begin
 908   FOnLoaded := Value;
 909 end;
 910
 911 procedure TBottleLogList.SetOnLoadFailure(
 912   const Value: TBottleLogLoadFailureEvent);
 913 begin
 914   FOnLoadFailure := Value;
 915 end;
 916
 917 procedure TBottleLogList.SetOnLoadWork(const Value: TNotifyEvent);
 918 begin
 919   FOnLoadWork := Value;
 920 end;
 921
 922 procedure TBottleLogList.SetSelectedIndex(const Value: integer);
 923 begin
 924   FSelectedIndex := Value;
 925 end;
 926
 927 procedure TBottleLogList.SetTitle(const Value: String);
 928 begin
 929   FTitle := Value;
 930 end;
 931
 932 procedure TBottleLogList.SortBottles(LogSortType: TBottleLogSortType);
 933 begin
 934   if FOldSortColumn = LogSortType then
 935     ASortDesc := not FOldSortDesc
 936   else begin
 937     ASortDesc := false;
 938   end;
 939   ASortType := LogSortType;
 940   Self.Sort(LogCompare);
 941   FOldSortColumn := ASortType;
 942   FOldSortDesc := ASortDesc;
 943 end;
 944
 945 procedure TBottleLogList.XMLLoaded(Sener: TObject);
 946 begin
 947   Self.Assign(FXMLThread.List);
 948   if Assigned(FOnLoaded) then FOnLoaded(Self);
 949   FXMLThread := nil;
 950 end;
 951
 952 procedure TBottleLogList.XMLLoadFailure(Sender: TObject;
 953   const Message: String);
 954 begin
 955   if Assigned(FOnLoadFailure) then
 956     DoLoadFailure(Message);
 957 end;
 958
 959 { TLogXMLThread }
 960
 961 constructor TLogXMLThread.Create(FileName: String);
 962 begin
 963   inherited Create(true);
 964   FList := TObjectList.Create(false); // OwnsObject = false (!!)
 965   FFileName := FileName;
 966 end;
 967
 968 destructor TLogXMLThread.Destroy;
 969 begin
 970   FList.Free;
 971   inherited;
 972 end;
 973
 974 procedure TLogXMLThread.DoLoaded;
 975 begin
 976   if Assigned(FOnLoaded) then
 977     FOnLoaded(self);
 978 end;
 979
 980 procedure TLogXMLThread.DoLoadFailure;
 981 begin
 982   if Assigned(FOnLoadFailure) then
 983     FOnLoadFailure(self, FLoadFailureMessage);
 984 end;
 985
 986 procedure TLogXMLThread.Execute;
 987 var i, j, votes, agrees: integer;
 988     Time: TDateTime;
 989     ANode, Child: TdomElement;
 990     Item: TLogItem;
 991     DOM: TdomDocument;
 992     Parser: TXmlToDomParser;
 993     Impl: TDomImplementation;
 994     Str, mid, channel, script, ghost: String;
 995 begin
 996   FList.Clear;
 997   Impl := TDomImplementation.create(nil);
 998   try
 999     Parser := TXmlToDomParser.create(nil);
1000     Parser.DOMImpl := Impl;
1001     try
1002       try
1003         DOM := Parser.fileToDom(FFileName); //\82±\82ê\82Í\96¾\8e¦\93I\82ÉFree\82µ\82È\82\82Ä\82æ\82¢
1004         DOM.normalize;
1005         if not DOM.validate(nil, erReplace) then
1006           raise EXMLFileOpenException.Create('\97L\8cø\82È\83{\83g\83\8b\83\8d\83O\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B');
1007         with DOM do
1008         begin
1009           if DocumentElement = nil then
1010           begin
1011             FLoadFailureMessage := '\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1012              '\83\8b\81[\83g\83^\83O\82ª\82 \82è\82Ü\82¹\82ñ';
1013             Synchronize(DoLoadFailure);
1014             Exit;
1015           end;
1016           if DocumentElement.nodeName <> 'bottlelog' then
1017           begin
1018             FLoadFailureMessage := '\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1019               'bottlelog\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ';
1020             Synchronize(DoLoadFailure);
1021             Exit;
1022           end;
1023           Str :=  DocumentElement.getAttribute('version');
1024           if Str <> '1.0' then
1025           begin
1026             FLoadFailureMessage := Format('\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1027               '\82±\82Ì\83\8d\83O\83t\83@\83C\83\8b\82Ì\83o\81[\83W\83\87\83\93(%s)\82Í\93Ç\82Ý\8d\9e\82ß\82Ü\82¹\82ñ', [Str]);
1028             Synchronize(DoLoadFailure);
1029             Exit;
1030           end;
1031           for i := 0 to DocumentElement.childNodes.length-1 do
1032           begin
1033             if documentElement.childNodes.item(i).nodeType <> ntElement_Node then
1034               Continue;
1035             ANode := documentElement.childNodes.item(i) as TdomElement;
1036             if ANode.nodeName <> 'message' then
1037               Continue;
1038             mid := ANode.getAttribute('mid');
1039             channel := '';
1040             script := '';
1041             ghost := '';
1042             votes := 0;
1043             agrees := 0;
1044             Time := Now;
1045             for j := 0 to ANode.childNodes.length-1 do
1046             begin
1047               if ANode.childNodes.item(j).nodeType <> ntElement_Node then
1048                 Continue;
1049               Child := ANode.childNodes.item(j) as TdomElement;
1050               if Child.nodeName = 'channel' then
1051                 channel := Trim(Child.textContent)
1052               else if Child.nodeName = 'script' then
1053                 script := Trim(Child.textContent)
1054               else if Child.nodeName = 'ghost' then
1055                 ghost := Trim(Child.textContent)
1056               else if Child.nodeName = 'votes' then
1057                 votes := StrToIntDef(Child.textContent, 0)
1058               else if Child.nodeName = 'agrees' then
1059                 agrees := StrToIntDef(Child.textContent, 0)
1060               else if Child.nodeName = 'date' then
1061                 TryStrToDateTime(Trim(Child.textContent), Time);
1062             end;
1063             Item := TLogItem.Create(ltBottle, mid, channel, script, ghost, time);
1064             Item.Votes  := votes;
1065             Item.Agrees := agrees;
1066             Item.State := lsOpened;
1067             try
1068               FList.Add(Item);
1069             except
1070               Item.Free;
1071             end;
1072           end;
1073           Synchronize(DoLoaded);
1074         end;
1075       except
1076         on E: EParserException do
1077         begin
1078           FLoadFailureMessage := 'XML\89ð\90Í\83G\83\89\81[\81B' + E.Message;
1079           Synchronize(DoLoadFailure);
1080           Exit;
1081         end;
1082         on E: Exception do
1083         begin
1084           FLoadFailureMessage := 'XML\83I\81[\83v\83\93\8e\9e\82É\83G\83\89\81[\82ª\94\90¶\82µ\82Ü\82µ\82½\81B' +
1085             E.Message;
1086           Synchronize(DoLoadFailure);
1087           Exit;
1088         end;
1089       end;
1090     finally
1091       Parser.DOMImpl.freeDocument(DOM);
1092       Parser.Free;
1093     end;
1094   finally
1095     Impl.Free;
1096   end;
1097 end;
1098
1099 procedure TLogXMLThread.SetOnLoaded(const Value: TNotifyEvent);
1100 begin
1101   FOnLoaded := Value;
1102 end;
1103
1104 procedure TLogXMLThread.SetOnLoadFailure(const Value: TBottleLogLoadFailureEvent);
1105 begin
1106   FOnLoadFailure := Value;
1107 end;
1108
1109 end.