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