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.