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     FOnLoadWork: TNotifyEvent; // \83\8d\83O\91\8b
 116     FImagePath: String; // HTML\8fo\97Í\8e\9e\82ÌIMG\83^\83O\82Ì\83p\83X(\91\8a\91Î\82Ü\82½\82Í\90â\91Î\83p\83X)
 117     FImageFiles: TStringList;
 118     FOnHTMLOutputWork: TBottleLogHTMLOutputWork; // \8fd\95¡\89æ\91\9c\8fo\97Í\82µ\82È\82¢\82½\82ß\82Ì\83`\83F\83b\83J
 119
 120     function GetBottles(Index: integer): TLogItem;
 121     procedure SetOnLoaded(const Value: TNotifyEvent);
 122     procedure HttpSuccess(Sender: TObject);
 123     procedure HttpFailure(Sender: TObject);
 124     procedure HttpWork(Sender: TObject; LoadBytes: integer);
 125     procedure XMLLoaded(Sener: TObject);
 126     procedure XMLLoadFailure(Sender: TObject; const Message: String);
 127     procedure SetTitle(const Value: String);
 128     procedure SetOnLoadFailure(const Value: TBottleLogLoadFailureEvent);
 129     procedure SetSelectedIndex(const Value: integer);
 130     procedure SetOnLoadWork(const Value: TNotifyEvent);
 131     procedure DoLoadFailure(const ErrorMessage: String);
 132     function ColorToHex(const Col: TColor): String;
 133     procedure PrintHTMLBottle(Strs: TStringList; Bottle: TLogItem;
 134       SsParser: TSsParser; const Options: THTMLOutputOptions);
 135     function PrintSurfaceImage(Strs: TStringList; const Ghost: String; ID: integer;
 136       const Options: THTMLOutputOptions): boolean;
 137     procedure SetOnHTMLOutputWork(const Value: TBottleLogHTMLOutputWork);
 138   public
 139     constructor Create(const Title: String);
 140     destructor Destroy; override;
 141     procedure SortBottles(LogSortType: TBottleLogSortType);
 142     function Bottle(MID: String): TLogItem;
 143     property Bottles[Index: integer]: TLogItem read GetBottles;
 144     procedure LoadFromWeb(const Cond: TBottleLogDownloadCondition);
 145     property Title: String read FTitle write SetTitle;
 146     procedure LoadFromStream(Stream: TStream);
 147     property OnLoaded: TNotifyEvent read FOnLoaded write SetOnLoaded;
 148     property OnLoadWork: TNotifyEvent read FOnLoadWork write SetOnLoadWork;
 149     property OnLoadFailure: TBottleLogLoadFailureEvent read FOnLoadFailure write SetOnLoadFailure;
 150     property SelectedIndex: integer read FSelectedIndex write SetSelectedIndex;
 151     procedure AddScriptLog(const Script, Channel, MID, Ghost: String;
 152       const LogTime: TDateTime; const Vote, Agree: integer);
 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; const LogTime: TDateTime; const Vote, Agree: integer);
 302 var LogItem: TLogItem;
 303 begin
 304   LogItem := TLogItem.Create(ltBottle, MID, Channel, Script, Ghost, LogTime);
 305   LogItem.FVotes := Vote;
 306   LogItem.FAgreements := Agree;
 307   try
 308     Insert(0, LogItem);
 309   except
 310     LogItem.Free;
 311     raise;
 312   end;
 313 end;
 314
 315 procedure TBottleLogList.AddSystemLog(const MessageString: String);
 316 var LogItem: TLogItem;
 317 begin
 318   LogItem := TLogItem.Create(ltSystemLog, '', '', MessageString, '', Now());
 319   try
 320     Insert(0, LogItem);
 321   except
 322     LogItem.Free;
 323     raise;
 324   end;
 325 end;
 326
 327 function TBottleLogList.Bottle(MID: String): TLogItem;
 328 var i: integer;
 329 begin
 330   Result := nil;
 331   for i := 0 to Count-1 do
 332     if (Items[i] as TLogItem).MID = MID then begin
 333       Result := Items[i] as TLogItem;
 334       exit;
 335     end;
 336 end;
 337
 338 function TBottleLogList.ColorToHex(const Col: TColor): String;
 339 var
 340   RGB: integer;
 341   R, G, B: byte;
 342 begin
 343   RGB := ColorToRGB(Col);
 344   R := RGB and $FF;
 345   G := (RGB and $FF00) shr 8;
 346   B := (RGB and $FF0000) shr 16;
 347   RGB := (R shl 16) or (G shl 8) or B;
 348   Result := '#' + IntToHex(RGB, 6);
 349 end;
 350
 351 constructor TBottleLogList.Create(const Title: String);
 352 begin
 353   inherited Create;
 354   FTitle := Title;
 355   OwnsObjects := true;
 356   FSelectedIndex := -1; // \91I\91ð\82³\82ê\82Ä\82¢\82È\82¢
 357 end;
 358
 359 destructor TBottleLogList.Destroy;
 360 begin
 361   inherited;
 362   // 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
 363   // FHttpThread <> nil \82È\82ç\8eÀ\91Ì\82ª\91¶\8dÝ\82·\82é\82±\82Æ\82Í\8am\8eÀ\82Å\82 \82é\81B
 364   if FHttpThread <> nil then begin
 365     FHttpThread.OnSuccess := nil;
 366     FHttpThread.OnConnectionFailed := nil;
 367   end;
 368 end;
 369
 370 procedure TBottleLogList.DoLoadFailure(const ErrorMessage: String);
 371 begin
 372   self.Clear;
 373   self.AddSystemLog(ErrorMessage);
 374   if Assigned(FOnLoadFailure) then FOnLoadFailure(self, ErrorMessage);
 375 end;
 376
 377 procedure TBottleLogList.ExtractUniqueChannels(Target: TStrings);
 378 var i: integer;
 379 begin
 380   // \82±\82Ì\83\8d\83O\92\86\82Ì\83`\83\83\83\93\83l\83\8b\82ð\8eæ\82è\8fo\82·
 381   // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
 382   for i := 0 to Count-1 do
 383     if Target.IndexOf(Bottles[i].Channel) < 0 then
 384       Target.Add(Bottles[i].Channel);
 385 end;
 386
 387 procedure TBottleLogList.ExtractUniqueGhosts(Target: TStrings);
 388 var i: integer;
 389 begin
 390   // \82±\82Ì\83\8d\83O\92\86\82Ì\83S\81[\83X\83g\82ð\8eæ\82è\8fo\82·
 391   // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
 392   for i := 0 to Count-1 do
 393     if Target.IndexOf(Bottles[i].Ghost) < 0 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     SourceStream: TStringStream;
 452     Source: TStringList;
 453     LogItem: TLogItem;
 454   function S2D (const S: String): TDateTime;
 455   begin
 456     Result := EncodeDateTime(
 457       StrToInt(Copy(S, 1, 4)), StrToInt(Copy(S, 5, 2)), StrToInt(Copy(S, 7, 2)),
 458       StrToInt(Copy(S, 9, 2)), StrToInt(Copy(S, 11, 2)), StrToInt(Copy(S, 13, 2)), 0);
 459   end;
 460 begin
 461   Source := nil;
 462   SourceStream := nil;
 463   try
 464     try
 465       SourceStream := TStringStream.Create('');
 466       SourceStream.Seek(0, soFromBeginning);
 467       SourceStream.CopyFrom(Stream, Stream.Size);
 468       Source := TStringList.Create;
 469       Source.Text := SourceStream.DataString;
 470       i := 0;
 471       if Source.Count = 0 then begin
 472         DoLoadFailure('\8ew\92è\8fð\8c\8f\82Ì\83\8d\83O\82Í\91¶\8dÝ\82µ\82Ü\82¹\82ñ');
 473         Exit;
 474       end;
 475       if Source[0] <> 'OK' then begin
 476       end;
 477       Self.Clear;
 478       while (i + 7) < Source.Count do begin
 479         LogItem := TLogItem.Create(ltBottle, Source[i+1], Source[i+2],
 480           Source[i+7], Source[i+3], S2D(Source[i]));
 481         LogItem.Votes  := StrToInt(Source[i+5]);
 482         LogItem.Agrees := StrToInt(Source[i+6]);
 483         LogItem.State := lsOpened;
 484         i := i + 8;
 485         Self.Add(LogItem);
 486       end;
 487     finally
 488       SourceStream.Free;
 489       Source.Free;
 490     end;
 491   except
 492     On EConvertError do begin
 493       DoLoadFailure('\83T\81[\83o\89\9e\93\9a\82Ì\8c`\8e®\82ª\95s\90³\82Å\82·');
 494       Self.Clear;
 495     end;
 496   end;
 497   FOldSortColumn := stLogTime;
 498   FOldSortDesc := false;
 499   if Assigned(FOnLoaded) then FOnLoaded(Self);
 500 end;
 501
 502 procedure TBottleLogList.LoadFromWeb(const Cond: TBottleLogDownloadCondition);
 503 var Param: String;
 504 begin
 505   Self.Clear;
 506   AddSystemLog('\83_\83E\83\93\83\8d\81[\83h\92\86\82Å\82· - \83T\81[\83o\82©\82ç\89\9e\93\9a\91Ò\82¿');
 507   with Cond do begin
 508     if Cond.IsRange then begin
 509       Param := Format('year_lo=%d&month_lo=%d&day_lo=%d&year_hi=%d&month_hi=%d&day_hi=%d&',
 510         [YearOf(DateLo), MonthOf(DateLo), DayOf(DateLo),
 511          YearOf(DateHi), MonthOf(DateHi), DayOf(DateHi)]);
 512     end else begin
 513       Param := Format('recent=%d&', [RecentCount]);
 514     end;
 515     Param := Param + Format('minvote=%d&minagree=%d&channel=%s&sort=timedesc&delimiter=%%0D%%0A',
 516       [MinVote, MinAgree, ParamsEncode(Channel)]);
 517   end;
 518   FHttpThread := THTTPDownloadThread.Create(Pref.BottleServer, Pref.CgiFetchLog, Param);
 519   if Pref.UseHttpProxy then begin
 520     FHttpThread.ProxyServer := Pref.ProxyAddress;
 521     FHttpThread.ProxyPort   := Pref.ProxyPort;
 522   end;
 523   FHttpThread.FreeOnTerminate := true;
 524   FHttpThread.OnSuccess := HttpSuccess;
 525   FHttpThread.OnConnectionFailed := HttpFailure;
 526   FHttpThread.OnHttpWork := HttpWork;
 527
 528   FLoadBytes := 0;
 529   FHttpThread.Resume;
 530 end;
 531
 532 procedure TBottleLogList.LoadFromXMLFile(const FileName: String);
 533 begin
 534   Self.Clear;
 535   AddSystemLog('\83\8d\81[\83h\92\86...');
 536   FXMLThread := TLogXMLThread.Create(FileName);
 537   FXMLThread.FreeOnTerminate := true; // \8f\9f\8eè\82É\8fÁ\82¦\82Ä\82à\82ç\82¤
 538   with FXMLThread do
 539   begin
 540     OnLoaded := XMLLoaded;
 541     OnLoadFailure := XMLLoadFailure;
 542     Resume;
 543   end;
 544 end;
 545
 546 procedure TBottleLogList.PrintHTMLBottle(Strs: TStringList;
 547   Bottle: TLogItem; SsParser: TSsParser; const Options: THTMLOutputOptions);
 548 var
 549   i: integer;
 550   InScope1, InSync: boolean;
 551   Talk, Tag: String;
 552   sur0, sur1, sur: integer;
 553   procedure TalkEnd;
 554   var Cl: String;
 555   begin
 556     if Talk = '' then
 557       Exit;
 558     if InSync then Cl := 'synchronized'
 559     else if InScope1 then Cl := 'scope1'
 560     else Cl := 'scope0';
 561     if Options.ImageType = itNone then
 562     begin
 563       with Strs do
 564       begin
 565         Add('  <tr class="' + Cl + '">');
 566         Add('    <td class="talk">' + XMLEntity(Talk) + '</td>');
 567         Add('  </tr>');
 568       end;
 569     end else
 570     begin
 571       //\83`\83\83\83\93\83l\83\8b\83S\81[\83X\83g\91Î\8dô
 572       if Bottle.Ghost = '' then
 573         if ChannelList.Channel[Bottle.Channel] <> nil then
 574           Bottle.Ghost := ChannelList.Channel[Bottle.Channel].Ghost;
 575       with Strs do
 576       begin
 577         Add('  <tr class="' + Cl + '">');
 578         Add('    <td class="surface">');
 579         if InSync then
 580         begin
 581           PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
 582           PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
 583         end else if InScope1 then
 584         begin
 585           PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
 586         end else
 587         begin
 588           PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
 589         end;
 590         Add('    </td>');
 591         Add('    <td class="talk">' + Talk + '</td>');
 592         Add('  </tr>');
 593       end;
 594     end;
 595     Talk := '';
 596   end; // of sub-procedure TalkEnd
 597 begin
 598   SsParser.EscapeInvalidMeta := false;
 599   SsParser.LeaveEscape := false;
 600   SsParser.InputString := Bottle.Script;
 601   InScope1 := false;
 602   InSync := false;
 603   sur0 := 0;
 604   sur1 := 10;
 605   for i := 0 to SsParser.Count-1 do
 606     case SsParser.MarkUpType[i] of
 607       mtStr, mtMeta:
 608         Talk := Talk + XMLEntity(SsParser.Str[i]);
 609       mtTag:
 610         begin
 611           Tag := SsParser.Str[i];
 612           if (Tag = '\h') then
 613           begin
 614             if InScope1 and not InSync then
 615               TalkEnd;
 616             InScope1 := false;
 617           end else if (Tag = '\u') then
 618           begin
 619             if not InScope1 and not InSync then
 620               TalkEnd;
 621             InScope1 := true;
 622           end else if Tag = '\_s' then
 623           begin
 624             TalkEnd;
 625             InSync := not InSync;
 626           end else if SsParser.Match(Tag, '\s%d') = 3 then
 627           begin
 628             TalkEnd;
 629             sur := Ord(Tag[3]) - Ord('0');
 630             if InSync then
 631             begin
 632               sur0 := sur;
 633               sur1 := sur;
 634             end else if InScope1 then
 635               sur1 := sur
 636             else
 637               sur0 := sur;
 638           end else if (SsParser.Match(Tag, '\s[%D]') > 0) or (Tag = '\s[-1]') then
 639           begin
 640             TalkEnd;
 641             sur := StrToInt(SsParser.GetParam(Tag, 1));
 642             if InSync then
 643             begin
 644               sur0 := sur;
 645               sur1 := sur;
 646             end else if InScope1 then
 647               sur1 := sur
 648             else
 649               sur0 := sur;
 650           end else if SsParser.Match(Tag, '\n') >= 2 then
 651           begin
 652             if Talk <> '' then
 653               Talk := Talk + '<br>';
 654           end else if Tag = '\c' then
 655           begin
 656             TalkEnd;
 657           end;
 658         end;
 659     end;
 660   TalkEnd;
 661 end;
 662
 663 function TBottleLogList.PrintSurfaceImage(Strs: TStringList; const Ghost: String;
 664   ID: integer; const Options: THTMLOutputOptions): boolean;
 665 var
 666   Bmp: TBitmap;
 667   Path, Ext, Name: String;
 668 begin
 669   Result := false;
 670   if (ID < 0) or (Ghost = '') then
 671     Exit;
 672   Ext := 'bmp';
 673   Name := Format('%s,%d.%s', [SafeFileName(Ghost), ID, Ext]);
 674   if FImageFiles.IndexOf(Name) >= 0 then
 675   begin
 676     Strs.Add(Format('      <img src="%s\%s" alt="%s,%d">',
 677       [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
 678     Result := true;
 679   end else
 680   begin
 681     Bmp := TBitmap.Create;
 682     try
 683       if Spps.TryGetImage(Ghost, ID, Bmp) then
 684       begin
 685         Path := Options.ImageDir + PathDelim + Name;
 686         Bmp.SaveToFile(Path);
 687         Strs.Add(Format('      <img src="%s\%s" alt="%s,%d">',
 688           [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
 689         Result := true;
 690         FImageFiles.Add(Name); // \8e\9f\89ñ\82©\82ç\8cÄ\82Ñ\8fo\82³\82È\82\82Ä\82¢\82¢\82æ\82¤\82É\82·\82é
 691       end else
 692         Strs.Add(Format('      [%d]', [ID]));
 693     finally
 694       Bmp.Free;
 695     end;
 696   end;
 697 end;
 698
 699 procedure TBottleLogList.SaveToHTML(const FileName: String;
 700   const Options: THTMLOutputOptions; SsParser: TSsParser);
 701 var
 702   i: integer;
 703   Strs: TStringList;
 704   ChannelAndGhost: String;
 705   Cancel: boolean;
 706 begin
 707   if ExtractFilePath(FileName) = ExtractFilePath(Options.ImageDir) then
 708     FImagePath := ExtractFileName(Options.ImageDir)
 709   else
 710     FImagePath := Options.ImageDir;
 711
 712   Screen.Cursor := crHourGlass;
 713   FImageFiles := TStringList.Create;
 714   try
 715     Strs := TStringList.Create;
 716     try
 717       with Strs do
 718       begin
 719         Add('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN">');
 720         Add('<html>');
 721         Add('<style type="text/css"><!--');
 722         Add('table.bottle td{font-family: monospace}');
 723         if Options.UseColor = ucUse then
 724         begin
 725           Add(Format('p.bottleattr {color: %s}', [ColorToHex(Pref.TalkColorH)]));
 726           Add(Format('body {background-color: %s}', [ColorToHex(Pref.BgColor)]));
 727           Add(Format('table.bottle tr.scope0 td.talk{color: %s}', [ColorToHex(Pref.TalkColorH)]));
 728           Add(Format('table.bottle tr.scope1 td.talk{color: %s}', [ColorToHex(Pref.TalkColorU)]));
 729           Add(Format('table.bottle tr.synchronized td.talk{color: %s}', [ColorToHex(Pref.TalkColorS)]));
 730           Add('table.bottle td.surface {text-align: center}');
 731         end;
 732         Add('--></style>');
 733         for i := 0 to Self.Count-1 do
 734         begin
 735           if Assigned(FOnHTMLOutputWork) then
 736           begin
 737             Cancel := false;
 738             FOnHTMLOutputWork(Self, i, Cancel);
 739             if Cancel then
 740               Exit;
 741           end;
 742           if Bottles[i].Ghost <> '' then
 743             ChannelAndGhost := XMLEntity(Bottles[i].Channel) + '/' + XMLEntity(Bottles[i].Ghost)
 744           else
 745             ChannelAndGhost := XMLEntity(Bottles[i].Channel);
 746           Add(Format('<p class="bottleattr">%s %s \93\8a\95[%d \93¯\88Ó%d</p>', [
 747             FormatDateTime('yyyy/mm/dd hh:nn:ss', Bottles[i].LogTime),
 748             ChannelAndGhost,
 749             Bottles[i].Votes,
 750             Bottles[i].Agrees
 751           ]));
 752           Add('<table class="bottle">');
 753           PrintHTMLBottle(Strs, Bottles[i], SsParser, Options);
 754           Add('</table>');
 755           Add('<hr>');
 756         end;
 757         Add('</html>');
 758         SaveToFile(FileName);
 759       end;
 760     finally
 761       Strs.Free;
 762     end;
 763   finally
 764     FImageFiles.Free;
 765     Screen.Cursor := crArrow;
 766   end;
 767 end;
 768
 769 procedure TBottleLogList.SaveToSstpLog(const FileName: String;
 770   const WithChannel: boolean = false);
 771 var i: integer;
 772     Str: TStringList;
 773     Item: TLogItem;
 774     Date: String;
 775 const
 776   DayStr: array[1..7] of String = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
 777 begin
 778   Str := nil;
 779   try
 780     Str := TStringList.Create;
 781     for i := 0 to Self.Count - 1 do begin
 782       Item := Self.Items[i] as TLogItem;
 783       if Item.LogType = ltBottle then begin
 784         Date := FormatDateTime('yyyy/mm/dd hh:nn:ss ', Item.LogTime);
 785         Date := Date + '(' + DayStr[DayOfWeek(Item.LogTime)] + ')';
 786         if WithChannel then
 787           Date := Date + ',' + Item.Channel +',SEND,' + Item.Script
 788         else
 789           Date := Date + ',0.0.0.0,SEND,' + Item.Script;
 790         Str.Add(Date);
 791       end;
 792     end;
 793     Str.SaveToFile(FileName);
 794   finally
 795     Str.Free;
 796   end;
 797 end;
 798
 799 procedure TBottleLogList.SaveToText(const FileName: String);
 800 var i: integer;
 801     Str: TStringList;
 802 begin
 803   Str := nil;
 804   try
 805     Str := TStringList.Create;
 806     for i := 0 to Self.Count - 1 do
 807       if (Self.Items[i] as TLogItem).LogType = ltBottle then
 808         Str.Add((Self.Items[i] as TLogItem).Script);
 809     Str.SaveToFile(FileName);
 810   finally
 811     Str.Free;
 812   end;
 813 end;
 814
 815 procedure TBottleLogList.SaveToXMLFile(const FileName: String);
 816 var i: integer;
 817     MessageNode, Child: TdomElement;
 818     Item: TLogItem;
 819     DOM: TdomDocument;
 820     Parser: TXmlToDomParser;
 821     Impl: TDomImplementation;
 822     FS: TFileStream;
 823 begin
 824   Impl := TDomImplementation.create(nil);
 825   try
 826     Parser := TXmlToDomParser.create(nil);
 827     Parser.DOMImpl := Impl;
 828     try
 829       try
 830         DOM := Parser.fileToDom(ExtractFilePath(Application.ExeName)+'xbtl.dat');
 831         // \82±\82ê\82Í\96¾\8e¦\93I\82ÉFree\82µ\82È\82\82Ä\82æ\82¢
 832         with DOM do
 833         begin
 834           documentElement.setAttribute('saved',
 835             FormatDateTime('yy/mm/dd hh:nn:ss', Now));
 836           documentElement.setAttribute('generator', VersionString);
 837           documentElement.setAttribute('version', '1.0');
 838           for i := 0 to Self.Count-1 do begin
 839             Item := Self.GetBottles(i);
 840             MessageNode := createElement('message');
 841             MessageNode.setAttribute('mid', Item.MID);
 842             documentElement.appendChild(MessageNode);
 843
 844             // \93ú\95t
 845             Child := createElement('date');
 846             Child.appendChild(createTextNode(FormatDateTime('yy/mm/dd hh:nn:ss', Item.LogTime)));
 847             MessageNode.appendChild(Child);
 848             // \83`\83\83\83\93\83l\83\8b
 849             Child := createElement('channel');
 850             Child.appendChild(createTextNode(Item.Channel));
 851             MessageNode.appendChild(Child);
 852             // \83X\83N\83\8a\83v\83g
 853             Child := createElement('script');
 854             Child.appendChild(createTextNode(Item.Script));
 855             MessageNode.appendChild(Child);
 856             // \93\8a\95[
 857             Child := createElement('votes');
 858             Child.appendChild(createTextNode(IntToStr(Item.Votes)));
 859             MessageNode.appendChild(Child);
 860             // \93¯\88Ó
 861             Child := createElement('agrees');
 862             Child.appendChild(createTextNode(IntToStr(Item.Agrees)));
 863             MessageNode.appendChild(Child);
 864             // \83S\81[\83X\83g
 865             Child := createElement('ghost');
 866             Child.appendChild(createTextNode(Item.Ghost));
 867             MessageNode.appendChild(Child);
 868
 869           end;
 870         end;
 871         FS := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
 872         try
 873           DOM.writeCodeAsShiftJIS(FS);
 874         finally
 875           FS.Free;
 876         end;
 877       except
 878         ShowMessage('xbtl.dat\82ð\8dÄ\83C\83\93\83X\83g\81[\83\8b\82µ\82Ä\82\82¾\82³\82¢\81B');
 879       end;
 880     finally
 881       Parser.DOMImpl.freeDocument(DOM);
 882       Parser.Free;
 883     end;
 884   finally
 885     Impl.Free;
 886   end;
 887 end;
 888
 889 procedure TBottleLogList.SetOnHTMLOutputWork(
 890   const Value: TBottleLogHTMLOutputWork);
 891 begin
 892   FOnHTMLOutputWork := Value;
 893 end;
 894
 895 procedure TBottleLogList.SetOnLoaded(const Value: TNotifyEvent);
 896 begin
 897   FOnLoaded := Value;
 898 end;
 899
 900 procedure TBottleLogList.SetOnLoadFailure(
 901   const Value: TBottleLogLoadFailureEvent);
 902 begin
 903   FOnLoadFailure := Value;
 904 end;
 905
 906 procedure TBottleLogList.SetOnLoadWork(const Value: TNotifyEvent);
 907 begin
 908   FOnLoadWork := Value;
 909 end;
 910
 911 procedure TBottleLogList.SetSelectedIndex(const Value: integer);
 912 begin
 913   FSelectedIndex := Value;
 914 end;
 915
 916 procedure TBottleLogList.SetTitle(const Value: String);
 917 begin
 918   FTitle := Value;
 919 end;
 920
 921 procedure TBottleLogList.SortBottles(LogSortType: TBottleLogSortType);
 922 begin
 923   if FOldSortColumn = LogSortType then
 924     ASortDesc := not FOldSortDesc
 925   else begin
 926     ASortDesc := false;
 927   end;
 928   ASortType := LogSortType;
 929   Self.Sort(LogCompare);
 930   FOldSortColumn := ASortType;
 931   FOldSortDesc := ASortDesc;
 932 end;
 933
 934 procedure TBottleLogList.XMLLoaded(Sener: TObject);
 935 begin
 936   Self.Assign(FXMLThread.List);
 937   if Assigned(FOnLoaded) then FOnLoaded(Self);
 938   FXMLThread := nil;
 939 end;
 940
 941 procedure TBottleLogList.XMLLoadFailure(Sender: TObject;
 942   const Message: String);
 943 begin
 944   if Assigned(FOnLoadFailure) then
 945     DoLoadFailure(Message);
 946 end;
 947
 948 { TLogXMLThread }
 949
 950 constructor TLogXMLThread.Create(FileName: String);
 951 begin
 952   inherited Create(true);
 953   FList := TObjectList.Create(false); // OwnsObject = false (!!)
 954   FFileName := FileName;
 955 end;
 956
 957 destructor TLogXMLThread.Destroy;
 958 begin
 959   FList.Free;
 960   inherited;
 961 end;
 962
 963 procedure TLogXMLThread.DoLoaded;
 964 begin
 965   if Assigned(FOnLoaded) then
 966     FOnLoaded(self);
 967 end;
 968
 969 procedure TLogXMLThread.DoLoadFailure;
 970 begin
 971   if Assigned(FOnLoadFailure) then
 972     FOnLoadFailure(self, FLoadFailureMessage);
 973 end;
 974
 975 procedure TLogXMLThread.Execute;
 976 var i, j, votes, agrees: integer;
 977     Time: TDateTime;
 978     ANode, Child: TdomElement;
 979     Item: TLogItem;
 980     DOM: TdomDocument;
 981     Parser: TXmlToDomParser;
 982     Impl: TDomImplementation;
 983     Str, mid, channel, script, ghost: String;
 984 begin
 985   FList.Clear;
 986   Impl := TDomImplementation.create(nil);
 987   try
 988     Parser := TXmlToDomParser.create(nil);
 989     Parser.DOMImpl := Impl;
 990     try
 991       try
 992         DOM := Parser.fileToDom(FFileName); //\82±\82ê\82Í\96¾\8e¦\93I\82ÉFree\82µ\82È\82\82Ä\82æ\82¢
 993         DOM.normalize;
 994         if not DOM.validate(nil, erReplace) then
 995           raise EXMLFileOpenException.Create('\97L\8cø\82È\83{\83g\83\8b\83\8d\83O\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B');
 996         with DOM do
 997         begin
 998           if DocumentElement = nil then
 999           begin
1000             FLoadFailureMessage := '\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1001              '\83\8b\81[\83g\83^\83O\82ª\82 \82è\82Ü\82¹\82ñ';
1002             Synchronize(DoLoadFailure);
1003             Exit;
1004           end;
1005           if DocumentElement.nodeName <> 'bottlelog' then
1006           begin
1007             FLoadFailureMessage := '\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1008               'bottlelog\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ';
1009             Synchronize(DoLoadFailure);
1010             Exit;
1011           end;
1012           Str :=  DocumentElement.getAttribute('version');
1013           if Str <> '1.0' then
1014           begin
1015             FLoadFailureMessage := Format('\97L\8cø\82È\8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ\81B' +
1016               '\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]);
1017             Synchronize(DoLoadFailure);
1018             Exit;
1019           end;
1020           for i := 0 to DocumentElement.childNodes.length-1 do
1021           begin
1022             if documentElement.childNodes.item(i).nodeType <> ntElement_Node then
1023               Continue;
1024             ANode := documentElement.childNodes.item(i) as TdomElement;
1025             if ANode.nodeName <> 'message' then
1026               Continue;
1027             mid := ANode.getAttribute('mid');
1028             channel := '';
1029             script := '';
1030             ghost := '';
1031             votes := 0;
1032             agrees := 0;
1033             Time := Now;
1034             for j := 0 to ANode.childNodes.length-1 do
1035             begin
1036               if ANode.childNodes.item(j).nodeType <> ntElement_Node then
1037                 Continue;
1038               Child := ANode.childNodes.item(j) as TdomElement;
1039               if Child.nodeName = 'channel' then
1040                 channel := Trim(Child.textContent)
1041               else if Child.nodeName = 'script' then
1042                 script := Trim(Child.textContent)
1043               else if Child.nodeName = 'ghost' then
1044                 ghost := Trim(Child.textContent)
1045               else if Child.nodeName = 'votes' then
1046                 votes := StrToIntDef(Child.textContent, 0)
1047               else if Child.nodeName = 'agrees' then
1048                 agrees := StrToIntDef(Child.textContent, 0)
1049               else if Child.nodeName = 'date' then
1050                 TryStrToDateTime(Trim(Child.textContent), Time);
1051             end;
1052             Item := TLogItem.Create(ltBottle, mid, channel, script, ghost, time);
1053             Item.Votes  := votes;
1054             Item.Agrees := agrees;
1055             Item.State := lsOpened;
1056             try
1057               FList.Add(Item);
1058             except
1059               Item.Free;
1060             end;
1061           end;
1062           Synchronize(DoLoaded);
1063         end;
1064       except
1065         on E: EParserException do
1066         begin
1067           FLoadFailureMessage := 'XML\89ð\90Í\83G\83\89\81[\81B' + E.Message;
1068           Synchronize(DoLoadFailure);
1069           Exit;
1070         end;
1071         on E: Exception do
1072         begin
1073           FLoadFailureMessage := 'XML\83I\81[\83v\83\93\8e\9e\82É\83G\83\89\81[\82ª\94\90¶\82µ\82Ü\82µ\82½\81B' +
1074             E.Message;
1075           Synchronize(DoLoadFailure);
1076           Exit;
1077         end;
1078       end;
1079     finally
1080       Parser.DOMImpl.freeDocument(DOM);
1081       Parser.Free;
1082     end;
1083   finally
1084     Impl.Free;
1085   end;
1086 end;
1087
1088 procedure TLogXMLThread.SetOnLoaded(const Value: TNotifyEvent);
1089 begin
1090   FOnLoaded := Value;
1091 end;
1092
1093 procedure TLogXMLThread.SetOnLoadFailure(const Value: TBottleLogLoadFailureEvent);
1094 begin
1095   FOnLoadFailure := Value;
1096 end;
1097
1098 end.