PasToHtml

unit PasToHtml;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

const
  aRes: array [0..93] of string =
    (
     ('absolute'),
     ('abstract'),
     ('and'),
     ('array'),
     ('as'),
     ('asm'),
     ('assembler'),
     ('begin'),
     ('case'),
     ('cdecl'),
     ('class'),
     ('const'),
     ('constructor'),
     ('contains'),
     ('default'),
     ('destructor'),
     ('dispid'),
     ('dispinterface'),
     ('div'),
     ('do'),
     ('downto'),
     ('dynamic'),
     ('else'),
     ('end'),
     ('except'),
     ('export'),
     ('exports'),
     ('external'),
     ('far'),
     ('file'),
     ('finalization'),
     ('finally'),
     ('for'),
     ('forward'),
     ('function'),
     ('goto'),
     ('if'),
     ('implementation'),
     ('in'),
     ('inherited'),
     ('initialization'),
     ('inline'),
     ('interface'),
     ('is'),
     ('label'),
     ('library'),
     ('message'),
     ('mod'),
     ('near'),
     ('nil'),
     ('not'),
     ('object'),
     ('of'),
     ('on'),
     ('or'),
     ('out'),
     ('overload'),
     ('override'),
     ('package'),
     ('packed'),
     ('pascal'),
     ('private'),
     ('procedure'),
     ('program'),
     ('property'),
     ('protected'),
     ('public'),
     ('published'),
     ('raise'),
     ('record'),
     ('register'),
     ('reintroduce'),
     ('repeat'),
     ('requires'),
     ('resourcestring'),
     ('safecall'),
     ('set'),
     ('shl'),
     ('shr'),
     ('stdcall'),
     ('string'),
     ('then'),
     ('threadvar'),
     ('to'),
     ('try'),
     ('type'),
     ('unit'),
     ('until'),
     ('uses'),
     ('var'),
     ('virtual'),
     ('while'),
     ('with'),
     ('xor')
     );

  blank = ' ';

  aSpecial: array [0..22] of string =
    (
     ('#'),
     ('$'),
     ('&'),
     (#39), // aspa simples
     ('('),
     (')'),
     ('*'),
     ('+'),
     (','),
     ('-'),
     ('.'),
     ('/'),
     (':'),
     (';'),
     ('<'),
     ('='),
     ('>'),
     ('@'),
     ('['),
     (']'),
     ('^'),
     ('{'),
     ('}')
//     ('(*'),
//     ('(.'),
//     ('*)'),
//     ('.)'),
//     ('..'),
//     ('//'),
//     (':='),
//     ('<='),
//     ('>='),
//     ('<>')
     );

type
  TPasToHtmlOperation=class(TComponent)
  private
    nextIsComment,
    nextIsAsm: boolean;
    commentby: string;

    backcor: string;
    cor: string[7];

    antes: array [0..7] of string;
    depois: array [0..7] of string;
    
    FFileName: string;
    FIdentifierColor: TColor;
    FBackgroundColor: TColor;
    FCommentFont: TFont;
    FUserStyle: Boolean;
    FFontSize: Integer;
    FFontName: string;
    FReservedFont: TFont;
    FSymbolFont: TFont;
    FStringFont: TFont;
    FNumberFont: TFont;
    FAssemblerFont: TFont;
    procedure SetCommentFont(const Value: TFont);
    function changeline(str: string):string;
    procedure antes_depois(ind: byte; cor: string; bo,it,un: boolean);
    procedure changepas(var list: TStringList);
    procedure SetFontName(const Value: string);
    procedure SetFontSize(const Value: Integer);
  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    procedure Execute(const ToFileName:string);
  published
    property FileName:string read FFileName write FFileName;
    property UserStyle:Boolean read FUserStyle write FUserStyle;
    property FontName:string read FFontName write SetFontName;
    property FontSize:Integer read FFontSize write SetFontSize;
    property BackgroundColor:TColor read FBackgroundColor write FBackgroundColor;
    property CommentFont:TFont read FCommentFont write SetCommentFont;
    property ReservedFont:TFont read FReservedFont write FReservedFont;
    property IdentifierColor:TColor read FIdentifierColor write FIdentifierColor;
    property SymbolFont:TFont read FSymbolFont write FSymbolFont;
    property StringFont:TFont read FStringFont write FStringFont;
    property NumberFont:TFont read FNumberFont write FNumberFont;
    property AssemblerFont:TFont read FAssemblerFont write FAssemblerFont;
  end;

implementation


function ColorToHtmlColor(cor: TColor):string;
begin
  result := inttohex(cor,6);
  result := '#' + result[5] + result[6] + result[3] + result[4] + result[1] + result[2];
end;

function foundinres(pal: string):boolean;
var
  g: integer;
begin
  result := false;
  for g := 0 to length(aRes) - 1 do
    if UpperCase(aRes[g]) = UpperCase(pal) then begin
      result := true;
      break;
    end;
end;

function isSpecial(ch: string):boolean;
var
  s: integer;
begin
  result := false;
  for s := 0 to length(aSpecial) - 1 do
    if ch = aSpecial[s] then begin
      result := true;
      break;
    end;
end;

function IsNumber(ch: char):boolean;
begin
  if ch in ['0'..'9'] then
    result := true
  else
    result := false;
end;

{ TPasToHtmlOperation }

procedure TPasToHtmlOperation.antes_depois(ind: byte; cor: string; bo, it,
  un: boolean);
begin
  antes[ind] := '<FONT COLOR="' + cor + '">';
  depois[ind] := '</FONT>';

  if bo then begin
    antes[ind] := '<B>' + antes[ind];
    depois[ind] := depois[ind] + '</B>';
  end;
  if it then begin
    antes[ind] := '<I>' + antes[ind];
    depois[ind] := depois[ind] + '</I>';
  end;
  if un then begin
    antes[ind] := '<U>' + antes[ind];
    depois[ind] := depois[ind] + '</U>';
  end;
end;

function TPasToHtmlOperation.changeline(str: string): string;
var
  palavra,newstr: string;
  n,p,len,x: integer;
begin
  n := 1;
  palavra := '';
  len := length(str);

  if nextIsComment then begin
    p := Pos(commentby,str);
    if p > 0 then begin
      str := copy(str,1,p + length(commentby) - 1) +
             depois[1] +
             copy(str,p + length(commentby),len);
      n := p + length(depois[1]) + length(commentby);
      nextIsComment := false;
    end
    else begin
      result := str;
      exit;
    end;
  end;

  if nextIsAsm then begin
    p := Pos('END',Uppercase(str));
    if p > 0 then begin
      str := copy(str,1,p - 1) +
             depois[7] +
             copy(str,p,len);
      n := p + length(depois[7]);
      nextIsAsm := false;
    end
    else begin
      result := str;
      exit;
    end;
  end;

  len := length(str);
  while n <= len do begin
    if ((str[n] = blank)or(isSpecial(str[n]))and(str[n] <> '$')) then begin
      palavra := '';

      if str[n] = '#'  then begin
        if (char(ord(str[n - 1]) - 32) in ['A'..'Z'])or(str[n - 1] = '_') then
          inc(n)
        else begin
          x := n + 1;
          while (str[x] = '$')or(str[x] = '^')or(IsNumber(str[x]))do begin
            if str[x] = '$' then
              if IsNumber(str[x - 1]) then
                break;

            inc(x);

            if str[x - 1] = '^' then
              if str[x + 1] <> '^' then begin
                inc(x);
                break;
              end;
          end;
          str := copy(str,1,n - 1) +
                 antes[5] +
                 copy(str,n,x - n) +
                 depois[5] +
                 copy(str,x,len);
          inc(n,length(antes[5]) + length(depois[5]) + x - n - 1);
        end;
      end
      else
      if (str[n] = '/')and(str[n + 1] = '/') then begin
        str := copy(str,1,n - 1) +
               antes[1] +
               copy(str,n,len) +
               depois[1];
        break;
      end
      else
      if str[n] = '{' then begin
        newstr := copy(str,n + 1,len);
        p := Pos('}',newstr);
        if p > 0 then begin
          str := copy(str,1,n - 1) +
                 antes[1] +
                 copy(str,n,p + 1) +
                 depois[1] +
                 copy(newstr,p + 1,length(newstr));
          inc(n,length(antes[1]) + length(depois[1]) + p);
        end
        else begin
          str := copy(str,1,n - 1) +
                 antes[1] +
                 copy(str,n,length(str));
          commentby := '}';
          nextIsComment := true;
          break;
        end;
      end
      else
      if (str[n] = '(')and(str[n + 1] = '*') then begin
        newstr := copy(str,n + 2,len);
        p := Pos('*)',newstr);
        if p > 0 then begin
          str := copy(str,1,n - 1) +
                 antes[1] +
                 copy(str,n,p + 3) +
                 depois[1] +
                 copy(newstr,p + 2,length(newstr));
          inc(n,length(antes[1]) + length(depois[1]) + p + 2);
        end
        else begin
          str := copy(str,1,n - 1) +
                 antes[1] +
                 copy(str,n,length(str));
          commentby := '*)';
          nextIsComment := true;
          break;
        end;
      end
      else
      if str[n] = #39 then begin
        newstr := copy(str,n + 1,len);
        p := Pos(#39,newstr);
        if p > 0 then begin
          str := copy(str,1,n - 1) +
                 antes[5] +
                 str[n] + copy(newstr,1,p) +
                 depois[5] +
                 copy(newstr,p + 1,length(newstr));
          inc(n,length(antes[5]) + length(depois[5]) + p);
        end
        else begin
          str := copy(str,1,n - 1) +
                 antes[5] +
                 copy(str,n,length(str)) +
                 depois[5];
          break;
        end;
      end
      else
      if IsSpecial(str[n]) then begin
          x := n + 1;
          while (IsSpecial(str[x]))and
                (str[x] <> #39)and
                ((str[x] <> '(')and(str[x + 1] <> '*'))and
                (str[x] <> '{')and
                ((str[x] <> '/')and(str[x + 1] <> '/')) do begin

            inc(x);
          end;
          str := copy(str,1,n - 1) +
                 antes[4] +
                 copy(str,n,x - n) +
                 depois[4] +
                 copy(str,x,len);
          inc(n,length(antes[4]) + length(depois[4]) + x - n - 1);
      end;
    end
    else
    if (str[n] = '$')and
       ( (str[n - 1] <> '_')and(not(char(ord(str[n - 1]) - 32) in ['A'..'Z'])) ) then begin
      x := n + 1;
      while (str[x] = '$')or(IsNumber(str[x]))or
            (char(ord(str[x]) - 32) in ['A'..'F']) do
        inc(x);
      str := copy(str,1,n - 1) +
             antes[6] +
             copy(str,n,x - n) +
             depois[6] +
             copy(str,x,len);
      inc(n,length(antes[6]) + length(depois[6]) + x - n - 1);
    end
    else
    if (IsNumber(str[n]))and
       ( (str[n - 1] <> '_')and(not(char(ord(str[n - 1]) - 32) in ['A'..'Z'])) ) then begin
      x := n + 1;
      while (str[x] = '$')or(IsNumber(str[x]))or
            (char(ord(str[x]) - 32) in ['A'..'F']) do
//        if not(char(ord(str[x - 1]) - 32) in ['A'..'F']) then
          inc(x);
      str := copy(str,1,n - 1) +
             antes[6] +
             copy(str,n,x - n) +
             depois[6] +
             copy(str,x,len);
      inc(n,length(antes[6]) + length(depois[6]) + x - n - 1);
    end
    else
    if IsNumber(str[n]) then begin
      palavra := palavra + str[n];
      x := n + 1;
      while IsNumber(str[x]) do begin
        palavra := palavra + str[x];
        inc(x);
      end;
      n := x;
    end
    else begin
      palavra := palavra + str[n];

      if (foundinres(palavra))and((n = len)or(str[n + 1] = ' ')or(IsSpecial(str[n + 1]))) then begin
        if Uppercase(palavra) = 'ASM' then begin
          newstr := copy(str,n + 1,length(str));
          p := Pos('END',Uppercase(newstr));
          if p > 0 then begin
            str := copy(str,1,n - 3) +
                   antes[2] +
                   copy(str,n - 2,3) +
                   depois[2] +
                   antes[7] +
                   copy(newstr,1,p - 1) +
                   depois[7] +
                   copy(newstr,p,length(newstr));
            inc(n,length(antes[2]) + length(depois[2]) +
                  length(antes[7]) + length(depois[7]) +
                  length(newstr) - 4);
          end
          else begin
            str := copy(str,1,n - 3) +
                   antes[2] +
                   copy(str,n - 2,3) +
                   depois[2] +
                   antes[7] +
                   copy(str,n + 1,length(str));
            nextIsAsm := true;
            break;
          end;
        end
        else begin
          p := n - length(palavra) + 1;
          str := copy(str,1,p - 1) +
                 antes[2] +
                 palavra +
                 depois[2] +
                 copy(str,p + length(palavra),len);
          inc(n,length(antes[2]) + length(depois[2]));
        end;

        palavra := '';
      end;
    end;
    len := length(str);
    inc(n);
  end;
  result := str;
end;
procedure TPasToHtmlOperation.changepas(var list: TStringList);
var
  n: integer;
begin
  for n := 0 to list.count - 1 do
    list.strings[n] := changeline(list.strings[n]);
end;

constructor TPasToHtmlOperation.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FUserStyle:=True;

  FBackgroundColor:=RGB(226,186,24);
  FIdentifierColor:=RGB(0,0,0);
  
  FCommentFont:=TFont.Create;
  FCommentFont.Color:=RGB(128,128,128);

  FReservedFont:=TFont.Create;
  FReservedFont.Color:=RGB(0,0,128);
  
  FSymbolFont:=TFont.Create;
  FSymbolFont.Color:=RGB(0,0,255);

  FStringFont:=TFont.Create;
  FStringFont.Color:=RGB(128,0,128);
  
  FNumberFont:=TFont.Create;
  FNumberFont.Color:=RGB(255,0,0);

  FAssemblerFont:=TFont.Create;
  FAssemblerFont.Color:=RGB(0,128,0);

  FontSize:=3;
  FontName:='Courier New';
end;

destructor TPasToHtmlOperation.Destroy;
begin
  FCommentFont.Free;
  FReservedFont.Free;
  FSymbolFont.Free;
  FStringFont.Free;
  FNumberFont.Free;
  FAssemblerFont.Free;
  inherited Destroy;
end;

procedure TPasToHtmlOperation.Execute(const ToFileName:string);
var
  htm,pas: TStringList;
  fontcolor:string;
  Bol: boolean;
  Ita: boolean;
  Und: boolean;
  z: integer;
begin
  if not FileExists(FFileName)then begin
    ShowMessage('文件不存在！');
    exit;
  end;

  if FUserStyle then begin
    // Background
    backcor := ColorToHtmlColor(FBackgroundColor);
    // Comment
    cor := ColorToHtmlColor(FCommentFont.Color);
    Bol := fsBold in FCommentFont.Style;
    Ita := fsItalic in FCommentFont.Style;
    Und := fsUnderline in FCommentFont.Style;
    antes_depois(1,cor,bol,ita,und);
    // Reserved
    cor := ColorToHtmlColor(FReservedFont.Color);
    Bol := fsBold in FReservedFont.Style;
    Ita := fsItalic in FReservedFont.Style;
    Und := fsUnderline in FReservedFont.Style;
    antes_depois(2,cor,bol,ita,und);
    // Identifier
    fontcolor := ColorToHtmlColor(FIdentifierColor);
    // Symbol
    cor := ColorToHtmlColor(FSymbolFont.Color);
    Bol := fsBold in FSymbolFont.Style;
    Ita := fsItalic in FSymbolFont.Style;
    Und := fsUnderline in FSymbolFont.Style;
    antes_depois(4,cor,bol,ita,und);
    // String
    cor := ColorToHtmlColor(FStringFont.Color);
    Bol := fsBold in FStringFont.Style;
    Ita := fsItalic in FStringFont.Style;
    Und := fsUnderline in FStringFont.Style;
    antes_depois(5,cor,bol,ita,und);
    // Number
    cor := ColorToHtmlColor(FNumberFont.Color);
    Bol := fsBold in FNumberFont.Style;
    Ita := fsItalic in FNumberFont.Style;
    Und := fsUnderline in FNumberFont.Style;
    antes_depois(6,cor,bol,ita,und);
    // Assembler
    cor := ColorToHtmlColor(FAssemblerFont.Color);
    Bol := fsBold in FAssemblerFont.Style;
    Ita := fsItalic in FAssemblerFont.Style;
    Und := fsUnderline in FAssemblerFont.Style;
    antes_depois(7,cor,bol,ita,und); 
  end
  else begin
    backcor := '#FFFFFF';
    fontsize := 3;
    fontcolor := '#000000';
  end;

  nextIsComment := false;
  nextIsAsm := false;

  Screen.Cursor := crHourGlass;
  htm := TStringList.Create;
  pas := TStringList.Create;
  try
    try
      htm.clear;
      pas.clear;
      pas.LoadFromFile(FFileName);
      with htm do begin
        add('<HTML>');
        add('<HEAD>');
        add('<TITLE>' + FFileName + '</TITLE>');
        add('<META NAME="GENERATOR" CONTENT="Pascal To HTML by Bruno Lovatti - ' +
            formatdatetime('dd/mm/yyyy - hh:mm:ss',now) + '">');
        add('</HEAD>');

        add('<BODY BGCOLOR="' + backcor + '">');
        add('<FONT FACE="' + FCommentFont.Name +
            '" SIZE="' + inttostr(fontsize) +
            '" COLOR="' + fontcolor + '">');
        add('<A NAME=' + uppercase(extractfilename(FFileName)) +
            '><CENTER><H3>' + uppercase(extractfilename(FFileName)) + '</H3></CENTER></A>');
        add('</FONT>');
        add('<HR>');
        add('<PRE>');
        add('<FONT FACE="' + FCommentFont.Name +
            '" SIZE="' + inttostr(FFontSize) +
            '" COLOR="' + fontcolor + '">');

        if FUserStyle then
          changepas(pas);

        for z := 0 to pas.count - 1 do
          htm.add(pas.strings[z]);

        add('</FONT>');
        add('</PRE>');
        add('</BODY>');
        add('</HTML>');
        SaveToFile(ToFileName);
      end;
    except
    end;
  finally
    htm.free;
    pas.free;
    screen.cursor := crDefault;
  end;
end;


procedure TPasToHtmlOperation.SetCommentFont(const Value: TFont);
begin
  if Assigned(Value) then
    FCommentFont.Assign(Value);
end;

procedure TPasToHtmlOperation.SetFontName(const Value: string);
begin
  FFontName := Value;
  FCommentFont.Name := Value;
  FReservedFont.Name := Value;
  FSymbolFont.Name := Value;
  FStringFont.Name := Value;
  FNumberFont.Name := Value;
  FAssemblerFont.Name := Value;
end;

procedure TPasToHtmlOperation.SetFontSize(const Value: Integer);
begin
  if Value>0 then
  begin
    FFontSize := Value;
    FCommentFont.Size := Value;
    FReservedFont.Size := Value;
    FSymbolFont.Size := Value;
    FStringFont.Size := Value;
    FNumberFont.Size := Value;
    FAssemblerFont.Size := Value;
  end;
end;

end.