uses
Contnrs, Controls, Classes, SysUtils, Dialogs, Forms, HttpThread, BottleDef,
- DateUtils, XDOM_2_3_J3;
+ DateUtils, SsParser, XDOM_2_3_J3, Graphics, SppList;
type
TBottleLogSortType = (stLogTime, stChannel, stGhost, stScript, stVote, stAgree);
TBottleLogLoadFailureEvent = procedure(Sender: TObject; const Message: String) of object;
+ TBottleLogHTMLOutputWork = procedure(Sender: TObject; const Count: integer;
+ var Canceled: boolean) of object;
EXMLFileOpenException = class(Exception);
- TBottleLogDownLoadCondition = packed record
+ TBottleLogDownloadCondition = packed record
IsRange: boolean;
RecentCount: integer;
DateLo: TDateTime;
destructor Destroy; override;
end;
+ THTMLOutputUseColor = (ucUse, ucNoUse);
+ THTMLOutputImageType = (itNone, itBMP, itPNG, itJPG);
+ THTMLOutputRange = (orAll, orUpward, orSelected);
+
+ THTMLOutputOptions = record
+ ImageDir: String;
+ UseColor: THTMLOutputUseColor;
+ ImageType: THTMLOutputImageType;
+ end;
+
TBottleLogList = class(TObjectList)
private
FOnLoaded: TNotifyEvent;
FOldSortColumn: TBottleLogSortType; // \83\8d\83O\91\8b
FOldSortDesc: boolean; // \83\8d\83O\91\8b
FSelectedIndex: integer;
+ FLastDownloadCondition: TBottleLogDownloadCondition;
FOnLoadWork: TNotifyEvent; // \83\8d\83O\91\8b
+ FImagePath: String; // HTML\8fo\97Í\8e\9e\82ÌIMG\83^\83O\82Ì\83p\83X(\91\8a\91Î\82Ü\82½\82Í\90â\91Î\83p\83X)
+ FImageFiles: TStringList;
+ FOnHTMLOutputWork: TBottleLogHTMLOutputWork; // \8fd\95¡\89æ\91\9c\8fo\97Í\82µ\82È\82¢\82½\82ß\82Ì\83`\83F\83b\83J
function GetBottles(Index: integer): TLogItem;
procedure SetOnLoaded(const Value: TNotifyEvent);
procedure SetSelectedIndex(const Value: integer);
procedure SetOnLoadWork(const Value: TNotifyEvent);
procedure DoLoadFailure(const ErrorMessage: String);
+ function ColorToHex(const Col: TColor): String;
+ procedure PrintHTMLBottle(Strs: TStringList; Bottle: TLogItem;
+ SsParser: TSsParser; const Options: THTMLOutputOptions);
+ function PrintSurfaceImage(Strs: TStringList; const Ghost: String; ID: integer;
+ const Options: THTMLOutputOptions): boolean;
+ procedure SetOnHTMLOutputWork(const Value: TBottleLogHTMLOutputWork);
public
constructor Create(const Title: String);
destructor Destroy; override;
const WithChannel: boolean = false);
procedure SaveToXMLFile(const FileName: String);
procedure LoadFromXMLFile(const FileName: String);
- procedure SaveToHTML(const FileName: String);
+ procedure SaveToHTML(const FileName: String;
+ const Options: THTMLOutputOptions; SsParser: TSsParser);
+ procedure ExtractUniqueChannels(Target: TStrings);
+ procedure ExtractUniqueGhosts(Target: TStrings);
+ property OnHTMLOutputWork: TBottleLogHTMLOutputWork read FOnHTMLOutputWork write SetOnHTMLOutputWork;
end;
var
////////////////////////////////////////////////////////////////////////////////
implementation
+uses StrUtils;
+
function LogCompare(Item1, Item2: Pointer): Integer;
var
Log1, Log2: TLogItem;
end;
end;
+function TBottleLogList.ColorToHex(const Col: TColor): String;
+var
+ RGB: integer;
+ R, G, B: byte;
+begin
+ RGB := ColorToRGB(Col);
+ R := RGB and $FF;
+ G := (RGB and $FF00) shr 8;
+ B := (RGB and $FF0000) shr 16;
+ RGB := (R shl 16) or (G shl 8) or B;
+ Result := '#' + IntToHex(RGB, 6);
+end;
+
constructor TBottleLogList.Create(const Title: String);
begin
inherited Create;
if Assigned(FOnLoadFailure) then FOnLoadFailure(self, ErrorMessage);
end;
+procedure TBottleLogList.ExtractUniqueChannels(Target: TStrings);
+var i: integer;
+begin
+ // \82±\82Ì\83\8d\83O\92\86\82Ì\83`\83\83\83\93\83l\83\8b\82ð\8eæ\82è\8fo\82·
+ // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
+ for i := 0 to Count-1 do
+ if Target.IndexOf(Bottles[i].Channel) < 0 then
+ if Bottles[i].Channel <> '' then
+ Target.Add(Bottles[i].Channel);
+end;
+
+procedure TBottleLogList.ExtractUniqueGhosts(Target: TStrings);
+var i: integer;
+begin
+ // \82±\82Ì\83\8d\83O\92\86\82Ì\83S\81[\83X\83g\82ð\8eæ\82è\8fo\82·
+ // TStrings\82Ì\8eÀ\91\95\82ÍTHashedStringList\90\84\8f§
+ for i := 0 to Count-1 do
+ if Target.IndexOf(Bottles[i].Ghost) < 0 then
+ if Bottles[i].Ghost <> '' then
+ Target.Add(Bottles[i].Ghost);
+end;
+
function TBottleLogList.GetBottles(Index: integer): TLogItem;
begin
Result := Items[Index] as TLogItem;
procedure TBottleLogList.LoadFromStream(Stream: TStream);
var i: integer;
+ agree: integer;
+ vote: integer;
SourceStream: TStringStream;
Source: TStringList;
LogItem: TLogItem;
end;
Self.Clear;
while (i + 7) < Source.Count do begin
- LogItem := TLogItem.Create(ltBottle, Source[i+1], Source[i+2],
- Source[i+7], Source[i+3], S2D(Source[i]));
- LogItem.Votes := StrToInt(Source[i+5]);
- LogItem.Agrees := StrToInt(Source[i+6]);
- LogItem.State := lsOpened;
+ vote := StrToInt(Source[i+5]);
+ agree := StrToInt(Source[i+6]);
+
+ //\93\8a\95[\81E\93¯\88Ó\8fð\8c\8f\8ew\92è\82Í\82±\82±\82Å\8eÀ\8c»
+ //FIXME FIXME - \97Í\8bZ\82·\82¬\82Ü\82·\81A\81A\81A
+ if vote >= FLastDownloadCondition.MinVote then begin
+ if agree >= FLastDownloadCondition.MinAgree then begin
+ LogItem := TLogItem.Create(ltBottle, Source[i+1], Source[i+2],
+ Source[i+7], Source[i+3], S2D(Source[i]));
+
+ LogItem.Votes := vote;
+ LogItem.Agrees := agree;
+ LogItem.State := lsOpened;
+ Self.Add(LogItem);
+ end;
+ end;
+
i := i + 8;
- Self.Add(LogItem);
end;
finally
SourceStream.Free;
begin
Self.Clear;
AddSystemLog('\83_\83E\83\93\83\8d\81[\83h\92\86\82Å\82· - \83T\81[\83o\82©\82ç\89\9e\93\9a\91Ò\82¿');
+
+ FLastDownloadCondition := Cond;
with Cond do begin
if Cond.IsRange then begin
Param := Format('year_lo=%d&month_lo=%d&day_lo=%d&year_hi=%d&month_hi=%d&day_hi=%d&',
end else begin
Param := Format('recent=%d&', [RecentCount]);
end;
- Param := Param + Format('minvote=%d&minagree=%d&channel=%s&sort=timedesc&delimiter=%%0D%%0A',
- [MinVote, MinAgree, ParamsEncode(Channel)]);
+ Param := Param + Format('channel=%s&sort=timedesc&delimiter=%%0D%%0A',
+ [ParamsEncode(Channel)]);
end;
- FHttpThread := THTTPDownloadThread.Create(BottleServer, Pref.CgiFetchLog, Param);
+ FHttpThread := THTTPDownloadThread.Create(Pref.BottleServer, Pref.CgiFetchLog, Param);
if Pref.UseHttpProxy then begin
FHttpThread.ProxyServer := Pref.ProxyAddress;
FHttpThread.ProxyPort := Pref.ProxyPort;
+ if Pref.ProxyNeedAuthentication then begin
+ FHttpThread.ProxyUser := Pref.ProxyUser;
+ FHttpThread.ProxyPass := Pref.ProxyPass;
+ end;
end;
FHttpThread.FreeOnTerminate := true;
FHttpThread.OnSuccess := HttpSuccess;
end;
end;
-procedure TBottleLogList.SaveToHTML(const FileName: String);
+procedure TBottleLogList.PrintHTMLBottle(Strs: TStringList;
+ Bottle: TLogItem; SsParser: TSsParser; const Options: THTMLOutputOptions);
+var
+ i: integer;
+ InScope1, InSync: boolean;
+ Talk, Tag: String;
+ sur0, sur1, sur: integer;
+ procedure TalkEnd;
+ var Cl: String;
+ begin
+ if Talk = '' then
+ Exit;
+ if InSync then Cl := 'synchronized'
+ else if InScope1 then Cl := 'scope1'
+ else Cl := 'scope0';
+ if Options.ImageType = itNone then
+ begin
+ with Strs do
+ begin
+ Add(' <tr class="' + Cl + '">');
+ Add(' <td class="talk">' + XMLEntity(Talk) + '</td>');
+ Add(' </tr>');
+ end;
+ end else
+ begin
+ with Strs do
+ begin
+ Add(' <tr class="' + Cl + '">');
+ Add(' <td class="surface">');
+ if InSync then
+ begin
+ PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
+ PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
+ end else if InScope1 then
+ begin
+ PrintSurfaceImage(Strs, Bottle.Ghost, Sur1, Options);
+ end else
+ begin
+ PrintSurfaceImage(Strs, Bottle.Ghost, Sur0, Options);
+ end;
+ Add(' </td>');
+ Add(' <td class="talk">' + Talk + '</td>');
+ Add(' </tr>');
+ end;
+ end;
+ Talk := '';
+ end; // of sub-procedure TalkEnd
+begin
+ SsParser.EscapeInvalidMeta := false;
+ SsParser.LeaveEscape := false;
+ SsParser.InputString := Bottle.Script;
+ InScope1 := false;
+ InSync := false;
+ sur0 := 0;
+ sur1 := 10;
+ for i := 0 to SsParser.Count-1 do
+ case SsParser.MarkUpType[i] of
+ mtStr, mtMeta:
+ Talk := Talk + XMLEntity(SsParser.Str[i]);
+ mtTag:
+ begin
+ Tag := SsParser.Str[i];
+ if (Tag = '\h') then
+ begin
+ if InScope1 and not InSync then
+ TalkEnd;
+ InScope1 := false;
+ end else if (Tag = '\u') then
+ begin
+ if not InScope1 and not InSync then
+ TalkEnd;
+ InScope1 := true;
+ end else if Tag = '\_s' then
+ begin
+ TalkEnd;
+ InSync := not InSync;
+ end else if SsParser.Match(Tag, '\s%d') = 3 then
+ begin
+ TalkEnd;
+ sur := Ord(Tag[3]) - Ord('0');
+ if InSync then
+ begin
+ sur0 := sur;
+ sur1 := sur;
+ end else if InScope1 then
+ sur1 := sur
+ else
+ sur0 := sur;
+ end else if (SsParser.Match(Tag, '\s[%D]') > 0) or (Tag = '\s[-1]') then
+ begin
+ TalkEnd;
+ sur := StrToInt(SsParser.GetParam(Tag, 1));
+ if InSync then
+ begin
+ sur0 := sur;
+ sur1 := sur;
+ end else if InScope1 then
+ sur1 := sur
+ else
+ sur0 := sur;
+ end else if SsParser.Match(Tag, '\n') >= 2 then
+ begin
+ if Talk <> '' then
+ Talk := Talk + '<br>';
+ end else if Tag = '\c' then
+ begin
+ TalkEnd;
+ end;
+ end;
+ end;
+ TalkEnd;
+end;
+
+function TBottleLogList.PrintSurfaceImage(Strs: TStringList; const Ghost: String;
+ ID: integer; const Options: THTMLOutputOptions): boolean;
+var
+ Bmp: TBitmap;
+ Path, Ext, Name: String;
+begin
+ Result := false;
+ if (ID < 0) or (Ghost = '') then
+ Exit;
+ Ext := 'bmp';
+ Name := Format('%s,%d.%s', [SafeFileName(Ghost), ID, Ext]);
+ if FImageFiles.IndexOf(Name) >= 0 then
+ begin
+ Strs.Add(Format(' <img src="%s\%s" alt="%s,%d">',
+ [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
+ Result := true;
+ end else
+ begin
+ Bmp := TBitmap.Create;
+ try
+ if Spps.TryGetImage(Ghost, ID, Bmp) then
+ begin
+ Path := Options.ImageDir + PathDelim + Name;
+ Bmp.SaveToFile(Path);
+ Strs.Add(Format(' <img src="%s\%s" alt="%s,%d">',
+ [FImagePath, XMLEntity(Name), XMLEntity(Ghost), ID]));
+ Result := true;
+ FImageFiles.Add(Name); // \8e\9f\89ñ\82©\82ç\8cÄ\82Ñ\8fo\82³\82È\82\82Ä\82¢\82¢\82æ\82¤\82É\82·\82é
+ end else
+ Strs.Add(Format(' [%d]', [ID]));
+ finally
+ Bmp.Free;
+ end;
+ end;
+end;
+
+procedure TBottleLogList.SaveToHTML(const FileName: String;
+ const Options: THTMLOutputOptions; SsParser: TSsParser);
var
i: integer;
Strs: TStringList;
+ ChannelAndGhost: String;
+ Cancel: boolean;
begin
- Strs := TStringList.Create;
+ if ExtractFilePath(FileName) = ExtractFilePath(Options.ImageDir) then
+ FImagePath := ExtractFileName(Options.ImageDir)
+ else
+ FImagePath := Options.ImageDir;
+
+ Screen.Cursor := crHourGlass;
+ FImageFiles := TStringList.Create;
try
- with Strs do
- begin
- Add('<html>');
- for i := 0 to Self.Count-1 do
+ Strs := TStringList.Create;
+ try
+ with Strs do
begin
- Add('<table class="bottle">');
- Add(' <tr>');
- Add(' <td>' + Bottles[i].Script + '</td>');
- Add(' </tr>');
- Add('</table>');
+ Add('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN">');
+ Add('<html>');
+ Add('<style type="text/css"><!--');
+ Add('table.bottle td{font-family: monospace}');
+ if Options.UseColor = ucUse then
+ begin
+ Add(Format('p.bottleattr {color: %s}', [ColorToHex(Pref.TalkColorH)]));
+ Add(Format('body {background-color: %s}', [ColorToHex(Pref.BgColor)]));
+ Add(Format('table.bottle tr.scope0 td.talk{color: %s}', [ColorToHex(Pref.TalkColorH)]));
+ Add(Format('table.bottle tr.scope1 td.talk{color: %s}', [ColorToHex(Pref.TalkColorU)]));
+ Add(Format('table.bottle tr.synchronized td.talk{color: %s}', [ColorToHex(Pref.TalkColorS)]));
+ Add('table.bottle td.surface {text-align: center}');
+ end;
+ Add('--></style>');
+ for i := 0 to Self.Count-1 do
+ begin
+ if Assigned(FOnHTMLOutputWork) then
+ begin
+ Cancel := false;
+ FOnHTMLOutputWork(Self, i, Cancel);
+ if Cancel then
+ Exit;
+ end;
+ if Bottles[i].Ghost <> '' then
+ ChannelAndGhost := XMLEntity(Bottles[i].Channel) + '/' + XMLEntity(Bottles[i].Ghost)
+ else
+ ChannelAndGhost := XMLEntity(Bottles[i].Channel);
+ Add(Format('<p class="bottleattr">%s %s \93\8a\95[%d \93¯\88Ó%d</p>', [
+ FormatDateTime('yyyy/mm/dd hh:nn:ss', Bottles[i].LogTime),
+ ChannelAndGhost,
+ Bottles[i].Votes,
+ Bottles[i].Agrees
+ ]));
+ Add('<table class="bottle">');
+ PrintHTMLBottle(Strs, Bottles[i], SsParser, Options);
+ Add('</table>');
+ Add('<hr>');
+ end;
+ Add('</html>');
+ SaveToFile(FileName);
end;
- Add('</html>');
- SaveToFile(FileName);
+ finally
+ Strs.Free;
end;
finally
- Strs.Free;
+ FImageFiles.Free;
+ Screen.Cursor := crArrow;
end;
end;
end;
end;
+procedure TBottleLogList.SetOnHTMLOutputWork(
+ const Value: TBottleLogHTMLOutputWork);
+begin
+ FOnHTMLOutputWork := Value;
+end;
+
procedure TBottleLogList.SetOnLoaded(const Value: TNotifyEvent);
begin
FOnLoaded := Value;
OSDN Git Service
