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