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