Delphi World - Преобразование PAS-файла в HTML-файл
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Преобразование 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.

Загрузить весь проект

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования