jvpasimportform.pas

jvcl driver development envionment

{******************************************************************

                       JEDI-VCL Demo

 Copyright (C) 2002 Project JEDI

 Original author:

 Contributor(s):

 You may retrieve the latest version of this file at the JEDI-JVCL
 home page, located at http://jvcl.sourceforge.net

 The contents of this file are used with permission, subject to
 the Mozilla Public License Version 1.1 (the "License"); you may
 not use this file except in compliance with the License. You may
 obtain a copy of the License at
 http://www.mozilla.org/MPL/MPL-1_1Final.html

 Software distributed under the License is distributed on an
 "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 implied. See the License for the specific language governing
 rights and limitations under the License.

******************************************************************}

unit JvPasImportForm;

interface

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

type
  TJvPasImport = class(TForm)
    eSource: TEdit;
    bSource: TButton;
    Label1: TLabel;
    eDestination: TEdit;
    Label2: TLabel;
    bDestination: TButton;
    bImport: TButton;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    ProgressBar1: TProgressBar;
    Label3: TLabel;
    lbClasses: TListBox;
    bReadClasses: TButton;
    bParams: TButton;
    bAddToReg: TButton;
    Label4: TLabel;
    cbClasses: TCheckBox;
    cbFunctions: TCheckBox;
    cbConstants: TCheckBox;
    cbDirectCall: TCheckBox;
    procedure bSourceClick(Sender: TObject);
    procedure bDestinationClick(Sender: TObject);
    procedure bImportClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure eSourceChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure bParamsClick(Sender: TObject);
    procedure bAddToRegClick(Sender: TObject);
  public
  end;

var
  PasImport: TJvPasImport;

implementation

uses
  JvJCLUtils, JvHLParser, JvInterpreter, JvDebugForm, JvRegClassesForm;

{$R *.dfm}

procedure TJvPasImport.bSourceClick(Sender: TObject);
var
  S: string;
begin
  OpenDialog.FileName := eSource.Text;
  if OpenDialog.Execute then
  begin
    eSource.Text := OpenDialog.FileName;
    S := ExtractFileName(eSource.Text);
    if ANSIStrLIComp(PChar(S), 'I_', 2) = 0 then
      Delete(S, 1, 2);
    eDestination.Text := ExtractFilePath(eDestination.Text) +
      'JvInterpreter_' + S;
  end;
end;

procedure TJvPasImport.bDestinationClick(Sender: TObject);
begin
  SaveDialog.FileName := eDestination.Text;
  if SaveDialog.Execute then
    eDestination.Text := SaveDialog.FileName;
end;

procedure TJvPasImport.bImportClick(Sender: TObject);
var
  i: Integer;
  P: Integer;
  Token: string;
  Parser: TJvIParser;
  S: string;
  Output: TStringList;
  Params: TStringList;
  ClassName: string;
  Adapter: TStringList;
  AdapterNames: TStringList;
  RClasses: TStrings;
  Year, Month, Day: Word;

  Name: string; { for all }
  Typ: string; { for functions and properties }
  IndexTyp: string; { for properties }
  IndexDefault: Boolean; { default indexed property }
  PropRead, PropWrite: Boolean; { for properties }
  Decl: string;
  Roll: Integer;
  DirectCall: Boolean;

const
  SetArgs = '(const Value: Variant; Args: TJvInterpreterArgs)';
  GetArgs = '(var Value: Variant; Args: TJvInterpreterArgs)';

  function CT(S: string): Boolean;
  begin
    Result := Cmp(Token, S);
  end;

  procedure Add(S: string);
  begin
    Output.Add(S);
    if DebugLog.cbDebug.Checked then
      DebugLog.memDebug.Lines.Add(S);
  end;

  function NextToken: string;
  begin
    Token := Parser.Token;
    if (Token = '') or CT('implementation') then
      Abort;
    P := Parser.Pos;
    if P mod 100 = 0 then
    try
      ProgressBar1.Position := Parser.Pos;
    except
    end;
    Result := Token;
    if Roll = 0 then
    begin
      if (Token[1] in [';', ':', ',', '(', ')']) or
        (Length(Decl) > 0) and (Decl[Length(Decl)] = '(') then
        Decl := Decl + Token
      else
        Decl := Decl + ' ' + Token;
    end
    else
      Dec(Roll);
  end;

  procedure RollBack(Count: Integer);
  begin
    Parser.RollBack(Count);
    Roll := Count;
  end;

  procedure DeleteAdapterLastLine;
  begin
    if (Adapter.Count > 0) and (Adapter[Adapter.Count - 1] = '') then
      Adapter.Delete(Adapter.Count - 1);
  end;

  function UnitNameStr: string;
  begin
    Result := ChangeFileExt(ExtractFileName(eSource.Text), '');
    if ANSIStrLIComp(PChar(Result), 'I_', 2) = 0 then
      Delete(Result, 1, 2);
  end;

  procedure NextPublicSection;
  begin
    while True do
    begin
      if CT('end') then
        Abort;
      if CT('public') then
        Break;
      NextToken;
    end; { while }
  end;

  procedure ReadParams;
  var
    VarParam: Boolean;
    ParamType: string;
    i, iBeg: Integer;
  begin
    while True do
    begin
      VarParam := False;
      NextToken;
      if Token = ')' then
        Break;
      if CT('var') then
      begin
        VarParam := True;
        NextToken;
      end;
      if CT('const') then
        NextToken;
      iBeg := Params.Count;
      while True do
      begin
        if Token = ';' then
          Break;
        if Token = ')' then
          Exit;
        if Token = ':' then
        begin
          ParamType := NextToken;
          while True do
          begin
            if Token[1] in [')', ';'] then
            begin
              RollBack(1);
              Break;
            end;
            NextToken;
          end;
          Break;
        end;
        if Token <> ',' then
        begin
          // Params.Add(Token + '|' + IntToStr(Integer(VarParam)));
          if VarParam then
            Params.Add('var ' + Token)
          else
            Params.Add(Token);
        end;
        NextToken;
      end;
      for i := iBeg to Params.Count - 1 do
      begin
        Params[i] := Params[i] + ': ' + ParamType;
      end;
    end;
  end;

  function ParamStr: string;
  var
    i: Integer;
  begin
    Result := '';
    if Params.Count = 0 then
      Exit;
    Result := '(';
    for i := 0 to Params.Count - 1 do
    begin
      // Result := Result + SubStr(Params[i], 0, '|');
      if Result <> '(' then
        Result := Result + '; ';
      Result := Result + Params[i]
    end;
    Result := Result + ')';
  end;

  function TypStr(const Typ: string; const RetEmty: Boolean): string;
  begin
    if Cmp(Typ, 'TObject') or (RClasses.IndexOf(Typ) > -1) then
      Result := 'varObject'
    else
    if Cmp(Typ, 'Integer') or Cmp(Typ, 'TColor') then
      Result := 'varInteger'
    else
    if Cmp(Typ, 'Pointer') then
      Result := 'varPointer'
    else
    if Cmp(Typ, 'Word') then
      Result := 'varSmallint'
    else
    if Cmp(Typ, 'Boolean') then
      Result := 'varBoolean'
    else
    if Cmp(Typ, 'String') then
      Result := 'varString'
    else
    if Cmp(Typ, 'Double') then
      Result := 'varDouble'
    else
    if RetEmty then
      Result := 'varEmpty'
    else
      Result := Typ;
  end;

  function ParamTypStr: string;
  var
    i: Integer;
  begin
    if Params.Count = 0 then
    begin
      Result := '[varEmpty]';
      Exit;
    end;
    Result := '[';
    for i := 0 to Params.Count - 1 do
    begin
      // Result := Result + SubStr(Params[i], 0, '|');
      if Result <> '[' then
        Result := Result + ', ';
      Result := Result + TypStr(Trim(SubStr(Params[i], 1, ':')), True);
      if SubStr(Params[i], 0, ' ') = 'var' then
        Result := Result + ' or varByRef';
    end;
    Result := Result + ']';
  end;

  procedure ReadFun;
  begin
    Name := NextToken;
    NextToken;
    Params.Clear;
    if Token = '(' then
    begin
      ReadParams;
      NextToken;
    end;
    if Token = ':' then
    begin
      Typ := NextToken;
      NextToken; { Decl := Decl + ';'}
    end;
  end;

  function ReadProp: Boolean;
  begin
    Result := False;
    Name := NextToken;
    if (Length(Name) > 2) and (Name[1] = 'O') and
      (Name[2] = 'n') and (Name[3] in ['A'..'Z']) then
      { Skip Event Handlers }
      Exit;

    NextToken;
    Params.Clear;
    PropRead := False;
    PropWrite := False;
    IndexTyp := '';
    IndexDefault := False;
    if Token = ';' then
    begin
      { we must reading property info from ancestor }
      { not implemented }
      Exit;
    end;
    if Token <> ':' then
    begin
      if Token <> '[' then
        { something going wrong }
        Exit;
      { indexed property }
      NextToken;
      if NextToken <> ':' then
        { more than one index - not implemented }
        Exit;
      IndexTyp := NextToken;
      if NextToken <> ']' then
        { something going wrong }
        Exit;
      NextToken;
    end;
    Typ := NextToken;
    while True do
    begin
      NextToken;
      if Token = ';' then
      begin
        NextToken;
        if CT('default') then
          IndexDefault := True
        else
          RollBack(1);
        Break;
      end;
      if CT('read') then
        PropRead := True;
      if CT('write') then
        PropWrite := True;
    end;
    Result := True;
  end;

  function V2Param(S: string; ParamType: string): string;
  begin
    Result := S;
    if Cmp(ParamType, 'TObject') then
      Result := 'V2O(' + Result + ')'
    else
    if lbClasses.Items.IndexOf(ParamType) > -1 then
      Result := 'V2O(' + Result + ') as ' + ParamType
    else
    if RClasses.IndexOf(ParamType) > -1 then
      Result := 'V2O(' + Result + ') as ' + ParamType
    else
    if Cmp(ParamType, 'PChar') then
      Result := 'PChar(string(' + Result + '))'
    else
    if Cmp(ParamType, 'Char') then
      Result := 'string(' + Result + ')[1]'
    else
    if Cmp(ParamType, 'Pointer') then
      Result := 'V2P(' + Result + ')'
  end;

  function Result2V(S: string): string;
  var
    ParamType: string;
  begin
    Result := S;
    ParamType := Trim(Typ);
    if Cmp(ParamType, 'TObject') then
      Result := 'O2V(' + S + ')'
    else
    if lbClasses.Items.IndexOf(ParamType) > -1 then
      Result := 'O2V(' + S + ')'
    else
    if RClasses.IndexOf(ParamType) > -1 then
      Result := 'O2V(' + Result + ')'
    else
    if Cmp(ParamType, 'PChar') then
      Result := 'string(' + S + ')'
    else
    if Cmp(ParamType, 'Pointer') then
      Result := 'P2V(' + S + ')'
  end;

  function ResVar: string;
  var
    ParamType: string;
    VType: Integer;
  begin
    ParamType := Trim(Typ);
    VType := TypeName2VarTyp(ParamType);
    case VType of
      varInteger:
        Result := 'varInteger';
      varSmallInt:
        Result := 'varSmallInt';
      varBoolean:
        Result := 'varBoolean';
      varDouble:
        Result := 'varDouble';
      varString:
        Result := 'varString';
      varDate:
        Result := 'varDate';
    else
      if (VType = varObject) or (lbClasses.Items.IndexOf(ParamType) > -1) or
        (RClasses.IndexOf(ParamType) > -1) then
        Result := 'varObject'
      else
        Result := 'varEmpty';
    end;
  end;

  function ConvertParams: string;
  var
    i: Integer;

    function VarCast(S: string): string;
    var
      Typ: string;
    begin
      Result := S;
      if SubStr(Params[i], 0, ' ') <> 'var' then
        Exit;
      Typ := Trim(SubStr(Params[i], 1, ':'));
      if Cmp(Typ, 'integer') then
        Result := 'TVarData(' + Result + ').VInteger'
      else
      if Cmp(Typ, 'smallint') then
        Result := 'TVarData(' + Result + ').VSmallint'
      else
      if Cmp(Typ, 'byte') then
        Result := 'TVarData(' + Result + ').VByte'
      else
      if Cmp(Typ, 'word') then
        Result := 'Word(TVarData(' + Result + ').VSmallint)'
      else
      if Cmp(Typ, 'string') then
        Result := 'string(TVarData(' + Result + ').VString)'
      else
      if Cmp(Typ, 'pointer') then
        Result := 'TVarData(' + Result + ').VPointer'
      else
      if Cmp(Typ, 'double') then
        Result := 'TVarData(' + Result + ').VDouble'
      else
      if Cmp(Typ, 'boolean') then
        Result := 'TVarData(' + Result + ').VBoolean'
      else
      if Cmp(Typ, 'currency') then
        Result := 'TVarData(' + Result + ').VCurrency'
    end;

  begin
    Result := '';
    if Params.Count = 0 then
      Exit;