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