unit HtmlOut;

interface

uses
  Classes, Graphics, SysUtils;

type
  THtmlTag = (htHtml, htHead, htBody, htTitle, htStyle,
    htH1, htH2, htH3, htH4, htH5, htH6, htNumbering, htBulleting, htTable,
    htRow, htColumn, htPara, htBold, htItalic,
    htUnderline, htTypeWriter, htSmall);
  THtmlTags = set of THtmlTag;

  THtmlEncoding = (htmlDefault, htmlAnsi, htmlUtf8);

  THtmlWriter = class
  private
    FStream: TStream;
    FOpenTags: TList;
    {$ifdef UNICODE}
    FEncoding: TEncoding;
    {$endif}
    FHtmlEncoding: THtmlEncoding;
//    FFreeOnTerminate: Boolean;
  public
    procedure Body(Color: TColor = -1);
    procedure Bookmark(const Name: string);
    constructor Create(const FileName: string;
      aEncoding: THtmlEncoding = htmlDefault; aWriteBOM: Boolean = True); overload;
    constructor Create(Stream: TStream;
      aEncoding: THtmlEncoding = htmlDefault; aWriteBOM: Boolean = True); overload;
    destructor Destroy; override;
    function EndTag: Boolean;
    procedure Close;
    procedure Head;
    procedure HRef(const Msg, Ref: string);
    procedure Indent;
    procedure ListItem;
    procedure NewLine;
    procedure Paragraph;
    procedure Write(const S: string);
    procedure Writeln(const S: string = '');
    procedure WriteLine(const S: string = '');
    procedure Table(Spacing, Padding, Border, AWidth: Integer);
    procedure TableBg(Spacing, Padding, Border, AWidth: Integer; Color: TColor);
    procedure TableRow(Color: TColor = -1; Align: TAlignment = taLeftJustify); overload;
    procedure TableRow(const CssClass: string; Align: TAlignment = taLeftJustify); overload;
    procedure TableCol(const Msg: string; Align: TAlignment = taLeftJustify);
    procedure TableColW(const Msg: string; Width: Integer;
      Align: TAlignment = taLeftJustify);
    procedure Tag(Tag: THtmlTag);
    procedure TaggedText(const Text: string; Tags: THtmlTags);
    procedure Separator;
    procedure Unindent;
    property Stream: TStream read FStream;
  end;

const
  CrLf        = #13#10;
  NbSp        = '&nbsp;';

function GetHtmlColor(Color: TColor): string;
function HtmlEncodeStr(const ASource: string): string;
function HtmlDecodeStr(const ASource: string): string;

implementation

const
  HtmlTags: array [THtmlTag] of string =
    ('html', 'head', 'body', 'title', 'style',
      'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 'ul', 'ol', 'table', 'tr', 'td', 'p',
      'b', 'i', 'u', 'tt', 'small');

const
  SAlignes: array [TAlignment] of string = ('left', 'right', 'center');

function SeparateLineTag(Tag: THtmlTag): Boolean;
begin
  Result := Tag < htBold;
end;

function GetHtmlColor(Color: TColor): string;
begin
  Result := '"#' + LowerCase(IntToHex(Color, 6)) + '"';
end;

function HtmlEncodeStr(const ASource: string): string;
begin
  Result := StringReplace(ASource, '&',  '&amp;',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '<',  '&lt;',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '>',  '&gt;',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '"',  '&quot;',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '''', '&apos;',[rfReplaceAll]); {do not localize}
end;

function HtmlDecodeStr(const ASource: string): string;
begin
  Result := StringReplace(ASource, '&apos;', '''',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '&quot;', '"',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '&gt;',   '>',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '&lt;',   '<',[rfReplaceAll]); {do not localize}
  Result := StringReplace(Result,  '&amp;',  '&',[rfReplaceAll]); {do not localize}
end;

{ THtmlWriter }

procedure THtmlWriter.Body(Color: TColor = -1);
begin
  if Color = -1 then Write('<body>' + CrLf)
  else Write(Format('<body bgcolor=%s>' + CrLf, [GetHtmlColor(Color)]));
  FOpenTags.Add(Pointer(htBody));
end;

constructor THtmlWriter.Create(Stream: TStream;
  aEncoding: THtmlEncoding = htmlDefault; aWriteBOM: Boolean = True);
{$ifdef UNICODE}
var
  Preamble: TBytes;
{$else}
const
  Utf8Preamble: AnsiString = #$EF#$BB#$BF;
{$endif}
begin
  inherited Create;
  FStream := Stream;
  FOpenTags := TList.Create;
  FHtmlEncoding := aEncoding;
  {$ifdef UNICODE}
  FEncoding := nil;
  case aEncoding of
    htmlAnsi: FEncoding := TEncoding.ANSI;
    htmlDefault,
    htmlUtf8: FEncoding := TEncoding.UTF8;
  end;
  if aWriteBOM then begin
    Preamble := FEncoding.GetPreamble;
    if Length(Preamble) > 0 then
      FStream.WriteBuffer(Preamble[0], Length(Preamble));
  end;
  {$else}
  if aWriteBOM and (fHtmlEncoding = htmlUtf8) then
    FStream.WriteBuffer(Utf8Preamble[1], Length(Utf8Preamble));
  {$endif}
  Tag(htHtml);
end;

constructor THtmlWriter.Create(const FileName: string;
  aEncoding: THtmlEncoding = htmlDefault; aWriteBOM: Boolean = True);
begin
//  FFreeOnTerminate := True;
  Create(TFileStream.Create(FileName, fmCreate), aEncoding, aWriteBOM);
end;

destructor THtmlWriter.Destroy;
begin
  Close;
//  if FFreeOnTerminate then
    FStream.Free;
  FOpenTags.Free;
  inherited;
end;

procedure THtmlWriter.Close;
begin
  if Assigned(FOpenTags) then while EndTag do;
end;

function THtmlWriter.EndTag: Boolean;
var
  Idx: Integer;
  Tag: THtmlTag;
  S: string;
begin
  Idx := FOpenTags.Count - 1;
  if Idx >= 0 then
  begin
    Tag := THtmlTag(FOpenTags[Idx]);
    FOpenTags.Delete(Idx);
    S := '</' + HtmlTags[Tag] + '>';
    if SeparateLineTag(Tag) then S := S + CrLf;
    Write(S);
    Result := True;
  end
  else Result := False;
end;

procedure THtmlWriter.Head;
begin
  Tag(htHead);
end;

procedure THtmlWriter.Paragraph;
begin
  Write('<p>' + CrLf);
end;

procedure THtmlWriter.Separator;
begin
  Writeln('<hr>');
end;

procedure THtmlWriter.Write(const S: string);
var
{$ifdef UNICODE}
  Buffer: TBytes;
{$else}
  Buffer: AnsiString;
{$endif}
begin
  {$ifdef UNICODE}
  Buffer := FEncoding.GetBytes(S);
  FStream.WriteBuffer(Buffer[0], Length(Buffer));
  {$else}
  if FHtmlEncoding = htmlUtf8 then
    Buffer := AnsiToUtf8(S)
  else
    Buffer := S;
  FStream.WriteBuffer(Buffer[1], Length(Buffer));
  {$endif}
end;

procedure THtmlWriter.Writeln(const S: string = '');
begin
  Write(S + CrLf);
end;

procedure THtmlWriter.Tag(Tag: THtmlTag);
const
  sCharSet: array [THtmlEncoding] of string =
    {$ifdef UNICODE}
    ('utf-8', 'windows-1251', 'utf-8');
    {$else}
    ('windows-1251', 'windows-1251', 'utf-8');
    {$endif}
var
  S: string;
  P: Integer;
begin
  S := '<' + HtmlTags[Tag] + '>';
  if SeparateLineTag(Tag) then S := S + CrLf;
  Write(S);
  FOpenTags.Add(Pointer(Tag));

  if Tag = htHead then
  begin
    S := ExtractFileName(ParamStr(0));
    P := LastDelimiter('.', S);
    if P > 0 then Delete(S, P, MaxInt);
//    Writeln('<meta http-equiv="content-type" content="text/html; charset=windows-1251">');
    Writeln('<meta name="Generator" content="' + S + '">');
    Writeln(Format('<meta http-equiv="Content-Type" content="text/html; charset=%s">', [sCharSet[FHtmlEncoding]]));
    Writeln('<meta name="Author" content="Moscow Exchange (help@moex.com)">');
  end;
end;

procedure THtmlWriter.TaggedText(const Text: string; Tags: THtmlTags);
var
  Prefix, Suffix, STag: string;
  I: THtmlTag;
begin
  Prefix := '';
  Suffix := '';
  for I := Low(THtmlTag) to High(THtmlTag) do
    if I in Tags then
    begin
      Prefix := Prefix + '<' + HtmlTags[I] + '>';
      STag := '</' + HtmlTags[I] + '>';
      if SeparateLineTag(I) then STag := STag + CrLf;
      Suffix := STag + Suffix;
    end;
  Write(Prefix + Text + Suffix);
end;

procedure THtmlWriter.HRef(const Msg, Ref: string);
var
  S: string;
begin
  FmtStr(S, '<a href="%s">%s</a>', [Ref, Msg]);
  Write(S);
end;

procedure THtmlWriter.Bookmark(const Name: string);
begin
  Writeln(Format('<a name="%s"></a>', [Name]));
end;

procedure THtmlWriter.NewLine;
begin
  Write('<br>' + CrLf);
end;

procedure THtmlWriter.Table(Spacing, Padding, Border, AWidth: Integer);
begin
  Write(Format('<table cellspacing=%d cellpadding=%d border=%d width=%d%%>' +
    CrLf, [Spacing, Padding, Border, AWidth]));
  FOpenTags.Add(Pointer(htTable));
end;

procedure THtmlWriter.TableBg(Spacing, Padding, Border, AWidth: Integer; Color: TColor);
begin
  Write(Format('<table cellspacing=%d cellpadding=%d border=%d width=%d%% bgcolor=%s>' +
    CrLf, [Spacing, Padding, Border, AWidth, GetHtmlColor(Color)]));
  FOpenTags.Add(Pointer(htTable));
end;

procedure THtmlWriter.TableRow(Color: TColor = -1; Align: TAlignment = taLeftJustify);
begin
  if Color = -1 then
    if Align = taLeftJustify then Write('<tr>' + CrLf)
    else Write(Format('<tr align=%s>' + CrLf, [SAlignes[Align]]))
  else
    if Align = taLeftJustify then Write(Format('<tr bgcolor=%s>' + CrLf, [GetHtmlColor(Color)]))
    else Write(Format('<tr align=%s bgcolor=%s>' + CrLf, [SAlignes[Align], GetHtmlColor(Color)]));
  FOpenTags.Add(Pointer(htRow));
end;

procedure THtmlWriter.TableRow(const CssClass: string; Align: TAlignment = taLeftJustify);
var
  ClassAttr, AlignAttr: string;
begin
  if CssClass <> '' then
    FmtStr(ClassAttr, ' class=%s', [CssClass]);
  if Align <> taLeftJustify then
    FmtStr(AlignAttr, ' align=%s', [SAlignes[Align]]);

  Write(Format('<tr%s%s>' + CrLf, [ClassAttr, AlignAttr]));
  FOpenTags.Add(Pointer(htRow));
end;

procedure THtmlWriter.TableCol(const Msg: string; Align: TAlignment = taLeftJustify);
var
  S: string;
begin
  if Align = taLeftJustify then
    FmtStr(S, '<td>%s</td>' + CrLf, [Msg])
  else
    FmtStr(S, '<td align=%s>%s</td>' + CrLf, [SAlignes[Align], Msg]);
  Write(S);
end;

procedure THtmlWriter.TableColW(const Msg: string; Width: Integer; Align: TAlignment = taLeftJustify);
var
  S: string;
begin
  if Align = taLeftJustify then
    FmtStr(S, '<td width=%d%%>%s</td>' + CrLf, [Width, Msg])
  else
    FmtStr(S, '<td width=%d%% align=%s>%s</td>' + CrLf, [Width, SAlignes[Align], Msg]);
  Write(S);
end;

procedure THtmlWriter.Indent;
begin
  Write('<ul>' + CrLf);
end;

procedure THtmlWriter.Unindent;
begin
  Write('</ul>' + CrLf);
end;

procedure THtmlWriter.ListItem;
begin
  Write('<li>');
end;

procedure THtmlWriter.WriteLine(const S: string);
begin
  Write(S + '<br>' + CrLf);
end;

end.
