unit Convert;

interface

uses
  Classes, NewParse;

type
  KeywordType = (ktPascal, ktDfm);

  TCodeParser = class (TNewParser)
  public
    constructor Create (SSource, SDest: TStream);
    procedure SetKeywordType (Kt: KeywordType);
    // conversion
    procedure Convert;
  protected
    // virtual methods (mostly virtual abstract)
    procedure BeforeString; virtual; abstract;
    procedure AfterString; virtual; abstract;
    procedure BeforeKeyword; virtual; abstract;
    procedure AfterKeyword; virtual; abstract;
    procedure BeforeComment; virtual; abstract;
    procedure AfterComment; virtual; abstract;
    procedure InitFile; virtual; abstract;
    procedure EndFile; virtual; abstract;
    function CheckSpecialToken (Ch1: char): string; virtual;
    function MakeStringLegal (S: String): string; virtual;
    function MakeCommentLegal (S: String): string; virtual;
  protected
    Source, Dest: TStream;
    OutStr: string;
    FKeywords: TStrings;
    Line, Pos: Integer;
  end;

  THtmlParser = class (TCodeParser)
  public
    FileName: string;
    Copyright: string;
    Alone: Boolean;
    procedure AddFileHeader (FileName: string);
    class function HtmlHead (Filename: string): string;
    class function HtmlTail (Copyright: string): string;
  protected
    // virtual methods
    procedure BeforeString; override;
    procedure AfterString; override;
    procedure BeforeKeyword; override;
    procedure AfterKeyword; override;
    procedure BeforeComment; override;
    procedure AfterComment; override;
    procedure InitFile; override;
    procedure EndFile; override;
    function CheckSpecialToken (Ch1: char): string; override;
  end;

// functions to be used by a Wizard
function OpenProjectToHTML (Filename, Copyright: string): string;
function CurrProjectToHTML (Copyright: string): string;

implementation

uses
  ExptIntf, SysUtils, ToolIntf;

var
  PascalKeywords: TStrings;
  DfmKeywords: TStrings;

