[JVCL-Checkins] CVS: dev/help/tools/GenDtx DelphiParser.pas,NONE,1.1 EditNiceNameDlg.dfm,NONE,1.1 EditNiceNameDlg.pas,NONE,1.1 GenDtx.dof,NONE,1.1 GenDtx.dpr,NONE,1.1 InputDlg.dfm,NONE,1.1 InputDlg.pas,NONE,1.1 MainCtrl.pas,NONE,1.1 MainDlg.dfm,NONE,1.1 MainDlg.pas,NONE,1.1 ParserTypes.pas,NONE,1.1 Settings.pas,NONE,1.1 SettingsDlg.dfm,NONE,1.1 SettingsDlg.pas,NONE,1.1

[Remko B. <rem...@us...>]

Update of /cvsroot/jvcl/dev/help/tools/GenDtx
In directory sc8-pr-cvs1:/tmp/cvs-serv21516

Added Files:
	DelphiParser.pas EditNiceNameDlg.dfm EditNiceNameDlg.pas 
	GenDtx.dof GenDtx.dpr InputDlg.dfm InputDlg.pas MainCtrl.pas 
	MainDlg.dfm MainDlg.pas ParserTypes.pas Settings.pas 
	SettingsDlg.dfm SettingsDlg.pas 
Log Message:
.dtx generator

--- NEW FILE: DelphiParser.pas ---
unit DelphiParser;

interface

uses
  Classes, ParserTypes;

const
  toComment = Char(6);
  toSemiColon = Char(';');
  toHaakjeOpen = Char('(');
  toHaakjeSluiten = Char(')');
  toEquals = Char('=');
  toCompilerDirective = Char(7);

type
  TClassVisibility = (inPrivate, inProtected, inPublic, inPublished);
  TClassVisibilities = set of TClassVisibility;

[...2146 lines suppressed...]
    if TokenSymbolIs('class') then
      ReadClass('dummy')
    else
      NextToken;

  Result := Token <> toEof;
end;

procedure TFunctionParser.ReadUntilImplementationBlock;
begin
  SkipUntilSymbol('implementation');
end;

function TBasicParser.GetRecordStrWithCurrentToken: string;
begin
  Result := FRecordStr + ' ' + TokenString;
end;

end.


--- NEW FILE: EditNiceNameDlg.dfm ---
object frmEditNiceName: TfrmEditNiceName
  Left = 283
  Top = 175
  Width = 370
  Height = 166
  Caption = 'frmEditNiceName'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object lblClass: TLabel
    Left = 8
    Top = 8
    Width = 28
    Height = 13
    Caption = '&Class:'
    FocusControl = edtClass
  end
  object lblNiceName: TLabel
    Left = 8
    Top = 48
    Width = 54
    Height = 13
    Caption = '&Nice name:'
    FocusControl = edtNiceName
  end
  object edtClass: TEdit
    Left = 8
    Top = 24
    Width = 345
    Height = 21
    CharCase = ecUpperCase
    TabOrder = 0
    OnKeyPress = edtClassKeyPress
  end
  object Button1: TButton
    Left = 192
    Top = 96
    Width = 75
    Height = 25
    Action = actOK
    Default = True
    TabOrder = 2
  end
  object Button2: TButton
    Left = 278
    Top = 96
    Width = 75
    Height = 25
    Action = actCancel
    Cancel = True
    TabOrder = 3
  end
  object edtNiceName: TEdit
    Left = 8
    Top = 64
    Width = 345
    Height = 21
    TabOrder = 1
  end
  object ActionList1: TActionList
    Left = 16
    Top = 96
    object actOK: TAction
      Caption = 'OK'
      OnExecute = actOKExecute
      OnUpdate = actOKUpdate
    end
    object actCancel: TAction
      Caption = 'Cancel'
      OnExecute = actCancelExecute
    end
  end
end

--- NEW FILE: EditNiceNameDlg.pas ---
unit EditNiceNameDlg;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ActnList;

type
  TfrmEditNiceName = class(TForm)
    lblClass: TLabel;
    edtClass: TEdit;
    ActionList1: TActionList;
    actOK: TAction;
    actCancel: TAction;
    Button1: TButton;
    Button2: TButton;
    lblNiceName: TLabel;
    edtNiceName: TEdit;
    procedure actOKExecute(Sender: TObject);
    procedure actCancelExecute(Sender: TObject);
    procedure actOKUpdate(Sender: TObject);
    procedure edtClassKeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
  public
    class function ExecuteAdd(var AClass, ADesc: string): Boolean;
    class function ExecuteEdit(const AClass: string; var ADesc: string): Boolean;
  end;

implementation

{$R *.dfm}

