{
  ClassRW object (reader/writer of source TObject descendant files)

  Creates published part for all fields defined in the first private part of the
  class declaration.

  Assumes the following format of the source file:
  - no TAB characters, just spaces
  - every field on its own line
  - pascal keywords in lowercase (class private protected public end function procedure)
  - spaces around " = " and keywords: private protected public function procedure
  - no spaces: "class(", "end;"

  Creates file with the same name as the input file but with .tmp extension
  and writes to it published part of the class and definition of the
  class Get and Set function for the published properties.

  }
unit ClassRWu;
{v0.62}
{
  (C) 2000 - 2001 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

interface
uses
  Windows, Classes, SysUtils, FileCtrl, Math;

type
  TClassRW = class(TObject)
  private
    FPublField: string;
  private
    FInFileName: string; // input file name (source file where class defined)
    FIn: text;           // text variable corresponding to opened FInFileName
    FOutFileName: string; // name of temporary file to which published part of
                          // the class will be written
    FOut: text;           // to FOutFileName corresponding text variable
    FLine: string;       // current line read wrom Fin
    FClassName: string;
    FInClass: boolean;   // if FIn position in class definition?
    FInPrivate: boolean;  // are we in private section of the class?
    FInComment: boolean;  // are we in the comment?
    FField: string;       // name of the current field (without starting 'F')
    FType: string;        // pascal type of the current field
    FFields: TStringList;

    procedure CheckComment; // check FLine for comments, stripped them off
    procedure WriteOut;
  public
    constructor Create(AInFileName: string); reintroduce;
    procedure Run;
    destructor Destroy; override;
  end;

implementation

constructor TClassRW.Create(AInFileName: string);
begin
  inherited Create;
  FInFileName := AInFileName;
  if ExtractFileExt(FInFileName) = '' then
    FInFileName := ChangeFileExt(FInFileName, '.pas');
  Assign(FIn, FInFileName);
  Reset(FIn);
  FOutFileName := ChangeFileExt(FInFileName, '.tmp');
  Assign(FOut, FOutFileName);
  Rewrite(FOut);
  FFields := TStringList.Create;
end;

procedure TClassRW.CheckComment;
var
  line1: string;
  i: integer;
begin
  line1 := '';
  repeat
    if FInComment then begin
      for i := 1 to length(FLine) do begin
        if FLine[i] = '}' then begin
          FInComment := false;
          FLine := copy(FLine, i + 1, length(FLine));
          break;
        end;
      end;
      if i > length(FLine) then
        break;
    end else begin
      for i := 1 to length(FLine) do begin
        if FLine[i] = '{' then begin
          FInComment := true;
          line1 := line1 + copy(FLine, 1, i - 1);
          FLine := copy(FLine, i + 1, length(FLine));
          break;
        end;
      end;
      if i > length(FLine) then
        break;
    end;
  until false;
  FLine := line1 + FLine;
  i := pos('//', FLine);
  if i > 0 then
    FLine := copy(FLine, 1, i - 1);
end;

procedure TClassRW.Run;
var i: integer;
begin
  while not eof(FIn) do begin
    readln(fin, FLine);
    CheckComment;
    if FInComment or (trim(FLine) = '') then
      continue;

    if FInClass then begin
      if pos(' end;', FLine) > 0 then begin
        FInClass := false;
        FInPrivate := false;
        break;
      end else begin
        if FInPrivate then begin
          if (pos(' protected', FLine) > 0) or (pos(' public', FLine) > 0) or
             (pos(' private', FLine) > 0) then
          begin
            FInPrivate := false;
          end else begin
            i := pos(':', FLine);
            if (pos(' procedure ', FLine) = 0) and (pos (' function ', FLine) = 0) then
            begin
              FField := '';
              FType := '';
              if i > 0 then begin
                FField := Trim(copy(FLine, 1, i - 1));
                if (FField <> '') and (FField[1] = 'F') then begin
                  FField := copy(FField, 2, length(FField));// strip 'F'
                  FType := Trim(copy(FLine, i + 1, length(FLine)));
                  i := pos(';', FType);
                  FType := copy(FType, 1, i - 1);
                end;
              end;
              if (FField <> '') and (FType <> '') then begin
                FFields.Add(FField + '=' + FType);
              end;
            end;
          end;
        end else begin
          if pos(' private', FLine) > 0 then begin
            FInPrivate := true;
          end;
        end;
      end;
    end else begin
      i := pos('= class(', FLine);
      if i > 0 then begin
        FClassName := trim(copy(FLine, 1, i - 1));
        FInClass := true;
      end;
    end;

  end;
  WriteOut;
end;

procedure TClassRW.WriteOut;
var
  i: integer;
  f: string;
  t: string;
  procedure wo(s: string);
  begin
    writeln(FOut, s);
  end;
begin
  wo('  private');
  for i := 0 to FFields.Count - 1 do begin
    f := FFields.Names[i];
    t := FFields.Values[f];
    wo('    procedure Set' + f + '(A' + f + ': ' + t + ');');
    wo('    function Get' + f + ': ' + t + ';');
  end;
  wo('');

  wo('  published');
  for i := 0 to FFields.Count - 1 do begin
    f := FFields.Names[i];
    t := FFields.Values[f];
    wo('    property ' + f + ': ' + t + ' read Get' + f + ' write Set' + f + ';');
  end;
  wo('  end;');
  wo('');

  for i := 0 to FFields.Count - 1 do begin
    f := FFields.Names[i];
    t := FFields.Values[f];
    wo('procedure ' + FClassName + '.Set' + f + '(A' + f + ': ' + t + ');');
    wo('begin');
    wo('  F' + f + ' := A' + f + ';');
    wo('end;');
    wo('');
    wo('function ' + FClassName + '.Get' + f + ': ' + t + ';');
    wo('begin');
    wo('  Result := F' + f + ';');
    wo('end;');
    wo('');
  end;
end;

destructor TClassRW.Destroy;
begin
  if TTextRec(FIn).Mode = fmInput then
    Close(FIn);
  if TTextRec(FOut).Mode = fmOutput then
    Close(FOut);
  FFields.Free;
  inherited;
end;

end.
