jvpasimportform.pas

jvcl driver development envionment

    Result := '(';
    for i := 0 to Params.Count - 1 do
    begin
      if Result <> '(' then
        Result := Result + ', ';
      Result := Result + VarCast(V2Param('Args.Values[' + IntToStr(i) + ']',
        Trim(SubStr(Params[i], 1, ':'))));
    end;
    Result := Result + ')';
  end;

  procedure AddCons;
  begin
    ReadFun;
    Add('');
    Add('{ constructor ' + Name + ParamStr + ' }');
    Add('');
    Add('procedure ' + ClassName + '_' + Name + GetArgs + ';');
    Add('begin');
    Add('  Value := O2V(' + ClassName + '.' + Name + ConvertParams + ');');
    Add('end;');
    Adapter.Add('    AddGet(' + ClassName + ', ''' + Name + ''', ' +
      ClassName + '_' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr + ', ' + ResVar + ');');
  end;

  procedure AddFun;
  var
    PS, TS: string;
  begin
    ReadFun;
    PS := ParamTypStr;
    TS := TypStr(Typ, True);
    if DirectCall and (Pos('varEmpty', PS) = 0) then
    { direct call }
    begin
      Adapter.Add('    { ' + Decl + ' }');
      Adapter.Add('    AddDGet(' + ClassName + ', ''' + Name + ''', ' +
        '@' + ClassName + '.' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr +
        ', ' + TS + ', ' + ResVar + ', [ccFastCall]);');
    end
    else
    begin
      Add('');
      Add('{ ' + Decl + ' }');
      Add('');
      Add('procedure ' + ClassName + '_' + Name + GetArgs + ';');
      Add('begin');
      Add('  Value := ' + Result2V(ClassName + '(Args.Obj).' + Name + ConvertParams) + ';');
      Add('end;');
      Adapter.Add('    AddGet(' + ClassName + ', ''' + Name + ''', ' +
        ClassName + '_' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr + ', ' + ResVar + ');');
    end;
  end;

  procedure AddProc;
  var
    PS: string;
  begin
    ReadFun;
    PS := ParamTypStr;
    if DirectCall and (Pos('varEmpty', PS) = 0) then
    { direct call }
    begin
      Adapter.Add('    { ' + Decl + ' }');
      Adapter.Add('    AddDGet(' + ClassName + ', ''' + Name + ''', ' +
        '@' + ClassName + '.' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr +
        ', varEmpty, [ccFastCall]);');
    end
    else
    begin
      Add('');
      Add('{ ' + Decl + ' }');
      Add('');
      Add('procedure ' + ClassName + '_' + Name + GetArgs + ';');
      Add('begin');
      Add('  ' + ClassName + '(Args.Obj).' + Name + ConvertParams + ';');
      Add('end;');
      Adapter.Add('    AddGet(' + ClassName + ', ''' + Name + ''', ' +
        ClassName + '_' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr + ', ' + ResVar + ');');
    end;
  end;

  procedure AddFun2;
  var
    S: string;
  begin
    ReadFun;
    Add('');
    Add('{ ' + Decl + ' }');
    Add('');
    Add('procedure ' + 'JvInterpreter_' + Name + GetArgs + ';');
    Add('begin');
    Add('  Value := ' + Result2V(Name + ConvertParams) + ';');
    Add('end;');
    S := UnitNameStr;
    AdapterNames.Add(S);
    Adapter.Add('    AddFunction(c' + UnitNameStr + ', ''' + Name + ''', ' +
      'JvInterpreter_' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr + ', ' + ResVar + ');');
  end;

  procedure AddProc2;
  var
    S: string;
  begin
    ReadFun;
    Add('');
    Add('{ ' + Decl + ' }');
    Add('');
    Add('procedure ' + 'JvInterpreter_' + Name + GetArgs + ';');
    Add('begin');
    Add('  ' + Name + ConvertParams + ';');
    Add('end;');
    S := UnitNameStr;
    AdapterNames.Add(S);
    Adapter.Add('    AddFunction(c' + S + ', ''' + Name + ''', ' +
      ClassName + 'JvInterpreter_' + Name + ', ' + IntToStr(Params.Count) + ', ' + ParamTypStr + ', ' + ResVar + ');');
  end;

  procedure AddProp;
  begin
    if ReadProp then
    begin
      if PropRead then
        if IndexTyp = '' then
        begin
          Add('');
          Add('{ property Read ' + Name + ': ' + Typ + ' }');
          Add('');
          Add('procedure ' + ClassName + '_' + 'Read_' + Name + GetArgs + ';');
          Add('begin');
          Add('  Value := ' + Result2V(ClassName + '(Args.Obj).' + Name + ConvertParams) + ';');
          Add('end;');
          Adapter.Add('    AddGet(' + ClassName + ', ''' + Name + ''', ' +
            ClassName + '_' + 'Read_' + Name + ', 0, [varEmpty], ' + ResVar + ');');
        end
        else
        begin
          Add('');
          Add('{ property Read ' + Name + '[' + IndexTyp + ']: ' + Typ + ' }');
          Add('');
          Add('procedure ' + ClassName + '_' + 'Read_' + Name + GetArgs + ';');
          Add('begin');
          Add('  Value := ' + Result2V(ClassName + '(Args.Obj).' + Name +
            '[Args.Values[0]]' {+ ConvertParams}) + ';');
          Add('end;');
          Adapter.Add('    AddIGet(' + ClassName + ', ''' + Name + ''', ' +
            ClassName + '_' + 'Read_' + Name + ', 1, [varEmpty], ' + ResVar + ');');
          if IndexDefault then
            Adapter.Add('    AddIDGet(' + ClassName + ', ' +
              ClassName + '_' + 'Read_' + Name + ', 1, [varEmpty], ' + ResVar + ');');
        end;
      if PropWrite then
        if IndexTyp = '' then
        begin
          Add('');
          Add('{ property Write ' + Name + '(Value: ' + Typ + ') }');
          Add('');
          Add('procedure ' + ClassName + '_' + 'Write_' + Name + SetArgs + ';');
          Add('begin');
          Add('  ' + ClassName + '(Args.Obj).' + Name + ConvertParams +
            ' := ' + V2Param('Value', Typ) + ';');
          Add('end;');
          Adapter.Add('    AddSet(' + ClassName + ', ''' + Name + ''', ' +
            ClassName + '_' + 'Write_' + Name + ', 0, [' + ResVar + ']);');
        end
        else
        begin
          Add('');
          Add('{ property Write ' + Name + '[' + IndexTyp + ']: ' + Typ + ' }');
          Add('');
          Add('procedure ' + ClassName + '_' + 'Write_' + Name + SetArgs + ';');
          Add('begin');
          Add('  ' + ClassName + '(Args.Obj).' + Name +
            '[Args.Values[0]]' { + ConvertParams} +
            ' := ' + V2Param('Value', Typ) + ';');
          Add('end;');
          Adapter.Add('    AddISet(' + ClassName + ', ''' + Name + ''', ' +
            ClassName + '_' + 'Write_' + Name + ', 0, [varNull]);');
          if IndexDefault then
            Adapter.Add('    AddIDSet(' + ClassName + ', ' +
              ClassName + '_' + 'Write_' + Name + ', 0, [varNull]);');
        end;
    end;
  end;

  procedure ReadSection;
  begin
    while True do
    begin
      if CT('function') then
        AddFun;
      if CT('procedure') then
        AddProc;
      if CT('constructor') then
        AddCons;
      if CT('property') then
        AddProp;
      if CT('end') or CT('private') or CT('protected') then
        Exit;
      Decl := '';
      NextToken;
    end;
  end;

  procedure SkipClass;
  begin
    if Token = ';' then
      Exit;
    if Cmp(NextToken, 'of') then
      Exit;
    if Cmp(Token, 'end') then
      Exit;
    while not Cmp(NextToken, 'end') do
      if Token = '' then
        Exit;
  end;

  function ReadClass: Boolean;
  var
    S: string;
  begin
    Result := False;
    ClassName := Parser.History[3];
    if Token = '(' then
    begin
      while True do
      begin
        NextToken;
        if Token = ')' then
          Break;
      end;
      NextToken;
    end;
    if Sender = bReadClasses then
    begin
      lbClasses.Items.Add(ClassName);
      Exit;
    end;
    if (lbClasses.Items.Count > 0) and
      not lbClasses.Selected[lbClasses.Items.IndexOf(ClassName)] then
    begin
      SkipClass;
      Exit;
    end;
    Add('');
    Add('{ ' + ClassName + ' }');
    DeleteAdapterLastLine;
    Adapter.Add('    { ' + ClassName + ' }');
    S := UnitNameStr;
    AdapterNames.Add(S);
    Adapter.Add('    AddClass(c' + S + ', ' + ClassName +
      ', ' + '''' + ClassName + ''');');
    if Token = ';' then
      Exit;
    Decl := Token;
    try
      while True do
      begin
        ReadSection;
        NextPublicSection;
      end;
    except
      on E: EAbort do
        ;
      else
        raise;
    end;
    Result := True;
  end;

  procedure ReadEnum(SetName: string);
  var
    En: string;
    S: string;
  begin
    Name := SetName;
    DeleteAdapterLastLine;
    Adapter.Add('    { ' + Name + ' }');
    while True do
    begin
      En := NextToken;
      if not (NextToken[1] in [',', ')']) then
        Break;
      S := UnitNameStr;
      AdapterNames.Add(S);
      Adapter.Add('    AddConst(c' + S + ', ''' + En + ''', Ord(' + En + '));');
      if Token = ')' then
        Break;
    end;
    Adapter.Add('');
  end;

begin
  Parser := TJvIParser.Create;
  Output := TStringList.Create;
  Params := TStringList.Create;
  Adapter := TStringList.Create;
  AdapterNames := TStringList.Create;
  AdapterNames.Sorted := True;
  AdapterNames.Duplicates := dupIgnore;
  if Sender = bReadClasses then
    lbClasses.Items.Clear;
  RClasses := RegClasses.memClasses.Lines;
  DirectCall := cbDirectCall.Checked;
  Output.Clear;
  DebugLog.memDebug.Lines.Clear;
  try
    S := LoadTextFile(eSource.Text);
    Parser.pcProgram := PChar(S);
    Parser.pcPos := Parser.pcProgram;
    if ProgressBar1.Max = 0 then
    try
      ProgressBar1.Max := Length(S);
    except
    end;
    ProgressBar1.Visible := True;
    if Sender = bImport then
    begin
      DecodeDate(Now, Year, Month, Day);
      Add('{-----------------------------------------------------------------------------');
      Add('The contents of this file are subject to the Mozilla Public License');
      Add('Version 1.1 (the "License"); you may not use this file except in compliance');
      Add('with the License. You may obtain a copy of the License at');
      Add('http://www.mozilla.org/MPL/MPL-1.1.html');
      Add('');
      Add('Software distributed under the License is distributed on an "AS IS" basis,');
      Add('WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for');
      Add('the specific language governing rights and limitations under the License.');
      Add('');
      Add('The Original Code is: ' + ExtractFileName(eDestination.Text) +
        Format(', generated on %.4d-%.2d-%.2d.', [Year, Month, Day]));
      Add('');
      Add('The Initial Developer of the Original Code is: Andrei Prygounkov <a dott prygounkov att gmx dott de>');
      Add('Copyright (C) ' + Format('%.4d', [Year]) + ' Andrei Prygounkov.');
      Add('All Rights Reserved.');
      Add('');
      Add('Contributor(s):');
      Add('');
      Add('Last Modified:');
      Add('');
      Add('You may retrieve the latest version of this file at the Project JEDI''s JVCL home page,');
      Add('located at http://jvcl.sourceforge.net');
      Add('');
      Add('Description:');
      Add('  adapter unit - converts JvInterpreter calls to Delphi calls');
      Add('');
      Add('Known Issues:');
      Add('  if compiled with errors:');
      Add('   - to convert variant to object use function V2O');
      Add('   - to convert object to variant use function O2V');
      Add('   - to convert variant to pointer use function V2P');
      Add('   - to convert pointer to variant use function P2V');
      Add('   - to convert set to variant use function S2V and');
      Add('     typecasting such as:');
      Add('       Value := S2V(Byte(TFont(Args.Obj).Style))');
      Add('   - to convert variant to set use typecasting');
      Add('     and function V2S such as:');
      Add('       TFont(Args.Obj).Style := TFontStyles(Byte(V2S(Value))) ');
      Add('     depending on size of set (f.e. SizeOf(TFontStyles)),');
      Add('     try to use Byte, Word or Integer types in typecasting');
      Add('   - sets with more than 32 elements cannot be used in JvInterpreter');
      Add('-----------------------------------------------------------------------------}');
      Add('');
      Add('unit ' + ChangeFileExt(ExtractFileName(eDestination.Text), ';'));
      Add('');
      Add('interface');
      Add('');
      Add('uses');
      Add('  JvInterpreter;');
      Add('');
      Add('procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);');
      Add('');
      Add('implementation');
      Add('');
      Add('uses');
      Add('  ' + ChangeFileExt(ExtractFileName(eSource.Text), '') + ';');
    end;
    Roll := 0;
    NextToken;
    try
      while True do
      begin
        if CT('class') then
        begin
          if cbClasses.Checked or (Sender = bReadClasses) then
          begin
            NextToken;
            if (Token <> ';') and (Parser.History[2] = '=') and
              not CT('of') then
              ReadClass;
          end
          else
            SkipClass;
        end
        else
        if CT('interface') and (Parser.History[1] = '=') then
          SkipClass
        else
        if cbFunctions.Checked and (Sender = bImport) then
        begin
          Decl := Token;
          if CT('function') and
            (Parser.History[1] <> '=') and
            (Parser.History[1] <> ':') then
          begin
            AddFun2;
           // Abort;
          end
          else
          if CT('procedure') and
            (Parser.History[1] <> '=') and
            (Parser.History[1] <> ':') then
          begin
            AddProc2;
          //  Abort;
          end;
        end
        else
        if cbConstants.Checked and (Sender = bImport) then
        begin
          if (Token = '(') and (Parser.History[1] = '=') then
            ReadEnum(Parser.History[2])
          else
          if (Token = '(') and Cmp(Parser.History[1], 'of') and
            Cmp(Parser.History[2], 'set') and (Parser.History[3] = '=') then
            ReadEnum(Parser.History[4]);
        end;
        NextToken;
      end;
    except
      on E: EAbort do
        ;
    else
      raise;
    end;
    ProgressBar1.Max := ProgressBar1.Position;
    ProgressBar1.Position := 0;
    ProgressBar1.Visible := False;
    if Sender = bImport then
    begin
      DeleteAdapterLastLine;
      Adapter.Add('  end;');
      Adapter.Add('end;');
      Add('');
      Output.Add('procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);');
      if AdapterNames.Count > 0 then
      begin
        Output.Add('const');
        for I := 0 to AdapterNames.Count-1 do
          Output.Add('  c' + AdapterNames[I] + ' = ''' + AdapterNames[I] + ''';')
      end;
      Output.Add('begin');
      Output.Add('  with JvInterpreterAdapter do');
      Output.Add('  begin');
      Output.AddStrings(Adapter);
      if DebugLog.cbDebug.Checked then
        DebugLog.memDebug.Lines.AddStrings(Adapter);
      Add('');
      Add('end.');
      if (not FileExists(eDestination.Text) or
        (MessageDlg('File ''' + eDestination.Text + ''' already exists. Overwrite ?',
        mtWarning, [mbYes, mbNo, mbCancel], 0) = mrYes)) then
        Output.SaveToFile(eDestination.Text);
    end;
    if Sender = bReadClasses then
    begin
      for i := lbClasses.Items.Count - 1 downto 0 do
        lbClasses.Selected[i] := True;
    end;
  finally
    Parser.Free;
    Params.Free;
    Adapter.Free;
    Output.Free;
    AdapterNames.Free;
  end;
end;

procedure TJvPasImport.FormShow(Sender: TObject);
begin
  DebugLog.Show;
end;

procedure TJvPasImport.eSourceChange(Sender: TObject);
begin
  ProgressBar1.Max := 0;
  lbClasses.Items.Clear;
end;

procedure TJvPasImport.FormCreate(Sender: TObject);
begin
  eSourceChange(nil);
end;

procedure TJvPasImport.bParamsClick(Sender: TObject);
begin
  RegClasses.Show;
end;

procedure TJvPasImport.bAddToRegClick(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to lbClasses.Items.Count - 1 do
    if lbClasses.Selected[i] and
      (RegClasses.memClasses.Lines.IndexOf(lbClasses.Items[i]) = -1) then
      RegClasses.memClasses.Lines.Add(lbClasses.Items[i]);
end;

end.