procedure TfrmEditNiceName.actOKExecute(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TfrmEditNiceName.actCancelExecute(Sender: TObject);
begin
  ModalResult := mrCancel;
end;

procedure TfrmEditNiceName.actOKUpdate(Sender: TObject);
begin
  if Sender is TAction then
    TAction(Sender).Enabled := edtClass.Text > '';
end;

class function TfrmEditNiceName.ExecuteAdd(var AClass,
  ADesc: string): Boolean;
begin
  with TfrmEditNiceName.Create(Application) do
  try
    edtClass.Text := '';
    edtNiceName.Text := '';
    Result := ShowModal = mrOk;
    if Result then
    begin
      AClass := UpperCase(edtClass.Text);
      ADesc := edtNiceName.Text;
    end;
  finally
    Free;
  end;
end;

class function TfrmEditNiceName.ExecuteEdit(const AClass: string;
  var ADesc: string): Boolean;
begin
  with TfrmEditNiceName.Create(Application) do
  try
    edtClass.Text := AClass;
    edtNiceName.Text := ADesc;
    edtClass.ReadOnly := True;
    edtClass.TabStop := False;
    Result := ShowModal = mrOk;
    if Result then
      ADesc := edtNiceName.Text;
  finally
    Free;
  end;
end;

procedure TfrmEditNiceName.edtClassKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['A'..'Z', 'a'..'z', '0'..'9', #8, #13]) then
    Key := #0;
end;

end.


--- NEW FILE: GenDtx.dof ---
[Directories]
OutputDir=..\
UnitOutputDir=..\lib
PackageDLLOutputDir=..\lib
PackageDCPOutputDir=..\lib

--- NEW FILE: GenDtx.dpr ---
program GenDtx;

uses
  Forms,
  MainDlg in 'MainDlg.pas' {Form1},
  DelphiParser in 'DelphiParser.pas',
  Settings in 'Settings.pas',
  SettingsDlg in 'SettingsDlg.pas' {frmSettings},
  ParserTypes in 'ParserTypes.pas',
  MainCtrl in 'MainCtrl.pas',
  InputDlg in 'InputDlg.pas' {frmInput},
  EditNiceNameDlg in 'EditNiceNameDlg.pas' {frmEditNiceName};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

--- NEW FILE: InputDlg.dfm ---
object frmInput: TfrmInput
  Left = 283
  Top = 175
  Width = 405
  Height = 132
  Caption = 'frmInput'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object lblNaam: TLabel
    Left = 8
    Top = 8
    Width = 28
    Height = 13
    Caption = '&Name'
  end
  object Button1: TButton
    Left = 224
    Top = 64
    Width = 75
    Height = 25
    Action = actOK
    Default = True
    TabOrder = 1
  end
  object Button2: TButton
    Left = 312
    Top = 64
    Width = 75
    Height = 25
    Action = actCancel
    Cancel = True
    TabOrder = 2
  end
  object edtName: TEdit
    Left = 8
    Top = 24
    Width = 385
    Height = 21
    CharCase = ecUpperCase
    TabOrder = 0
    OnKeyPress = edtNameKeyPress
  end
  object ActionList1: TActionList
    Left = 24
    Top = 64
    object actOK: TAction
      Caption = 'OK'
      OnExecute = actOKExecute
      OnUpdate = actOKUpdate
    end
    object actCancel: TAction
      Caption = 'Cancel'
      OnExecute = actCancelExecute
    end
  end
end

--- NEW FILE: InputDlg.pas ---
unit InputDlg;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActnList, StdCtrls;

type
  TfrmInput = class(TForm)
    lblNaam: TLabel;
    Button1: TButton;
    Button2: TButton;
    ActionList1: TActionList;
    edtName: TEdit;
    actOK: TAction;
    actCancel: TAction;
    procedure actOKExecute(Sender: TObject);
    procedure actCancelExecute(Sender: TObject);
    procedure actOKUpdate(Sender: TObject);
    procedure edtNameKeyPress(Sender: TObject; var Key: Char);
  public
    class function Execute(var AName: string): Boolean;
  end;

implementation

{$R *.dfm}

procedure TfrmInput.actOKExecute(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TfrmInput.actCancelExecute(Sender: TObject);
begin
  ModalResult := mrCancel;
end;

procedure TfrmInput.actOKUpdate(Sender: TObject);
begin
  if Sender is TAction then
    TAction(Sender).Enabled := edtName.Text > '';
end;

class function TfrmInput.Execute(var AName: string): Boolean;
begin
  with TfrmInput.Create(Application) do
  try
    Result := ShowModal = mrOk;
    if Result then
      AName := UpperCase(edtName.Text);
  finally
    Free;
  end;
end;

procedure TfrmInput.edtNameKeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['A'..'Z', '0'..'9', 'a'..'z', #8, #13]) then
    Key := #0;
end;

end.


--- NEW FILE: MainCtrl.pas ---
unit MainCtrl;

interface

uses
  Classes, ParserTypes, Settings;

const
  CSummaryDescription = 'Summary'#13#10'  Write here a summary (1 line)';
  CSummaryDescriptionOverride = CSummaryDescription +
    #13#10'  This is an overridden method, you don''t have to describe these' +
    #13#10'  if it does the same as the inherited method';
  CDescriptionDescription = 'Description'#13#10'  Write here a description'#13#10;
  CSeeAlsoDescription = 'See Also'#13#10'  List here other properties, methods (comma seperated)'#13#10 +
    '  Remove the ''See Also'' section if there are no references';
  CReturnsDescription = 'Return value'#13#10'  Describe here what the function returns';
  CParamDescription = 'Parameters'#13#10;
  CValueReference = '(Value = %Value - for reference)';
  CClassInfo = '<TITLEIMG %s>'#13#10'JVCLInfo'#13#10'  GROUP=JVCL.??'#13#10'  FLAG=Component'#13#10;

type
  TMainCtrl = class
  private
    FSkipList: TStrings;
    FParsedOK: Integer;
    FParsedError: Integer;
    FProcessList: TStrings;
    FMessagesList: TStrings;
    FIgnoreFiles: Boolean;
    procedure SetIgnoreFiles(const Value: Boolean);
  protected
    procedure DoMessage(const Msg: string);
    procedure WriteDtx(ATypeList: TTypeList);
    procedure SettingsChanged(Sender: TObject; ChangeType: TSettingsChangeType);
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure ProcessItem(const AFileName: string);
    procedure Process;

    procedure UpdateSourceFiles;
    procedure RemoveIgnoredFiles;

    property SkipList: TStrings read FSkipList write FSkipList;
    property ProcessList: TStrings read FProcessList write FProcessList;
    property MessagesList: TStrings read FMessagesList write FMessagesList;
    property IgnoreFiles: Boolean read FIgnoreFiles write SetIgnoreFiles;
  end;

implementation

uses
  SysUtils,
  JclFileUtils, JvProgressComponent,
  DelphiParser;

function GetClassInfoStr(AItem: TAbstractItem): string;
begin
  if (AItem.DelphiType = dtClass) and TSettings.Instance.IsRegisteredClass(AItem.SimpleName) then
    Result := Format(CClassInfo, [AItem.SimpleName])
  else
    Result := '';
end;

function GetTitleStr(AItem: TAbstractItem): string;
begin
  if AITem.TitleName > '' then
    Result := Format('<TITLE %s>', [AItem.TitleName])
  else
    Result := '';
end;

function GetSummaryStr(AItem: TAbstractItem): string;
begin
  if (AItem.DelphiType in [dtMethodFunc, dtMethodProc]) and (AItem is TParamClassMethod) and
    (diOverride in TParamClassMethod(AItem).Directives) then

    Result := CSummaryDescriptionOverride
  else
    Result := CSummaryDescription;
end;

function GetDescriptionStr(AItem: TAbstractItem): string;
begin
  Result := CDescriptionDescription + AItem.AddDescriptionString;
end;

(*function CanCombine(AItem: TAbstractItem): Boolean;
var
  S: string;
begin
  Result := AItem.DelphiType = dtType;
  if not Result then
    Exit;

  S := AItem.ValueString;

  Result := (S > '') and
    (
    ((StrLIComp(PChar(S), 'set of', 6) = 0) and (StrLIComp(PChar(S), 'set of (', 8) <> 0))
    or (S[1] = '^'));
end;*)

(*function GetCombineWithStr(AItem: TAbstractItem): string;
begin
  if AITem.CombineWithString > '' then
    Result := Format('<COMBINEWITH %s>', [AItem.CombineWithString])
  else
    Result := '';
end;*)

function GetCombineStr(AItem: TAbstractItem): string;
begin
  if AITem.CombineString > '' then
    Result := Format('<COMBINE %s>', [AItem.CombineString])
  else
    Result := '';

  (*
  Result := '';
  if AItem.DelphiType <> dtType then
    Exit;

  S := AItem.ValueString;
  if S = '' then
    Exit;

  if StrLIComp(PChar(S), 'set of', 6) = 0 then
  begin
    S := Trim(Copy(S, 8, MaxInt));
    while (Length(S) > 0) and (S[Length(S)] in [' ', ';']) do
      Delete(S, Length(S), 1);
    Result := Format('<COMBINE %s>'#13#10, [S]);
    Exit;
  end;

  if S[1] = '^' then
  begin
    Delete(S, 1, 1);
    S := Trim(S);
    while (Length(S) > 0) and (S[Length(S)] in [' ', ';']) do
      Delete(S, Length(S), 1);
    Result := Format('<COMBINE %s>'#13#10, [S]);
    Exit;
  end;*)
end;

function GetParamStr(AItem: TAbstractItem): string;
begin
  Result := AItem.ParamString;
  if Result > '' then
    Result := CParamDescription + Result;
end;

function GetReturnsStr(AItem: TAbstractItem): string;
begin
  if AItem.DelphiType in [dtFunction, dtProcedure] then
    Result := ''
  else
    Result := CReturnsDescription;
end;

{ TMainCtrl }

constructor TMainCtrl.Create;
begin
  TSettings.Instance.RegisterObserver(Self, SettingsChanged);
  FIgnoreFiles := True;
end;

destructor TMainCtrl.Destroy;
begin
  TSettings.Instance.UnRegisterObserver(Self);
  inherited;
end;

procedure TMainCtrl.DoMessage(const Msg: string);
begin
  if Assigned(MessagesList) then
    MessagesList.Add(Msg);
end;

procedure TMainCtrl.Process;
var
  I: Integer;
  Dir: string;
  ProgressDlg: TJvProgressComponent;
begin
  if not Assigned(ProcessList) then
    Exit;
  Dir := IncludeTrailingPathDelimiter(TSettings.Instance.InDir);
  FParsedOK := 0;
  FParsedError := 0;

  ProgressDlg := TJvProgressComponent.Create(nil);
  try
    ProgressDlg.ProgressMin := 0;
    ProgressDlg.ProgressMax := ProcessList.Count;
    ProgressDlg.Caption := 'Progress';
    ProgressDlg.Execute;

    for I := 0 to ProcessList.Count - 1 do
    begin
      ProgressDlg.InfoLabel := ProcessList[I];
      ProgressDlg.ProgressPosition := I;
      ProcessItem(Dir + ProcessList[I]);
    end;

    DoMessage(Format('Errors %d OK %d Total %d',
      [FParsedError, FParsedOK, FParsedError + FParsedOK]));
  finally
    ProgressDlg.Free;
  end;
end;

procedure TMainCtrl.ProcessItem(const AFileName: string);
var
  Parser: TDelphiParser;
begin
  Parser := TDelphiParser.Create;
  try
    Parser.AcceptCompilerDirectives := TSettings.Instance.AcceptCompilerDirectives;
    if Parser.Execute(AFileName) then
    begin
      Inc(FParsedOK);
      WriteDtx(Parser.TypeList);
    end
    else
    begin
      Inc(FParsedError);
      DoMessage(Format('[Error] %s - %s', [AFileName, Parser.ErrorMsg]));
    end;
  finally
    Parser.Free;
  end;
end;

procedure TMainCtrl.RemoveIgnoredFiles;
var
  I: Integer;
begin
  if Assigned(FProcessList) then
    with FProcessList do
    begin
      BeginUpdate;
      try
        for I := Count - 1 downto 0 do
          if TSettings.Instance.IsIgnoredUnit(Strings[I]) then
            Delete(I);
      finally
        EndUpdate;
      end;
    end;

  if Assigned(FSkipList) then
    with FSkipList do
    begin
      BeginUpdate;
      try
        for I := Count - 1 downto 0 do
          if TSettings.Instance.IsIgnoredUnit(Strings[I]) then
            Delete(I);
      finally
        EndUpdate;
      end;
    end;
end;

procedure TMainCtrl.SetIgnoreFiles(const Value: Boolean);
begin
  if Value = FIgnoreFiles then
    Exit;

  FIgnoreFiles := Value;
  if FIgnoreFiles then
    RemoveIgnoredFiles
  else
    UpdateSourceFiles;
end;

procedure TMainCtrl.SettingsChanged(Sender: TObject;
  ChangeType: TSettingsChangeType);
begin
  case ChangeType of
    ctInDirectory: UpdateSourceFiles;
    ctOutDirectory: ;
  end;
end;

procedure TMainCtrl.UpdateSourceFiles;
begin
  if Assigned(SkipList) then
    SkipList.Clear;

  if not Assigned(ProcessList) then
    Exit;
  ProcessList.BeginUpdate;
  try
    ProcessList.Clear;
    BuildFileList(IncludeTrailingPathDelimiter(TSettings.Instance.InDir) +
      '*.pas', faAnyFile, ProcessList);

    if IgnoreFiles then
      RemoveIgnoredFiles;
  finally
    ProcessList.EndUpdate;
  end;
end;

procedure TMainCtrl.WriteDtx(ATypeList: TTypeList);
const
  {TDelphiType = (dtClass, dtConst, dtDispInterface, dtFunction, dtFunctionType,
    dtInterface, dtMethodFunc, dtMethodProc, dtProcedure, dtProcedureType,
    dtProperty, dtRecord, dtResourceString, dtSet, dtType, dtVar);}
  {TOutputType = (otClass, otConst, otDispInterface, otFunction, otFunctionType,
    otInterface, otProcedure, otProcedureType, otProperty, otRecord,
    otResourceString, otSet, otType, otVar);}

  CConvert: array[TDelphiType] of TOutputType =
  (otClass, otConst, otType, otFunction, otFunctionType,
    otType, otFunction, otProcedure, otProcedure, otProcedureType,
    otProperty, otRecord, otResourcestring, otSet, otType, otVar);
var
  FileName: string;
  FileStream: TFileStream;

  function GetOutputStr(const OutputType: TOutputType; const AName: string): string;
  var
    Index: Integer;
  begin
    with TSettings.Instance do
    begin
      Index := OutputTypeDesc[OutputType].IndexOf(UpperCase(AName));
      if Index < 0 then
        Result := OutputTypeDefaults[OutputType]
      else
        Result := OutputTypeStrings[OutputType][Index];
    end;
  end;

  procedure WriteClassHeader(ATypeItem: TAbstractItem);
  var
    S: string;
  begin
    //S := TSettings.Instance.OutputTypeDefaults[otClassHeader];
    S := GetOutputStr(otClassHeader, ATypeItem.SimpleName);
    S := StringReplace(S, '%author', ATypeList.Author, [rfReplaceAll,
      rfIgnoreCase]);
    S := StringReplace(S, '%simplename', ATypeItem.SimpleName, [rfReplaceAll,
      rfIgnoreCase]);
    S := StringReplace(S, '%referencename', ATypeItem.ReferenceName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%sortname', ATypeItem.SortName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%titlename', ATypeItem.TitleName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%title', GetTitleStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%param', ATypeItem.ParamString, [rfReplaceAll,
      rfIgnoreCase]);
    S := StringReplace(S, '%items', ATypeItem.ItemsString, [rfReplaceAll,
      rfIgnoreCase]);
    S := StringReplace(S, '%nicename',
      TSettings.Instance.NiceName[ATypeItem.ClassString], [rfReplaceAll,
      rfIgnoreCase]);
    FileStream.Write(PChar(S)^, Length(S));
  end;

  procedure WriteHeader;
  var
    S: string;
    UnitName: string;
  begin
    UnitName := ChangeFileExt(ExtractFileName(FileName), '');
    S := TSettings.Instance.OutputTypeDefaults[otHeader];
    S := StringReplace(S, '%author', ATypeList.Author, [rfReplaceAll,
      rfIgnoreCase]);
    S := StringReplace(S, '%unitname', UnitName, [rfReplaceAll, rfIgnoreCase]);
    FileStream.Write(PChar(S)^, Length(S));
  end;

  procedure WriteType(ATypeItem: TAbstractItem);
  var
    S: string;
  begin
    { Inherited properties [property X;] niet toevoegen }
    if (ATypeItem is TMethodProp) and (TMethodProp(ATypeItem).InheritedProp) then
      Exit;

    { Create, Destroy ook niet }
    if SameText(ATypeItem.SimpleName, 'create') or SameText(ATypeItem.SimpleName, 'destroy') then
      Exit;

    if not TSettings.Instance.OutputTypeEnabled[CConvert[ATypeItem.DelphiType]] then
      Exit;
    //S := TSettings.Instance.OutputTypeDefaults[CConvert[ATypeItem.DelphiType]];

    S := GetOutputStr(CConvert[ATypeItem.DelphiType], ATypeItem.SimpleName);

    S := StringReplace(S, '%author', ATypeList.Author, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%name', ATypeItem.SimpleName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%classinfo', GetClassInfoStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%titlename', ATypeItem.TitleName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%title', GetTitleStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%referencename', ATypeItem.ReferenceName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%sortname', ATypeItem.SortName, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%param', GetParamStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%items', ATypeItem.ItemsString, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%class', ATypeItem.ClassString, [rfReplaceAll, rfIgnoreCase]);
    S := StringReplace(S, '%nicename', TSettings.Instance.NiceName[ATypeItem.ClassString], [rfReplaceAll,
      rfIgnoreCase]);
    if not ATypeItem.CanCombine then
    begin
      S := StringReplace(S, '%summary', GetSummaryStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%description', GetDescriptionStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%seealso', CSeeAlsoDescription, [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%returns', GetReturnsStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%combine', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%refvalue', CValueReference, [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%value', ATypeItem.ValueString, [rfReplaceAll, rfIgnoreCase]);
    end
    else
    begin
      S := StringReplace(S, '%summary', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%description', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%seealso', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%returns', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%combine', GetCombineStr(ATypeItem), [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%refvalue', '', [rfReplaceAll, rfIgnoreCase]);
      S := StringReplace(S, '%value', '', [rfReplaceAll, rfIgnoreCase]);
    end;
    S := Trim(S) + #13#10#13#10;
    S := Trim(StringReplace(S, #13#10#13#10, #13#10, [rfReplaceAll]));
    S := Trim(StringReplace(S, #13#10#13#10, #13#10, [rfReplaceAll]));
    S := S + #13#10;

    FileStream.Write(PChar(S)^, Length(S));
  end;

var
  I: Integer;
begin
  FileName := IncludeTrailingPathDelimiter(TSettings.Instance.OutDir) +
    ChangeFileExt(ExtractFileName(ATypeList.FileName), '.dtx');
  if FileExists(FileName) and not TSettings.Instance.OverwriteExisting then
    Exit;

  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    { Eerst de classheaders }
    if TSettings.Instance.OutputTypeEnabled[otClassHeader] then
      for I := 0 to ATypeList.Count - 1 do
        if ATypeList[I] is TClassItem then
          WriteClassHeader(ATypeList[I]);

    { Dan de header }
    if TSettings.Instance.OutputTypeEnabled[otHeader] then
      WriteHeader;

    { Dan de rest }
    for I := 0 to ATypeList.Count - 1 do
      WriteType(ATypeList[I]);
  finally
    FileStream.Free;
  end;
end;

end.


--- NEW FILE: MainDlg.dfm ---
object Form1: TForm1
  Left = 381
  Top = 199
  Width = 507
  Height = 472
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object lblInDirDesc: TLabel
    Left = 8
    Top = 48
    Width = 70
    Height = 13
    Caption = '*.pas directory:'
  end
  object lblOutDirDesc: TLabel
    Left = 8
    Top = 96
    Width = 67
    Height = 13
    Caption = '*.dtx directory:'
  end
  object lblInDir: TLabel
    Left = 8
    Top = 72
    Width = 32
    Height = 13
    Caption = 'lblInDir'
  end
  object lblOutDir: TLabel
    Left = 8
    Top = 120
    Width = 40
    Height = 13
    Caption = 'lblOutDir'
  end
  object lsbMessages: TListBox
    Left = 0
    Top = 320
    Width = 499
    Height = 118
    Align = alBottom
    ItemHeight = 13
    TabOrder = 8
  end
  object btnSettings: TButton
    Left = 8
    Top = 8
    Width = 75
    Height = 25
    Action = actSettings
    TabOrder = 0
  end
  object lsbSource: TListBox
    Left = 8
    Top = 144
    Width = 233
    Height = 137
    ItemHeight = 13
    MultiSelect = True
    Sorted = True
    TabOrder = 1
  end
  object lsbDest: TListBox
    Left = 272
    Top = 144
    Width = 217
    Height = 137
    ItemHeight = 13
    MultiSelect = True
    Sorted = True
    TabOrder = 6
  end
  object btnInclude: TButton
    Left = 248
    Top = 144
    Width = 17
    Height = 25
    Action = actInclude
    TabOrder = 2
  end
  object btnIncludeAll: TButton
    Left = 248
    Top = 176
    Width = 17
    Height = 25
    Action = actIncludeAll
    TabOrder = 3
  end
  object btnExclude: TButton
    Left = 248
    Top = 208
    Width = 17
    Height = 25
    Action = actExclude
    TabOrder = 4
  end
  object btnExcludeAll: TButton
    Left = 248
    Top = 240
    Width = 17
    Height = 25
    Action = actExcludeAll
    TabOrder = 5
  end
  object btnProcess: TButton
    Left = 8
    Top = 288
    Width = 75
    Height = 25
    Action = actProcess
    TabOrder = 7
  end
  object Button1: TButton
    Left = 272
    Top = 288
    Width = 75
    Height = 25
    Action = actSave
    TabOrder = 9
  end
  object chbDontIncludeIgnoredFiles: TCheckBox
    Left = 272
    Top = 120
    Width = 185
    Height = 17
    Caption = 'Do not Include Ignored Files'
    Checked = True
    State = cbChecked
    TabOrder = 10
    OnClick = chbDontIncludeIgnoredFilesClick
  end
  object Button2: TButton
    Left = 360
    Top = 288
    Width = 105
    Height = 25
    Action = actAddToIgnoreList
    TabOrder = 11
  end
  object ActionList1: TActionList
    Left = 312
    Top = 80
    object actIncludeAll: TAction
      Caption = '>>'
      OnExecute = actIncludeAllExecute
      OnUpdate = actIncludeAllUpdate
    end
    object actExcludeAll: TAction
      Caption = '<<'
      OnExecute = actExcludeAllExecute
      OnUpdate = actExcludeAllUpdate
    end
    object actInclude: TAction
      Caption = '>'
      OnExecute = actIncludeExecute
      OnUpdate = actIncludeUpdate
    end
    object actExclude: TAction
      Caption = '<'
      OnExecute = actExcludeExecute
      OnUpdate = actExcludeUpdate
    end
    object actSettings: TAction
      Caption = 'Settings'
      OnExecute = actSettingsExecute
    end
    object actProcess: TAction
      Caption = 'Process'
      OnExecute = actProcessExecute
      OnUpdate = actProcessUpdate
    end
    object actSave: TAction
      Caption = 'Save'
      OnExecute = actSaveExecute
    end
    object actAddToIgnoreList: TAction
      Caption = 'Add to Ignore List'
      OnExecute = actAddToIgnoreListExecute
    end
  end
  object OpenDialog1: TOpenDialog
    Left = 176
    Top = 64
  end
  object JvProgressComponent1: TJvProgressComponent
    ProgressMin = 0
    ProgressMax = 0
    ProgressStep = 0
    ProgressPosition = 0
    Left = 224
    Top = 64
  end
end

--- NEW FILE: MainDlg.pas ---
unit MainDlg;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ActnList,

  ParserTypes, MainCtrl, Settings, JvComponent, JvProgressComponent;

type
  TForm1 = class(TForm)
    lsbMessages: TListBox;
    lblInDirDesc: TLabel;
    lblOutDirDesc: TLabel;
    lblInDir: TLabel;
    lblOutDir: TLabel;
    btnSettings: TButton;
    lsbSource: TListBox;
    lsbDest: TListBox;
    btnInclude: TButton;
    btnIncludeAll: TButton;
    btnExclude: TButton;
    btnExcludeAll: TButton;
    ActionList1: TActionList;
    actIncludeAll: TAction;
    actExcludeAll: TAction;
    actInclude: TAction;
    actExclude: TAction;
    actSettings: TAction;
    btnProcess: TButton;
    actProcess: TAction;
    Button1: TButton;
    actSave: TAction;
    chbDontIncludeIgnoredFiles: TCheckBox;
    Button2: TButton;
    actAddToIgnoreList: TAction;
    OpenDialog1: TOpenDialog;
    JvProgressComponent1: TJvProgressComponent;
    { Form }
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    { Actions }
    procedure actIncludeExecute(Sender: TObject);
    procedure actIncludeAllExecute(Sender: TObject);
    procedure actExcludeExecute(Sender: TObject);
    procedure actExcludeAllExecute(Sender: TObject);
    procedure actIncludeAllUpdate(Sender: TObject);
    procedure actExcludeAllUpdate(Sender: TObject);
    procedure actIncludeUpdate(Sender: TObject);
    procedure actExcludeUpdate(Sender: TObject);
    procedure actSettingsExecute(Sender: TObject);
    procedure actProcessExecute(Sender: TObject);
    procedure actProcessUpdate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure actSaveExecute(Sender: TObject);
    procedure chbDontIncludeIgnoredFilesClick(Sender: TObject);
    procedure actAddToIgnoreListExecute(Sender: TObject);
  private
    FMainCtrl: TMainCtrl;
  protected
    procedure MoveSelected(List: TCustomListBox; Items: TStrings);
    procedure SetItem(List: TListBox; Index: Integer);
    function GetFirstSelection(List: TCustomListBox): Integer;

    procedure SettingsChanged(Sender: TObject; ChangeType: TSettingsChangeType);
    procedure UpdateLabels;
  end;

var
  Form1: TForm1;

implementation

uses
  JclFileUtils, SettingsDlg, DelphiParser;

{$R *.dfm}

{ DONE: dubbel classes eruit halen }
{ TODO: default values uitbreiden }
{ TODO: %code toevoegen }
{ TODO: %value toevoegen }
{ DONE: constructors, destructors voor methods sorteren }
{ TODO: %scope toevoegen voor properties/methods }
{ DONE: Record fields met , ook herkennen }
{ DONE: Param fields met , ook herkennen }
{ TODO: Set -> Enumeration; Set zelf toevoegen }

procedure TForm1.actIncludeExecute(Sender: TObject);
var
  Index: Integer;
begin
  Index := GetFirstSelection(lsbSource);
  MoveSelected(lsbSource, lsbDest.Items);
  SetItem(lsbSource, Index);
end;

procedure TForm1.actIncludeAllExecute(Sender: TObject);
var
  I: Integer;
begin
  lsbDest.Items.BeginUpdate;
  try
    for I := 0 to lsbSource.Items.Count - 1 do
      lsbDest.Items.AddObject(lsbSource.Items[I],
        lsbSource.Items.Objects[I]);
  finally
    lsbDest.Items.EndUpdate;
  end;
  lsbSource.Items.Clear;
  SetItem(lsbSource, 0);
end;

procedure TForm1.actExcludeExecute(Sender: TObject);
var
  Index: Integer;
begin
  Index := GetFirstSelection(lsbDest);
  MoveSelected(lsbDest, lsbSource.Items);
  SetItem(lsbDest, Index);
end;

procedure TForm1.actExcludeAllExecute(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to lsbDest.Items.Count - 1 do
    lsbSource.Items.AddObject(lsbDest.Items[I], lsbDest.Items.Objects[I]);
  lsbDest.Items.Clear;
  SetItem(lsbDest, 0);
end;

function TForm1.GetFirstSelection(List: TCustomListBox): Integer;
begin
  for Result := 0 to List.Items.Count - 1 do
    if List.Selected[Result] then
      Exit;
  Result := LB_ERR;
end;

procedure TForm1.MoveSelected(List: TCustomListBox; Items: TStrings);
var
  I: Integer;
begin
  Items.BeginUpdate;
  try
    List.Items.BeginUpdate;
    try
      for I := List.Items.Count - 1 downto 0 do
        if List.Selected[I] then
        begin
          Items.AddObject(List.Items[I], List.Items.Objects[I]);
          List.Items.Delete(I);
        end;
    finally
      List.Items.EndUpdate;
    end;
  finally
    Items.EndUpdate;
  end;
end;

procedure TForm1.SetItem(List: TListBox; Index: Integer);
var
  MaxIndex: Integer;
begin
  with List do
  begin
    SetFocus;
    MaxIndex := List.Items.Count - 1;
    if Index = LB_ERR then
      Index := 0
    else
      if Index > MaxIndex then
      Index := MaxIndex;
    Selected[Index] := True;
  end;
end;

procedure TForm1.actIncludeAllUpdate(Sender: TObject);
begin
  actIncludeAll.Enabled := lsbSource.Items.Count > 0;
end;

procedure TForm1.actExcludeAllUpdate(Sender: TObject);
begin
  actExcludeAll.Enabled := lsbDest.Items.Count > 0;
end;

procedure TForm1.actIncludeUpdate(Sender: TObject);
begin
  actInclude.Enabled := lsbSource.SelCount > 0;
end;

procedure TForm1.actExcludeUpdate(Sender: TObject);
begin
  actExclude.Enabled := lsbDest.SelCount > 0;
end;

procedure TForm1.UpdateLabels;
begin
  with TSettings.Instance do
  begin
    lblInDir.Caption := InDir;
    lblOutDir.Caption := OutDir;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  UpdateLabels;
end;

procedure TForm1.actSettingsExecute(Sender: TObject);
begin
  TfrmSettings.Execute;
end;

procedure TForm1.actProcessExecute(Sender: TObject);
begin
  FMainCtrl.Process;
end;

procedure TForm1.actProcessUpdate(Sender: TObject);
begin
  actProcess.Enabled := lsbDest.Items.Count > 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FMainCtrl := TMainCtrl.Create;
  FMainCtrl.SkipList := lsbSource.Items;
  FMainCtrl.ProcessList := lsbDest.Items;
  FMainCtrl.MessagesList := lsbMessages.Items;

  FMainCtrl.UpdateSourceFiles;

  TSettings.Instance.RegisterObserver(Self, SettingsChanged);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  TSettings.Instance.UnRegisterObserver(Self);
  FMainCtrl.Free;
end;

procedure TForm1.SettingsChanged(Sender: TObject;
  ChangeType: TSettingsChangeType);
begin
  case ChangeType of
    ctInDirectory, ctOutDirectory:
      UpdateLabels;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
  S: string;
begin
  with TFileStream.Create('C:\Temp\allfilestemp.txt', fmCreate) do
  try
    for I := 0 to lsbDest.Items.Count - 1 do
    begin
      S := lsbDest.Items[I] + #13#10;
      Write(PChar(S)^, Length(S));
    end;
  finally
    Free;
  end;
end;

procedure TForm1.actSaveExecute(Sender: TObject);
begin
  with TSaveDialog.Create(Application) do
  try
    if Execute then
      lsbDest.Items.SaveToFile(FileName);
  finally
    Free;
  end;
end;

procedure TForm1.chbDontIncludeIgnoredFilesClick(Sender: TObject);
begin
  FMainCtrl.IgnoreFiles := chbDontIncludeIgnoredFiles.Checked;
end;

procedure TForm1.actAddToIgnoreListExecute(Sender: TObject);
var
  I: Integer;
begin
  with lsbDest do
  begin
    Items.BeginUpdate;
    try
      for I := Count - 1 downto 0 do
        if Selected[I] then
        begin
          TSettings.Instance.IgnoredUnits.Add(Items[I]);
          if FMainCtrl.IgnoreFiles then
            Items.Delete(I);
        end;
    finally
      Items.EndUpdate;
    end;
  end;

  TSettings.Instance.Save;
end;

end.


--- NEW FILE: ParserTypes.pas ---
unit ParserTypes;

interface

uses
  Classes, Contnrs;

const
  CParamDescription = 'Description for this parameter';
  CItemDescription = '  Description for %s'#13#10;
type
  TDelphiType = (dtClass, dtConst, dtDispInterface, dtFunction, dtFunctionType,
    dtInterface, dtMethodFunc, dtMethodProc, dtProcedure, dtProcedureType,
    dtProperty, dtRecord, dtResourceString, dtEnum, dtType, dtVar);

  TMethodType = (mtNormal, mtConstructor, mtDestructor);
  TDirective = (diAbstract, diCdecl, diDynamic, diObject, diOf, diOverload,
    diOverride, diPascal, diRegister, diReintroduce, diSafecall, diStdcall,
    diVirtual);
  TDirectives = set of TDirective;

const
  CDirectives: array[TDirective] of string =
  ('abstract', 'cdecl', 'dynamic', 'object', 'of', 'overload', 'override',
    'pascal', 'register', 'reintroduce', 'safecall', 'stdcall', 'virtual');

type
  TAbstractItem = class;

  TTypeList = class(TList)
  private
    FAuthor: string;
    FFileName: string;
    function GetItem(Index: Integer): TAbstractItem;
    procedure SetItem(Index: Integer; const Value: TAbstractItem);
  public
    destructor Destroy; override;
    function Add(AItem: TAbstractItem): Integer;
    function IndexOfName(const SimpleName: string): Integer;
    procedure Clear; override;
    procedure SortIt;
    procedure CalculateCombines;
    property Items[Index: Integer]: TAbstractItem read GetItem write SetItem;
    default;
    property Author: string read FAuthor write FAuthor;
    property FileName: string read FFileName write FFileName;
  end;

  (*function GetTitleStr(AItem: TAbstractItem): string;
  const
    CTitleFunction = '<TITLE %s function>';
    CTitleProcedure = '<TITLE %s procedure>';
    CTitleType = '<TITLE %s type>';
  begin
    case AItem.DelphiType of
      dtFunction:
        Result := Format(CTitleFunction, [AItem.Name]);
      dtProcedure:
        Result := Format(CTitleProcedure, [AItem.Name]);
      dtType, dtRecord, dtEnum, dtProcedureType, dtFunctionType:
        Result := Format(CTitleType, [AItem.Name]);
    else
      Result := '';
    end;
  end;*)

  TAbstractItem = class(TObject)
  private
    FTypeList: TTypeList;
    FSimpleName: string;
    FCombineList: TObjectList;
    FCombineWithList: TObjectList;
    function GetDelphiType: TDelphiType; virtual; abstract;
    function GetItemsString: string; virtual;
    function GetRealParamString: string; virtual;
    function GetParamString: string; virtual;

    function GetReferenceName: string; virtual;
    function GetSortName: string; virtual;
    function GetTitleName: string; virtual;

    function GetValueString: string; virtual;
    function GetClassString: string; virtual;
    function GetCombineString: string; virtual;
    function GetCanCombine: Boolean;
    function GetCombineCount: Integer;
    function GetCombineWithCount: Integer;
    function GetAddDescriptionString: string; virtual;
  protected
    procedure AddCombine(AItem: TAbstractItem);
    procedure AddCombineWith(AItem: TAbstractItem);
  public
    constructor Create(const AName: string); virtual;
    property TypeList: TTypeList read FTypeList;
    { Simple name,   zonder . zonder @ }
    property SimpleName: string read FSimpleName write FSimpleName;
    { Reference name       met @ met . }
    property ReferenceName: string read GetReferenceName;
    { Title name     zonder . met 'function', 'type', 'procedure' }
    property TitleName: string read GetTitleName;
    property SortName: string read GetSortName;
    property DelphiType: TDelphiType read GetDelphiType;
    property ItemsString: string read GetItemsString;
    property ParamString: string read GetParamString;
    property RealParamString: string read GetRealParamString;
    property ValueString: string read GetValueString;
    property ClassString: string read GetClassString;
    property CombineString: string read GetCombineString;
    property AddDescriptionString: string read GetAddDescriptionString;
    { Voor function of object type > 0 als > 1 dan CanCombine = false }
    property CombineCount: Integer read GetCombineCount;
    { Voor event property = 1 }
    property CombineWithCount: Integer read GetCombineWithCount;
    property CanCombine: Boolean read GetCanCombine;
    { Returns CombineList }
  end;

  TValueItem = class(TAbstractItem)
  private
    FValue: string;
    function GetValueString: string; override;
  public
    property Value: string read FValue write FValue;
  end;

  TListItem = class(TAbstractItem)
  private
    FItems: TStringList;
    function GetItemsString: string; override;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    property Items: TStringList read FItems;
  end;

  TBaseFuncItem = class(TAbstractItem)
  private
    FParams: TStringList;
    FParamTypes: TStringList;
    FDirectives: TDirectives;
    function GetRealParamString: string; override;
    function GetReferenceName: string; override;
    function GetAddDescriptionString: string; override;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    property Params: TStringList read FParams;
    property ParamTypes: TStringList read FParamTypes;
    property Directives: TDirectives read FDirectives write FDirectives;
  end;

  TClassItem = class;

  TClassMethod = class(TAbstractItem)
  private
    FOwnerClass: TClassItem;
    function GetReferenceName: string; override;
    function GetClassString: string; override;
  public
    property OwnerClass: TClassItem read FOwnerClass write FOwnerClass;
  end;

  TParamClassMethod = class(TClassMethod)
  private
    FParams: TStringList;
    FParamTypes: TStringList;
    FDirectives: TDirectives;
    function GetRealParamString: string; override;
    function GetReferenceName: string; override;
    function GetAddDescriptionString: string; override;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    property Params: TStringList read FParams;
    property ParamTypes: TStringList read FParamTypes;
    property Directives: TDirectives read FDirectives write FDirectives;
  end;

  TClassItem = class(TAbstractItem)
  private
    FList: TList;
    function GetItem(Index: Integer): TAbstractItem;
    procedure SetItem(Index: Integer; const Value: TAbstractItem);
    function GetDelphiType: TDelphiType; override;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    procedure AddProcedure(AItem: TClassMethod);
    procedure AddFunction(AItem: TClassMethod);
    procedure AddProperty(AItem: TClassMethod);
    property Items[Index: Integer]: TAbstractItem read GetItem write SetItem;
    default;
  end;

  TConstItem = class(TValueItem)
  private
    function GetDelphiType: TDelphiType; override;
  end;

  TFunctionItem = class(TBaseFuncItem)
  private
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TFunctionTypeItem = class(TBaseFuncItem)
  private
    function GetAddDescriptionString: string; override;
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TMethodFunc = class(TParamClassMethod)
  private
    function GetDelphiType: TDelphiType; override;
  end;

  TMethodProc = class(TParamClassMethod)
  private
    FMethodType: TMethodType;
    function GetDelphiType: TDelphiType; override;
    function GetSortName: string; override;
  public
    property MethodType: TMethodType read FMethodType write FMethodType;
  end;

  TMethodProp = class(TClassMethod)
  private
    FInheritedProp: Boolean;
    FTypeStr: string;
    function GetParamString: string; override;
    function GetDelphiType: TDelphiType; override;
  public
    property InheritedProp: Boolean read FInheritedProp write FInheritedProp;
    property TypeStr: string read FTypeStr write FTypeStr;
  end;

  TProcedureItem = class(TBaseFuncItem)
  private
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TProcedureTypeItem = class(TBaseFuncItem)
  private
    function GetAddDescriptionString: string; override;
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TRecordItem = class(TListItem)
  private
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TResourceStringItem = class(TValueItem)
  private
    function GetDelphiType: TDelphiType; override;
  end;

  TEnumItem = class(TListItem)
  private
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TTypeItem = class(TValueItem)
  private
    function GetAddDescriptionString: string; override;
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

  TVarItem = class(TValueItem)
  private
    function GetTitleName: string; override;
    function GetDelphiType: TDelphiType; override;
  end;

implementation

uses
  SysUtils,
  Math; // voor Max

const
  CTitleFunction = '%s function';
  CTitleProcedure = '%s procedure';
  CTitleType = '%s type';
  CTitleVariable = '%s variable';

function FillTo(const S: string; Count: Integer): string;
begin
  SetLength(Result, Count);
  FillChar(PChar(Result)^, Count, ' ');
  Move(PChar(S)^, PChar(Result)^, Length(S));
end;

function ParamListToString(AStrings: TStrings): string;
var
  I: Integer;
  MaxLength: Integer;
begin
  Result := '';
  if AStrings.Count = 0 then
    Exit;

  MaxLength := -1;
  for I := 0 to AStrings.Count - 1 do
    MaxLength := Max(MaxLength, Length(AStrings[I]));
  Inc(MaxLength);
  for I := 0 to AStrings.Count - 1 do
    Result := Result + '  ' + FillTo(AStrings[I], MaxLength) + '- ' + CParamDescription + #13#10;
  { Laatste return eraf halen }
  Delete(Result, Length(Result) - 1, 2);
end;

{ TAbstractItem }

procedure TAbstractItem.AddCombine(AItem: TAbstractItem);
begin
  if not Assigned(FCombineList) then
    FCombineList := TObjectList.Create(False);

  FCombineList.Add(AItem);
end;

procedure TAbstractItem.AddCombineWith(AItem: TAbstractItem);
begin
  if not Assigned(FCombineWithList) then
    FCombineWithList := TObjectList.Create(False);

  FCombineWithList.Add(AItem);
end;

constructor TAbstractItem.Create(const AName: string);
begin
  FSimpleName := AName;
end;

function TAbstractItem.GetAddDescriptionString: string;
begin
  Result := '';
end;

function TAbstractItem.GetCanCombine: Boolean;
begin
  Result := CombineCount = 1;
end;

(*function TAbstractItem.GetCanCombineWith: Boolean;
var
  I: Integer;
begin
  Result := Assigned(FCombineWithList) and (CombineWithCount > 0);

  if not Result then
    Exit;

  Result := False;
  for I := 0 to FCombineWithList.Count - 1 do
    Result := Result or (TAbstractItem(FCombineWithList[I]).CombineCount = 1);
end;*)

function TAbstractItem.GetClassString: string;
begin
  Result := '';
end;

function TAbstractItem.GetCombineCount: Integer;
begin
  if Assigned(FCombineList) then
    Result := FCombineList.Count
  else
    Result := 0;
end;

function TAbstractItem.GetCombineString: string;
begin
  if Assigned(FCombineList) and (FCombineList.Count = 1) then
    Result := TAbstractItem(FCombineList[0]).ReferenceName
  else
    Result := '';
end;

function TAbstractItem.GetCombineWithCount: Integer;
begin
  if Assigned(FCombineWithList) then
    Result := FCombineWithList.Count
  else
    Result := 0;
end;

(*function TAbstractItem.GetCombineWithString: string;
begin
  Result := '';
end;*)

function TAbstractItem.GetItemsString: string;
begin
  Result := '';
end;

function TAbstractItem.GetParamString: string;
begin
  if CanCombine then
    Result := ''
  else
    Result := RealParamString;
end;

function TAbstractItem.GetRealParamString: string;
begin
  Result := '';
end;

function TAbstractItem.GetReferenceName: string;
begin
  Result := SimpleName;
end;

function TAbstractItem.GetSortName: string;
begin
  { Standaard de complete naam gebruiken, bij constructors, destructors
    doen we wat anders }
  Result := ReferenceName;
end;

function TAbstractItem.GetTitleName: string;
begin
  Result := '';
end;

function TAbstractItem.GetValueString: string;
begin
  Result := '';
end;

{ TBaseFuncItem }

constructor TBaseFuncItem.Create(const AName: string);
begin
  inherited Create(AName);
  FParams := TStringList.Create;
  FParamTypes := TStringList.Create;
end;

destructor TBaseFuncItem.Destroy;
begin
  FParams.Free;
  FParamTypes.Free;
  inherited;
end;

function TBaseFuncItem.GetReferenceName: string;
var
  I: Integer;
begin
  Result := inherited GetReferenceName;

  if not (diOverload in Directives) then
    Exit;

  for I := 0 to FParamTypes.Count - 1 do
    Result := Result + '@' + FParamTypes[I];
end;

function TBaseFuncItem.GetRealParamString: string;
begin
  Result := ParamListToString(FParams);
end;

function TBaseFuncItem.GetAddDescriptionString: string;
begin
  if diOverload in Directives then
    Result :=
      '  This is an overloaded function/procedure, if possible you may combine the description'#13#10 +
      '  of all these functions into 1 general description. If you do so, combine all "Parameter" '#13#10 +
      '  lists into 1 list, and leave the "Summary", "Description" etc. fields empty for all'#13#10 +
      '  other overloaded functions with the same name.'#13#10
  else
    Result := '';
end;

{ TListItem }

constructor TListItem.Create(const AName: string);
begin
  inherited Create(AName);
  FItems := TStringList.Create;
end;

destructor TListItem.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TListItem.GetItemsString: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to FItems.Count - 1 do
    Result := Result + '@@' + ReferenceName + '.' + FItems[I] + #13#10 + Format(CItemDescription, [FItems[I]]);
  if Result > '' then
    { Laatste enter weghalen }
    Delete(Result, Length(Result) - 1, 2);
end;

{ TClassItem }

procedure TClassItem.AddFunction(AItem: TClassMethod);
begin
  AItem.FOwnerClass := Self;
  FList.Add(AItem);
end;

procedure TClassItem.AddProcedure(AItem: TClassMethod);
begin
  AItem.FOwnerClass := Self;
  FList.Add(AItem);
end;

procedure TClassItem.AddProperty(AItem: TClassMethod);
begin
  AItem.FOwnerClass := Self;
  FList.Add(AItem);
end;

constructor TClassItem.Create(const AName: string);
begin
  inherited Create(AName);
  FList := TList.Create;
end;

destructor TClassItem.Destroy;
begin
  FList.Free;
  inherited;
end;

function TClassItem.GetDelphiType: TDelphiType;
begin
  Result := dtClass;
end;

function TClassItem.GetItem(Index: Integer): TAbstractItem;
begin
  Result := FList[Index];
end;

procedure TClassItem.SetItem(Index: Integer; const Value: TAbstractItem);
begin
  FList[Index] := Value;
end;

{ TTypeList }

function TTypeList.Add(AItem: TAbstractItem): Integer;
begin
  AItem.FTypeList := Self;
  Result := inherited Add(AItem);
end;

procedure TTypeList.CalculateCombines;
var
  I: Integer;

  procedure Examine(const S: string);
  var
    Indx: Integer;
  begin
    Indx := IndexOfName(S);
    if Indx < 0 then
      Exit;

    Items[I].AddCombine(Items[Indx]);
    Items[Indx].AddCombineWith(Items[I]);
  end;

  procedure ExamineEvent(const S: string);
  var
    Indx: Integer;
  begin
    if S = '' then
      Exit;

    Indx := 0;
    while Indx < Count do
    begin
      if (Items[Indx] is TMethodProp) and SameText(TMethodProp(Items[Indx]).TypeStr, S) then
      begin
        Items[I].AddCombine(Items[Indx]);
        Items[Indx].AddCombineWith(Items[I]);
      end;

      Inc(Indx);
    end;
  end;

var
  S: string;
begin
  for I := 0 to Count - 1 do
    if Items[I] is TTypeItem then
    begin
      S := Items[I].ValueString;
      if S = '' then
        Continue;

      if StrLIComp(PChar(S), 'set of', 6) = 0 then
      begin
        S := Trim(Copy(S, 8, MaxInt));
        while (Length(S) > 0) and (S[Length(S)] in [' ', ';']) do
          System.Delete(S, Length(S), 1);

        Examine(S);
        Continue;
      end;

      if S[1] = '^' then
      begin
        System.Delete(S, 1, 1);
        S := Trim(S);
        while (Length(S) > 0) and (S[Length(S)] in [' ', ';']) do
          System.Delete(S, Length(S), 1);

        Examine(S);
        Continue;
      end;
    end
    else
      if (Items[I] is TFunctionTypeItem) or (Items[I] is TProcedureTypeItem) then
    begin
      S := Items[I].SimpleName;
      ExamineEvent(S);
    end;
end;

procedure TTypeList.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    Items[I].Free;
  inherited;
end;

destructor TTypeList.Destroy;
begin
  Clear;
  inherited;
end;

function TTypeList.GetItem(Index: Integer): TAbstractItem;
begin
  Result := inherited Items[Index];
end;

function TTypeList.IndexOfName(const SimpleName: string): Integer;
begin
  Result := 0;
  while (Result < Count) and not SameText(Items[Result].SimpleName, SimpleName) do
    Inc(Result);
  if Result >= Count then
    Result := -1;
end;

procedure TTypeList.SetItem(Index: Integer; const Value: TAbstractItem);
begin
  inherited Items[Index] := Value;
end;

function SortCompare(Item1, Item2: Pointer): Integer;
begin
  Result := CompareText(TAbstractItem(Item1).SortName,
    TAbstractItem(Item2).SortName);
end;

procedure TTypeList.SortIt;
begin
  Sort(SortCompare);
end;

{ TParamClassMethod }

constructor TParamClassMethod.Create(const AName: string);
begin
  inherited Create(AName);
  FParams := TStringList.Create;
  FParamTypes := TStringList.Create;
end;

destructor TParamClassMethod.Destroy;
begin
  FParams.Free;
  FParamTypes.Free;
  inherited;
end;

function TParamClassMethod.GetReferenceName: string;
var
  I: Integer;
begin
  Result := inherited GetReferenceName;

  if not (diOverload in Directives) then
    Exit;

  for I := 0 to FParamTypes.Count - 1 do
    Result := Result + '@' + FParamTypes[I];
end;

function TParamClassMethod.GetRealParamString: string;
begin
  Result := ParamListToString(FParams);
end;

function TParamClassMethod.GetAddDescriptionString: string;
begin
  if diOverload in Directives then
    Result :=
      '  This is an overloaded function/procedure, if possible you may combine the description'#13#10 +
      '  of all these functions into 1 general description. If you do so, combine all "Parameter" '#13#10 +
      '  lists into 1 list, and leave the "Summary", "Description" etc. fields empty for all'#13#10 +
      '  other overloaded functions with the same name.'#13#10
  else
    Result := '';
end;

{ TVarItem }

function TVarItem.GetDelphiType: TDelphiType;
begin
  Result := dtVar;
end;

function TVarItem.GetTitleName: string;
begin
  Result := Format(CTitleVariable, [SimpleName]);
end;

{ TTypeItem }

function TTypeItem.GetAddDescriptionString: string;
begin
  Result :=
    '  You don''t have to document already described items such as sets,'#13#10 +
    '  pointers to records etc.'#13#10;
end;

function TTypeItem.GetDelphiType: TDelphiType;
begin
  Result := dtType;
end;

function TTypeItem.GetTitleName: string;
begin
  Result := Format(CTitleType, [SimpleName]);
end;

{ TEnumItem }

function TEnumItem.GetDelphiType: TDelphiType;
begin
  Result := dtEnum;
end;

function TEnumItem.GetTitleName: string;
begin
  Result := Format(CTitleType, [SimpleName]);
end;

{ TResourceStringItem }

function TResourceStringItem.GetDelphiType: TDelphiType;
begin
  Result := dtResourceString;
end;

{ TRecordItem }

function TRecordItem.GetDelphiType: TDelphiType;
begin
  Result := dtRecord;
end;

function TRecordItem.GetTitleName: string;
begin
  Result := Format(CTitleType, [SimpleName]);
end;

{ TProcedureTypeItem }

function TProcedureTypeItem.GetAddDescriptionString: string;
var
  I: Integer;
begin
  Result := '  This type is used by (for reference):'#13#10;
  if not Assigned(FCombineList) or (CombineCount = 0) then
  begin
    Result := Result + '    Nothing in this unit.'#13#10;
    Exit;
  end;

  for I := 0 to FCombineList.Count - 1 do
    Result := Result + Format('    %s'#13#10, [TAbstractItem(FCombineList[I]).ReferenceName]);
end;

function TProcedureTypeItem.GetDelphiType: TDelphiType;
begin
  Result := dtProcedureType;
end;

function TProcedureTypeItem.GetTitleName: string;
begin
  Result := Format(CTitleType, [SimpleName]);
end;

{ TProcedureItem }

function TProcedureItem.GetDelphiType: TDelphiType;
begin
  Result := dtProcedure;
end;

function TProcedureItem.GetTitleName: string;
begin
  Result := Format(CTitleProcedure, [SimpleName]);
end;

{ TMethodProp }

function TMethodProp.GetDelphiType: TDelphiType;
begin
  Result := dtProperty;
end;

function TMethodProp.GetParamString: string;
begin
  if (CombineWithCount = 1) and (TAbstractItem(FCombineWithList[0]).CombineCount = 1) then
    Result := TAbstractItem(FCombineWithList[0]).RealParamString
  else
    Result := '';
end;

{ TMethodProc }

function TMethodProc.GetDelphiType: TDelphiType;
begin
  Result := dtMethodProc;
end;

function TMethodProc.GetSortName: string;
begin
  case MethodType of
    mtNormal: Result := inherited GetSortName;
    mtConstructor: Result := OwnerClass.SortName + '.'#1 + SimpleName;
    mtDestructor: Result := OwnerClass.SortName + '.'#2 + SimpleName;
  else
    begin
      Assert(False, 'GetSortName');
      Result := '';
    end;
  end;
end;

{ TMethodFunc }

function TMethodFunc.GetDelphiType: TDelphiType;
begin
  Result := dtMethodFunc;
end;

{ TFunctionTypeItem }

function TFunctionTypeItem.GetAddDescriptionString: string;
var
  I: Integer;
begin
  if not Assigned(FCombineList) or (CombineCount = 0) then
  begin
    Result := '    Nothing in this unit.';
    Exit;
  end;

  Result := '';
  for I := 0 to FCombineList.Count - 1 do
    Result := Result + Format('    %s'#13#10, [TAbstractItem(FCombineList[I]).ReferenceName]);
end;

function TFunctionTypeItem.GetDelphiType: TDelphiType;
begin
  Result := dtFunctionType;
end;

function TFunctionTypeItem.GetTitleName: string;
begin
  Result := Format(CTitleType, [SimpleName]);
end;

{ TFunctionItem }

function TFunctionItem.GetDelphiType: TDelphiType;
begin
  Result := dtFunction;
end;

function TFunctionItem.GetTitleName: string;
begin
  Result := Format(CTitleFunction, [SimpleName]);
end;

{ TConstItem }

function TConstItem.GetDelphiType: TDelphiType;
begin
  Result := dtConst;
end;

{ TClassMethod }

function TClassMethod.GetClassString: string;
begin
  Result := OwnerClass.SimpleName;
end;

function TClassMethod.GetReferenceName: string;
begin
  Result := OwnerClass.ReferenceName + '.' + inherited GetReferenceName;
end;

{ TValueItem }

function TValueItem.GetValueString: string;
begin
  Result := FValue;
end;

end.


--- NEW FILE: Settings.pas ---
unit Settings;

interface

uses
  Classes;

type
  TOutputType = (otClass, otClassHeader, otConst, otDispInterface, otFunction,
    otFunctionType,
    otHeader, otInterface, otProcedure, otProcedureType, otProperty, otRecord,
    otResourceString, otSet, otType, otVar);

  TOutputTypeBool = array[TOutputType] of Boolean;
  TOutputTypeStrs = array[TOutputType] of string;
  TOutputTypeStrings = array[TOutputType] of TStringList;

  TSettingsChangeType = (ctInDirectory, ctOutDirectory);
  TSettingsChangeEvent = procedure(Sender: TObject;
    ChangeType: TSettingsChangeType) of object;

  TSettings = class(TPersistent)
  private
    FInDir: string;
    FOutDir: string;
    FOutputTypeDefaults: TOutputTypeStrs;
    FOutputTypeDesc: TOutputTypeStrings;
    FOutputTypeStrings: TOutputTypeStrings;
    FNiceNameClass: TStringList;
    FNiceNameDesc: TStringList;
    FOverwriteExisting: Boolean;
    FOutputTypeEnabled: TOutputTypeBool;
    FIgnoredUnits: TStringList;
    FRegisteredClasses: TStringList;

    { Observer }
    FObservers: TList;
    FChangeEvents: TList;
    FDefaultNiceName: string;
    FAcceptCompilerDirectives: TStrings;

    procedure SetInDir(const Value: string);
    procedure SetOutDir(const Value: string);
    procedure SetOverwriteExisting(const Value: Boolean);
    function GetOutputTypeDefaults(const OutputType: TOutputType): string;
    procedure SetOutputTypeDefaults(const OutputType: TOutputType; const Value: string);
    function GetOutputTypeDesc(const OutputType: TOutputType): TStringList;
    function GetOutputTypeStrings(const OutputType: TOutputType): TStringList;
    function GetNiceName(const AClassName: string): string;
    function GetOutputTypeEnabled(const OutputTYpe: TOutputType): Boolean;
    procedure SetOutputTypeEnabled(const OutputTYpe: TOutputType; const Value: Boolean);
    procedure SetAcceptCompilerDirectives(const Value: TStrings);
    function GetFileName: string;
  protected
    procedure DoEvent(ChangeType: TSettingsChangeType);

    procedure DoLoad;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    class function Instance: TSettings;

    procedure Load;
    procedure Save;

    procedure RegisterObserver(Observer: TObject; Event: TSettingsChangeEvent = nil); virtual;
    procedure UnRegisterObserver(Observer: TObject); virtual;

    procedure Reset;
    procedure Assign(Source: TPersistent); override;

    function IsRegisteredClass(const S: string): Boolean;
    function IsIgnoredUnit(const S: string): Boolean;

    property IgnoredUnits: TStringList read FIgnoredUnits;
    property RegisteredClasses: TStringList read FRegisteredClasses;
    property InDir: string read FInDir write SetInDir;
    property OutDir: string read FOutDir write SetOutDir;
    property OverwriteExisting: Boolean read FOverwriteExisting write
      SetOverwriteExisting;
    property OutputTypeDefaults[const OutputType: TOutputType]: string read
    GetOutputTypeDefaults write SetOutputTypeDefaults;
    property OutputTypeDesc[const OutputType: TOutputType]: TStringList read
    GetOutputTypeDesc;
    property OutputTypeStrings[const OutputType: TOutputType]: TStringList read
    GetOutputTypeStrings;
    property OutputTypeEnabled[const OutputTYpe: TOutputType]: Boolean read
    GetOutputTypeEnabled write SetOutputTypeEnabled;

    property NiceNameClass: TStringList read FNiceNameClass;
    property NiceNameDesc: TStringList read FNiceNameDesc;
    property DefaultNiceName: string read FDefaultNiceName write
      FDefaultNiceName;
    property AcceptCompilerDirectives: TStrings read FAcceptCompilerDirectives write
      SetAcceptCompilerDirectives;

    property NiceName[const AClassName: string]: string read GetNiceName;

    property FileName: string read GetFileName;
  end;

implementation

uses
  SysUtils, Forms, IniFiles;

const
  COutputTypeSection: array[TOutputType] of string = (
    'Class', {otClass}
    'ClassHeader', {otClassHeader}
    'Const', {otConst}
    'DispInterface', {otDispInterface}
    'Function', {otFunction}
    'FunctionType', {otFunctionType}
    'Header', {otHeader}
    'Interface', {otInterface}
    'Pro...
 
[truncated message content]