Преобразование PAS-файла в HTML-файл

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
.

Другое по теме:

• Очистка корзины
• Полнофункциональная функция для создания ярлыка с определенными параметрами.
• Регистрация расширений