const
  Quote = '''';

//////////// class TCodeParser ////////////

constructor TCodeParser.Create (SSource, SDest: TStream);
begin
  inherited Create (SSource);
  Source := SSource;
  Dest := SDest;
  SetLength (OutStr, 10000);
  OutStr := '';
  FKeywords := PascalKeywords;
end;

procedure TCodeParser.SetKeywordType (Kt: KeywordType);
begin
  case Kt of
    ktPascal: FKeywords := PascalKeywords;
    ktDfm: FKeywords := DfmKeywords;
  else
    raise Exception.Create ('Undefined keywords type');
  end;
end;

procedure TCodeParser.Convert;
begin
  InitFile; // virtual
  Line := 1;
  Pos := 0;
  // parse the entire source file
  while Token <> toEOF do
  begin
    // if the source code line has changed,
    // add the proper newline character
    while SourceLine > Line do
    begin
      AppendStr (OutStr, #13#10);
    Inc (Line);
      Pos := Pos + 2; // 2 characters, cr+lf
    end;
    // add proper white spaces (formatting)
    while SourcePos > Pos do
    begin
      AppendStr (OutStr, ' ');
      Inc (Pos);
    end;
    // check the token
    case Token of
      toSymbol:
      begin
        // if the token is not a keyword
        if FKeywords.IndexOf (TokenString) < 0 then
          // add the plain token
          AppendStr (OutStr, TokenString)
        else
        begin
          BeforeKeyword; // virtual
          AppendStr (OutStr, TokenString);
          AfterKeyword; // virtual
        end;
      end;
      toString:
      begin
        BeforeString; // virtual
        if (Length (TokenString) = 1) and
          (Ord (TokenString [1]) < 32) then
          begin
            AppendStr (OutStr, '#' +
              IntToStr (Ord (TokenString [1])));
            if Ord (TokenString [1]) < 10 then
              Pos := Pos + 1
            else
              Pos := Pos + 2;
          end
        else
        begin
          AppendStr (OutStr, MakeStringLegal (TokenString));
          Pos := Pos + 2; // 2 x hypen
        end;
        AfterString; // virtual
      end;
      toInteger:
        AppendStr (OutStr, TokenString);
      toFloat:
        AppendStr (OutStr, TokenString);
      toComment:
      begin
        BeforeComment; // virtual
        AppendStr (OutStr, MakeCommentLegal (TokenString));
        AfterComment; // virtual
      end;
      else
        // any other token
        AppendStr (OutStr, CheckSpecialToken (Token));
    end; // case Token of
    // increase the current position
    Pos := Pos + Length (TokenString);
    // move to the next token
    NextToken;
  end; // while Token <> toEOF do
  // add final code
  EndFile; // virtual
  // add the string to the stream
  Dest.WriteBuffer (Pointer(OutStr)^, Length (OutStr));
end;

function TCodeParser.CheckSpecialToken (Ch1: char): string;
begin
  Result := Ch1; // do nothing
end;

function TCodeParser.MakeStringLegal (S: String): string;
var
  I: Integer;
begin
  if Length (S) < 1 then
  begin
    Result := Quote + Quote;
    Exit;
  end;

  // if the first character is not special,
  // add the open quote
  if S[1] > #31 then
    Result := Quote
  else
    Result := '';

  // for each character of the string
  for I := 1 to Length (S) do
    case S [I] of

      // quotes must be doubled
      Quote: begin
        AppendStr (Result, Quote + Quote);
        Pos := Pos + 1;
      end;

      // special characters (characters below the value 32)
      #0..#31: begin
        Pos := Pos + Length (IntToStr (Ord (S[I])));
        // if preceeding characters are plain ones,
        // close the string
        if (I > 1) and (S[I-1] > #31) then
          AppendStr (Result, Quote);
        // add the special character
        AppendStr (Result, '#' + IntToStr (Ord (S[I])));
        // if the following characters are plain ones,
        // open the string
        if (I < Length (S) - 1) and (S[I+1] > #31) then
          AppendStr (Result, Quote);
      end;
    else
      AppendStr (Result, CheckSpecialToken(S[I]));
  end;

  // if the last character was not special,
  // add closing quote
  if (S[Length (S)] > #31) then
    AppendStr (Result, Quote);
end;

function TCodeParser.MakeCommentLegal (S: String): string;
var
  I: Integer;
begin
  Result := '';
  // for each character of the string
  for I := 1 to Length (S) do
    AppendStr (Result, CheckSpecialToken(S[I]));
end;

//////////// class THtmlParser ////////////

procedure THtmlParser.InitFile;
begin
  if Alone then
    AppendStr (OutStr, HtmlHead (Filename));
  AddFileHeader (Filename);
  AppendStr (OutStr, '<PRE>'#13#10);
end;

procedure THtmlParser.EndFile;
begin
  AppendStr (OutStr, '</PRE>');
  if Alone then
    AppendStr (OutStr, HtmlTail (Copyright))
  else
    AppendStr (OutStr, #13#10'<HR>'#13#10#13#10); // separator
end;

procedure THtmlParser.BeforeComment;
begin
  AppendStr (OutStr, '<FONT COLOR="#000080"><I>');
end;

procedure THtmlParser.AfterComment;
begin
  AppendStr (OutStr, '</I></FONT>');
end;

procedure THtmlParser.BeforeKeyword;
begin
  AppendStr (OutStr, '<B>');
end;

procedure THtmlParser.AfterKeyword;
begin
  AppendStr (OutStr, '</B>');
end;

procedure THtmlParser.BeforeString;
begin
  // no special style...
end;

procedure THtmlParser.AfterString;
begin
  // no special style...
end;

function THtmlParser.CheckSpecialToken (Ch1: char): string;
begin
  case Ch1 of
    '<': Result := '&lt;';
    '>': Result := '&gt;';
    '&': Result := '&amp;';
    '"': Result := '&quot;';
  else
    Result := Ch1;
  end;
end;

procedure THtmlParser.AddFileHeader (FileName: string);
var
  FName: string;
begin
  FName := Uppercase (ExtractFilename (FileName));
  AppendStr (OutStr, Format (
    '<A NAME=%s><H3>%s</H3></A>' + #13#10+#13#10,
  [FName, FName]));
end;

class function THtmlParser.HtmlHead (Filename: string): string;
begin
  Result := '<HTML><HEAD>' + #13#10+
   '<TITLE>File: ' +  ExtractFileName(Filename) + '</TITLE>' + #13#10+
   '<META NAME="GENERATOR" CONTENT="PasToWeb[Marco Cantщ]">'#13#10 +
    '</HEAD>'#13#10 +
    '<BODY BGCOLOR="#FFFFFF">'#13#10;
end;

class function THtmlParser.HtmlTail (Copyright: string): string;
begin
  Result := '<HR><CENTER<I>Generated by PasToWeb,' +
    ' a tool by Marco Cant&ugrave;.<P>' + #13#10+
   Copyright + '</CENTER></I>'#13#10 + '</BODY> </HTML>';
end;

// code for the HTML Wizard

function OpenProjectToHTML (Filename, Copyright: string): string;
begin
  // open the project and get the lists...
  ToolServices.OpenProject (FileName);
  Result := CurrProjectToHTML (Copyright);
end;

function CurrProjectToHTML (Copyright: string): string;
var
  Dest, Source, BinSource: TStream;
  HTML, FileName, Ext, FName: string;
  I: Integer;
  Parser: THtmlParser;
begin
  // initialize
  FileName := ToolServices.GetProjectName;
  Result := ChangeFileExt (FileName, '_dpr') + '.htm';
  Dest := TFileStream.Create (Result,
    fmCreate or fmOpenWrite);
  try
    // add head
    HTML := '<HTML><HEAD>' + #13#10+
     '<TITLE>Project: ' +  ExtractFileName (Filename) +
        '</TITLE>' + #13#10+
     '<META NAME="GENERATOR" CONTENT="PasToHTML[Marco Cantщ]">' + #13#10+
     '</HEAD>'#13#10 +
      '<BODY BGCOLOR="#FFFFFF">'#13#10 +
      '<H1><CENTER>Project: ' + FileName +
      '</CENTER></H1><BR><BR><HR>'#13#10;
    AppendStr (HTML, '<UL>'#13#10);
    // units list
    for I := 0 to ToolServices.GetUnitCount - 1 do
    begin
      Ext := Uppercase (ExtractFileExt(
        ToolServices.GetUnitName(I)));
      FName := Uppercase (ExtractFilename (
        ToolServices.GetUnitName(I)));
      if (Ext <> '.RES') and (Ext <> '.DOF') then
        AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' +
          FName + '</A>'#13#10);
    end;
    // forms list
    for I := 0 to ToolServices.GetFormCount - 1 do
    begin
      FName := Uppercase (ExtractFilename (
        ToolServices.GetFormName(I)));
      AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' +
        FName + '</A>'#13#10);
    end;
    AppendStr (HTML, '</UL>'#13#10);
    AppendStr (HTML, '<HR>'#13#10);
    // add the HTML string to the output buffer
    Dest.WriteBuffer (Pointer(HTML)^, Length (HTML));

    // generate the HTML code for the units
    for I := 0 to ToolServices.GetUnitCount - 1 do
    begin
      Ext := Uppercase (ExtractFileExt(
        ToolServices.GetUnitName(I)));
      if (Ext <> '.RES') and (Ext <> '.DOF') then
      begin
        Source := TFileStream.Create (
          ToolServices.GetUnitName(I), fmOpenRead);
        Parser := THtmlParser.Create (Source, Dest);
        try
          Parser.Alone := False;
          Parser.Filename := ToolServices.GetUnitName(I);
          Parser.Convert;
        finally
          Parser.Free;
          Source.Free;
        end;
      end; // if
    end; // for

    // generate the HTML code for forms
    for I := 0 to ToolServices.GetFormCount - 1 do
    begin
      // convert the DFM file to text
      BinSource := TFileStream.Create (
        ToolServices.GetFormName(I), fmOpenRead);
      Source := TMemoryStream.Create;
      ObjectResourceToText (BinSource, Source);
      Source.Position := 0;
      Parser := THtmlParser.Create (Source, Dest);
      try
        Parser.Alone := False;
        Parser.Filename := ToolServices.GetFormName(I);
        Parser.SetKeywordType (ktDfm);
        Parser.Convert;
      finally
        Parser.Free;
        BinSource.Free;
        Source.Free;
      end;
    end; // for

    // add the tail of the HTML file
    HTML :=
      '<BR><I><CENTER>HTML file generated by PasToWeb, a tool by Marco Cant&ugrave;<BR>'#13#10 +
      Copyright + '</CENTER></I>'#13#10 +
      '</BODY> </HTML>';
    Dest.WriteBuffer (Pointer(HTML)^, Length (HTML));
  finally
    Dest.Free;
  end;
end;

initialization
  PascalKeywords := TStringList.Create;
  DfmKeywords := TStringList.Create;

  // Pascal Keywords
  PascalKeywords.Add ('absolute');
  PascalKeywords.Add ('abstract');
  PascalKeywords.Add ('and');
  PascalKeywords.Add ('array');
  PascalKeywords.Add ('as');
  PascalKeywords.Add ('asm');
  PascalKeywords.Add ('assembler');
  PascalKeywords.Add ('at');
  PascalKeywords.Add ('automated');
  PascalKeywords.Add ('begin');
  PascalKeywords.Add ('case');
  PascalKeywords.Add ('cdecl');
  PascalKeywords.Add ('class');
  PascalKeywords.Add ('const');
  PascalKeywords.Add ('constructor');
  PascalKeywords.Add ('contains');
  PascalKeywords.Add ('default');
  PascalKeywords.Add ('destructor');
  PascalKeywords.Add ('dispid');
  PascalKeywords.Add ('dispinterface');
  PascalKeywords.Add ('div');
  PascalKeywords.Add ('do');
  PascalKeywords.Add ('downto');
  PascalKeywords.Add ('dynamic');
  PascalKeywords.Add ('else');
  PascalKeywords.Add ('end');
  PascalKeywords.Add ('except');
  PascalKeywords.Add ('exports');
  PascalKeywords.Add ('external');
  PascalKeywords.Add ('file');
  PascalKeywords.Add ('finalization');
  PascalKeywords.Add ('finally');
  PascalKeywords.Add ('for');
  PascalKeywords.Add ('forward');
  PascalKeywords.Add ('function');
  PascalKeywords.Add ('goto');
  PascalKeywords.Add ('if');
  PascalKeywords.Add ('implementation');
  PascalKeywords.Add ('in');
  PascalKeywords.Add ('index');
  PascalKeywords.Add ('inherited');
  PascalKeywords.Add ('initialization');
  PascalKeywords.Add ('inline');
  PascalKeywords.Add ('interface');
  PascalKeywords.Add ('is');
  PascalKeywords.Add ('label');
  PascalKeywords.Add ('library');
  PascalKeywords.Add ('message');
  PascalKeywords.Add ('mod');
//  PascalKeywords.Add ('name');
  PascalKeywords.Add ('nil');
  PascalKeywords.Add ('nodefault');
  PascalKeywords.Add ('not');
  PascalKeywords.Add ('object');
  PascalKeywords.Add ('of');
  PascalKeywords.Add ('on');
  PascalKeywords.Add ('or');
  PascalKeywords.Add ('override');
  PascalKeywords.Add ('packed');
  PascalKeywords.Add ('pascal');
  PascalKeywords.Add ('private');
  PascalKeywords.Add ('procedure');
  PascalKeywords.Add ('program');
  PascalKeywords.Add ('property');
  PascalKeywords.Add ('protected');
  PascalKeywords.Add ('public');
  PascalKeywords.Add ('published');
  PascalKeywords.Add ('raise');
  PascalKeywords.Add ('read');
  PascalKeywords.Add ('record');
  PascalKeywords.Add ('register');
  PascalKeywords.Add ('repeat');
  PascalKeywords.Add ('requires');
  PascalKeywords.Add ('resident');
  PascalKeywords.Add ('set');
  PascalKeywords.Add ('shl');
  PascalKeywords.Add ('shr');
  PascalKeywords.Add ('stdcall');
  PascalKeywords.Add ('stored');
  PascalKeywords.Add ('string');
  PascalKeywords.Add ('then');
  PascalKeywords.Add ('threadvar');
  PascalKeywords.Add ('to');
  PascalKeywords.Add ('try');
  PascalKeywords.Add ('type');
  PascalKeywords.Add ('unit');
  PascalKeywords.Add ('until');
  PascalKeywords.Add ('uses');
  PascalKeywords.Add ('var');
  PascalKeywords.Add ('virtual');
  PascalKeywords.Add ('while');
  PascalKeywords.Add ('with');
  PascalKeywords.Add ('write');
  PascalKeywords.Add ('xor');

  // DFm keywords
  DfmKeywords.Add ('object');
  DfmKeywords.Add ('end');

finalization
  PascalKeywords.Free;
end.

unit NewParse;

interface

uses
  Classes, SysUtils, Consts;

const
  toComment = Char(5);

type
  TNewParser = class(TObject)
  private
    FStream: TStream;
    FOrigin: Longint;
    FBuffer: PChar;
    FBufPtr: PChar;
    FBufEnd: PChar;
    FSourcePtr: PChar;
    FSourceEnd: PChar;
    FTokenPtr: PChar;
    FStringPtr: PChar;
    FSourceLine: Integer;
    FSaveChar: Char;
    FToken: Char;
    procedure ReadBuffer;
    procedure SkipBlanks;
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    procedure CheckToken(T: Char);
    procedure CheckTokenSymbol(const S: string);
    procedure Error(const Ident: string);
    procedure ErrorFmt(const Ident: string; const Args: array of const);
    procedure ErrorStr(const Message: string);
    procedure HexToBinary(Stream: TStream);
    function NextToken: Char;
    function SourcePos: Longint;
    function TokenComponentIdent: String;
    function TokenFloat: Extended;
    function TokenInt: Longint;
    function TokenString: string;
    function TokenSymbolIs(const S: string): Boolean;
    property SourceLine: Integer read FSourceLine;
    property Token: Char read FToken;
  end;

implementation

const
  ParseBufSize = 4096;

procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     EDX,0
        JMP     @@1
@@0:    DB      '0123456789ABCDEF'
@@1:    LODSB
        MOV     DL,AL
        AND     DL,0FH
        MOV     AH,@@0.Byte[EDX]
        MOV     DL,AL
        SHR     DL,4
        MOV     AL,@@0.Byte[EDX]
        STOSW
        DEC     ECX
        JNE     @@1
        POP     EDI
        POP     ESI
end;

function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
asm
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     EBX,EDX
        MOV     EDX,0
        JMP     @@1
@@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
        DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
        DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
        DB      -1,10,11,12,13,14,15
@@1:    LODSW
        CMP     AL,'0'
        JB      @@2
        CMP     AL,'f'
        JA      @@2
        MOV     DL,AL
        MOV     AL,@@0.Byte[EDX-'0']
        CMP     AL,-1
        JE      @@2
        SHL     AL,4
        CMP     AH,'0'
        JB      @@2
        CMP     AH,'f'
        JA      @@2
        MOV     DL,AH
        MOV     AH,@@0.Byte[EDX-'0']
        CMP     AH,-1
        JE      @@2
        OR      AL,AH
        STOSB
        DEC     ECX
        JNE     @@1
@@2:    MOV     EAX,EDI
        SUB     EAX,EBX
        POP     EBX
        POP     EDI
        POP     ESI
end;

constructor TNewParser.Create(Stream: TStream);
begin
  FStream := Stream;
  GetMem(FBuffer, ParseBufSize);
  FBuffer[0] := #0;
  FBufPtr := FBuffer;
  FBufEnd := FBuffer + ParseBufSize;
  FSourcePtr := FBuffer;
  FSourceEnd := FBuffer;
  FTokenPtr := FBuffer;
  FSourceLine := 1;
  NextToken;
end;

destructor TNewParser.Destroy;
begin
  if FBuffer <> nil then
  begin
    FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
    FreeMem(FBuffer, ParseBufSize);
  end;
end;

procedure TNewParser.CheckToken(T: Char);
begin
  if Token <> T then
    case T of
      toSymbol:
        Error(SIdentifierExpected);
      toString:
        Error(SStringExpected);
      toInteger, toFloat:
        Error(SNumberExpected);
    else
      ErrorFmt(SCharExpected, [T]);
    end;
end;

procedure TNewParser.CheckTokenSymbol(const S: string);
begin
  if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
end;

procedure TNewParser.Error(const Ident: string);
begin
  ErrorStr(Ident);
end;

procedure TNewParser.ErrorFmt(const Ident: string; const Args: array of const);
begin
  ErrorStr(Format(Ident, Args));
end;

procedure TNewParser.ErrorStr(const Message: string);
begin
  raise EParserError.CreateFmt(SParseError, [Message, FSourceLine]);
end;

procedure TNewParser.HexToBinary(Stream: TStream);
var
  Count: Integer;
  Buffer: array[0..255] of Char;
begin
  SkipBlanks;
  while FSourcePtr^ <> '}' do
  begin
    Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
    if Count = 0 then Error(SInvalidBinary);
    Stream.Write(Buffer, Count);
    Inc(FSourcePtr, Count * 2);
    SkipBlanks;
  end;
  NextToken;
end;

function TNewParser.NextToken: Char;
var
  I: Integer;
  P, S: PChar;
begin
  SkipBlanks;
  P := FSourcePtr;
  FTokenPtr := P;
  case P^ of
    'A'..'Z', 'a'..'z', '_':
      begin
        Inc(P);
        while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
        Result := toSymbol;
      end;
    '#', '''':
      begin
        S := P;
        while True do
          case P^ of
            '#':
              begin
                Inc(P);
                I := 0;
                while P^ in ['0'..'9'] do
                begin
                  I := I * 10 + (Ord(P^) - Ord('0'));
                  Inc(P);
                end;
                S^ := Chr(I);
                Inc(S);
              end;
            '''':
              begin
                Inc(P);
                while True do
                begin
                  case P^ of
                    #0, #10, #13:
                      Error(SInvalidString);
                    '''':
                      begin
                        Inc(P);
                        if P^ <> '''' then Break;
                      end;
                  end;
                  S^ := P^;
                  Inc(S);
                  Inc(P);
                end;
              end;
          else
            Break;
          end;
        FStringPtr := S;
        Result := toString;
      end;
    '$':
      begin
        Inc(P);
        while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
        Result := toInteger;
      end;
    '-', '0'..'9':
      begin
        Inc(P);
        while P^ in ['0'..'9'] do Inc(P);
        Result := toInteger;
        while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
        begin
          Inc(P);
          Result := toFloat;
        end;
      end;
    // new custom code!!!!
    '{':
      begin
        // look for closing brace
        while (P^ <> '}') and (P^ <> toEOF) do
          Inc(P);
        // move to the next
        if (P^ <> toEOF) then
          Inc(P);
        Result := toComment;
      end;
  else
    // updated
    if (P^ = '/') and (P^ <> toEOF) and ((P+1)^ = '/') then
    begin
      // single line comment
      while P^ <> #13 do
        Inc(P);
      Result := toComment;
    end
    else
    begin
      Result := P^;
      if Result <> toEOF then
        Inc(P);
    end;
  end;
  FSourcePtr := P;
  FToken := Result;
end;

procedure TNewParser.ReadBuffer;
var
  Count: Integer;
begin
  Inc(FOrigin, FSourcePtr - FBuffer);
  FSourceEnd[0] := FSaveChar;
  Count := FBufPtr - FSourcePtr;
  if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  FBufPtr := FBuffer + Count;
  Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  FSourcePtr := FBuffer;
  FSourceEnd := FBufPtr;
  if FSourceEnd = FBufEnd then
  begin
    FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
    if FSourceEnd = FBuffer then Error(SLineTooLong);
  end;
  FSaveChar := FSourceEnd[0];
  FSourceEnd[0] := #0;
end;

procedure TNewParser.SkipBlanks;
begin
  while True do
  begin
    case FSourcePtr^ of
      #0:
        begin
          ReadBuffer;
          if FSourcePtr^ = #0 then Exit;
          Continue;
        end;
      #10:
        Inc(FSourceLine);
      '!'..'я' :
        Exit;
    end;
    Inc(FSourcePtr);
  end;
end;

function TNewParser.SourcePos: Longint;
begin
  Result := FOrigin + (FTokenPtr - FBuffer);
end;

function TNewParser.TokenFloat: Extended;
begin
  Result := StrToFloat(TokenString);
end;

function TNewParser.TokenInt: Longint;
begin
  Result := StrToInt(TokenString);
end;

function TNewParser.TokenString: string;
var
  L: Integer;
begin
  if FToken = toString then
    L := FStringPtr - FTokenPtr else
    L := FSourcePtr - FTokenPtr;
  SetString(Result, FTokenPtr, L);
end;

function TNewParser.TokenSymbolIs(const S: string): Boolean;
begin
  Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
end;

function TNewParser.TokenComponentIdent: String;
var
  P: PChar;
begin
  CheckToken(toSymbol);
  P := FSourcePtr;
  while P^ = '.' do
  begin
    Inc(P);
    if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
      Error(SIdentifierExpected);
    repeat
      Inc(P)
    until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  end;
  FSourcePtr := P;
  Result := TokenString;
end;

end.

unit PasToWebForm;

interface

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

type
  TForm1 = class (TForm)
    EditSource: TEdit;
    BtnHTML: TButton;
    EditCopyr: TEdit;
    BtnInput: TButton;
    OpenDialog1: TOpenDialog;
    EditDest: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    BtnOpen: TButton;
    BtnInfo: TButton;
    procedure BtnHTMLClick(Sender: TObject);
    procedure BtnInputClick(Sender: TObject);
    procedure EditDestChange(Sender: TObject);
    procedure BtnOpenClick(Sender: TObject);
    procedure BtnInfoClick(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Convert, ShellApi;

procedure TForm1.BtnHTMLClick(Sender: TObject);
var
  Source, BinSource, Dest: TStream;
  Parser: THtmlParser;
begin
  // extract the target file name
  if FileExists (EditDest.Text) then
    if MessageDlg ('Overwrite the existing file ' + EditDest.Text + '?',
      mtConfirmation, [mbYes, mbNo], 0) = idNo then
    Exit;
  // create the two streams
  Dest := TFileStream.Create (EditDest.Text,
    fmCreate or fmOpenWrite);
  if ExtractFileExt(EditSource.Text) = '.dfm' then
  begin
    // convert the DFM file to text
    BinSource := TFileStream.Create (EditSource.Text, fmOpenRead);
    Source := TMemoryStream.Create;
    ObjectResourceToText (BinSource, Source);
    Source.Position := 0;
  end
  else
  begin
    Source := TFileStream.Create (EditSource.Text, fmOpenRead);
    BinSource := nil;
  end;
  // parse the source code
  try
    Parser := THtmlParser.Create (Source, Dest);
    try
      Parser.Alone := True;
      Parser.Filename := EditSource.Text;
      Parser.Copyright := EditCopyr.Text;
      if ExtractFileExt(EditSource.Text) = '.dfm' then
        Parser.SetKeywordType (ktDfm);
      Parser.Convert;
    finally
      Parser.Free;
    end;
  finally
    Dest.Free;
    Source.Free;
    BinSource.Free;
  end;
  // enable the third button
  BtnOpen.Enabled := True;
end;

procedure TForm1.BtnInputClick(Sender: TObject);
begin
  with OpenDialog1 do
    if Execute then
    begin
      EditSource.Text := Filename;
      EditDest.Text := ChangeFileExt(FileName, '_' +
        Copy (ExtractFileExt(Filename), 2, 3)) + '.HTM';
      BtnHtml.Enabled := True;
    end;
end;

procedure TForm1.EditDestChange(Sender: TObject);
begin
  BtnOpen.Enabled := False;
end;

procedure TForm1.BtnOpenClick(Sender: TObject);
begin
  ShellExecute (Handle, 'open',
     PChar (EditDest.Text), '', '', sw_ShowNormal);
end;

procedure TForm1.BtnInfoClick(Sender: TObject);
begin
  // this isn't true any more
  MessageDlg (Caption + #13#13+
   'from Delphi Developers Handbook',
    mtInformation, [mbOK], 0);
end;

end.