FDC Generic Command Line Parser for Delphi 10.3.x

FDC.CommandLine.pas

unit FDC.CommandLine;

///  <summary>
///  Written by Lars Fosdal, August 2019, Delphi 10.3.1
///  Your license to use and modify follows the Attribution-ShareAlike 4.0 International (CC BY-SA 4.0) license rules.
///  https://creativecommons.org/licenses/by-sa/4.0/
///  </summary>

interface
uses
  System.Classes, System.StrUtils, System.SysUtils, System.SyncObjs,
  System.Generics.Defaults, System.Generics.Collections, System.RTTI, System.TypInfo;

type
  TCmdDebugOutHandler = reference to procedure(const aMsg: string);
  procedure SetCmdDebugOutHandler(const aHandler: TCmdDebugOutHandler);
  procedure CmdDebugOut(const aMsg: string);


type
  /// <summary> A value assigned to an option </summary>
  TParam = class abstract
  protected
    function GetAsString: string; virtual; abstract;
    procedure SetAsString(const aValue: string); virtual; abstract;
    function Debug: string;
  public
    constructor Create; virtual; abstract;
    property AsString: string read GetAsString write SetAsString;
  end;

  const
   CmdSwitch: TSysCharSet = ['-', '+', '/'];
   CmdName: TSysCharSet   = ['a'..'z', 'A'..'Z', '0'..'9', '_', '?', '&', '#', '%'];
   CmdSpace: TSysCharSet  = [' ', ^I];
   CmdFlag: TSysCharSet   = ['+', '-', '=', ':'];
   CmdList: TSysCharSet   = [';', ','];

type
  ///  <summary> An option may contain multiple parameters
  ///  <code>/option1=" a parameter " /option2=(param1, param2, "param 3") /option3+ --option4-</code>
  ///  </summary>
  TOption = class abstract
  private
    FName: string;
    FSwitch: string;
    FFlag: string;
    FGiven: Boolean;
    FOrder: Integer;
  protected
    function Add: TParam; virtual; abstract;
    function Duplicate: string; virtual; abstract;
  public
    constructor Create; virtual; abstract;
    /// <summary> Clears values of options, but does not remove them - unlike Clear </summary>
    procedure ClearValues; virtual; abstract;
    /// <summary> Option debug info </summary>
    function Debug: string; virtual; abstract;
    /// <summary> First parameter value </summary>
    function AsString: string; virtual; abstract;
    /// <summary> All parameter values as string </summary>
    function AsStringList: TArray<string>; virtual; abstract;
    /// <summary> Option name as in /option </summary>
    property Name: string read FName write FName;
    /// <summary> Leading switch(es) </summary>
    property Switch: string read FSwitch write FSwitch;
    /// <summary> Trailing flag(s) </summary>
    property Flag: string read FFlag write FFlag;
    /// <summary> True if found in parsing </summary>
    property Given: Boolean read FGiven write FGiven;
    /// <summary> Order in parsed string </summary>
    property Order: Integer read FOrder write FOrder;

  end;

  /// <summary> Generic parameter value of type T</summary>
  TParam<T> = class(TParam)
  private
    FValue: T;
    FParent: TOption;
  protected
    function GetAsString: string; override;
    procedure SetAsString(const aValue: string); override;
    property Parent: TOption read FParent write FParent;
  public
    constructor Create; override;
    property Value: T read FValue write FValue;
  end;

  /// <summary><para>Option containing parameters of type T. The default type of unknown options is String.</para>
  /// <para>This can be extended by adding predefined typed options before parsing.</para>
  /// <para>Supports string, int, float, and enumerated types.</para></summary>
  TOption<T> = class(TOption)
  type
    TParamList = class(TObjectList<TParam<T>>);
  private
    FParams: TParamList;
    FDefaultValue: T;
    function GetValue: T;
    function GetValueList: TArray<T>;
  protected
    function Add: TParam; override;
    function Duplicate: string; override;
    property Params: TParamList read FParams;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure ClearValues; override;
    function Debug: string; override;
    function AsString: string; override;
    function AsStringList: TArray<string>; override;
    function MultiParams: Boolean;
    property DefaultValue: T read FDefaultValue write FDefaultValue;
    property Value: T read GetValue;
    property ValueList: TArray<T> read GetValueList;
  end;
  /// <summary> The actual parser that collects options and their parameters </summary>
  TOptionParser = class(TObjectDictionary<string, TOption>)
  type
    TOptionComparer = class(TComparer<TOption>)
      function Compare(const Left, Right: TOption): Integer; override;
    end;
  public
    constructor Create; reintroduce; virtual;
    procedure ClearValues;
    function Declare<T>(const aName: String; const aDefaultValue: T): TOption<T>; overload;
    procedure Declare(const aName: String; aOption: TOption); overload;
    function Duplicate: string;
    function DuplicateExcluding(const aNames: TArray<String>): String;
    procedure Parse(aOptions: string);
    function Given(const aName: string): boolean;
    function Option<T>(const aName: string): TOption<T>;
    function AsString(const aName: string; const aDefault: string = ''): string;
    function AsStringList(const aName: string): TArray<string>;
    procedure Debug(const Strings: TStrings);
  end;

  TCommandLine = class(TOptionParser)
  private
    FCmdLn: string;
  public
    constructor Create; override;
    property CmdLn: string read FCmdLn;
  end;

  function CommandLine: TCommandLine;
  function CommandLineStr(const aName:String; const aDefault:String = ''): string;

implementation

var
  CallDebugOut: TCmdDebugOutHandler;

procedure CmdDebugOut(const aMsg: string);
begin
  CallDebugOut(aMsg);
end;

procedure SetCmdDebugOutHandler(const aHandler: TCmdDebugOutHandler);
begin
  CallDebugOut := aHandler;
end;

procedure NoOutput(const aMsg: string);
begin
    // send this somewhere
end;

{ TParam }

function TParam.Debug: string;
begin
  Result := AsString;
  if Pos(' ', Result) > 0
  then begin
    if Pos('"', Result)> 0
     then Result := '''' + Result + ''''
      else Result := '"' + Result + '"';
  end;
end;

{ TParam<T> }

constructor TParam<T>.Create;
begin
  Inherited;
  FValue := Default(T);
end;

function TParam<T>.GetAsString: string;
var
  TV: TValue;
begin
  TV := TValue.From<T>(FValue);
  Result := TV.AsString;
end;

procedure TParam<T>.SetAsString(const aValue: string);
var
  TV: TValue;
begin
  TV := TValue.From<T>(Default(T));
  try
    case TV.Kind of
      tkEnumeration: TV := TValue.FromOrdinal(TypeInfo(T), GetEnumValue(TypeInfo(T), aValue));
      tkInteger: TV := TValue.From<Integer>(StrToInt(aValue));
      tkInt64:   TV := TValue.From<Int64>(StrToInt(aValue));
      tkFloat:   TV := TValue.From<Extended>(StrToFloat(aValue));
            else TV := TValue.From<String>(aValue);
    end;
    FValue := TV.AsType<T>;
  except
    on E:Exception
    do begin
      CmdDebugOut(Parent.Debug + ': "' + aValue + '" -> ' + E.Message);
      FValue := Default(T);
    end;
  end;
end;

{ TOptionParser.TOptionComparer }

function TOptionParser.TOptionComparer.Compare(const Left, Right: TOption): Integer;
begin
  if (Left.Order < Right.Order)
   then Result := -1
  else if (Left.Order > Right.Order)
   then Result := 1
  else Result := 0;
end;

{ TOption<T> }

procedure TOption<T>.ClearValues;
begin
  FGiven := False;
  FParams.Clear;
end;

constructor TOption<T>.Create;
begin
  inherited;
  FName := '';
  FSwitch := '';
  FFlag := '';
  FGiven := False;
  FOrder := 0;
  FDefaultValue := Default(T);
  FParams := TParamList.Create;
end;

destructor TOption<T>.Destroy;
begin
  FParams.Free;
  inherited;
end;

function TOption<T>.Add: TParam;
begin
  var p:= TParam<T>.Create;
  p.Parent := Self;
  Result := p;
  FParams.Add(p);
end;

function TOption<T>.Duplicate: string;
var
  ParamValues, Semi: string;
begin
  ParamValues := '';
  if Params.Count = 1
  then ParamValues := Params[0].Debug
  else begin
    semi := '';
    for var p in params
    do begin
      ParamValues := ParamValues + Semi + p.Debug;
      semi := ';'
    end;
    if ParamValues <> ''
     then ParamValues := '(' + ParamValues + ')';
  end;
  Result := Switch + Name + Flag + ParamValues;
end;

function TOption<T>.Debug: string;
begin
  Result := Order.ToString + ' ' + Duplicate;
end;

function TOption<T>.AsString: string;
begin
  if Params.Count > 0
   then Result := Params[0].AsString
    else Result := '';
end;

function TOption<T>.AsStringList: TArray<string>;
begin
  Result := [];
  if Params.Count > 0
  then begin
    for var p in Params
    do Result := Result + [p.AsString];
  end;
end;

function TOption<T>.GetValue: T;
begin
  if Params.Count > 0
  then Result := Params[0].Value
  else Result := DefaultValue;
end;

function TOption<T>.GetValueList: TArray<T>;
begin
  SetLength(Result, Params.Count);
  for var ix := 0 to Params.Count - 1
   do Result[ix] := Params[ix].Value;
end;

function TOption<T>.MultiParams: Boolean;
begin
  Result := Params.Count > 1;
end;

{ TOptionParser }

function TOptionParser.AsString(const aName: string; const aDefault: string = ''): string;
var
  Option: TOption;
begin
  if TryGetValue(LowerCase(aName), Option) 
   then Result := Option.AsString
    else Result := '';
  if Result = '' 
   then Result := aDefault;
end;

function TOptionParser.AsStringList(const aName: string): TArray<string>;
var
  Option: TOption;
begin
  if TryGetValue(LowerCase(aName), Option) 
   then Result := Option.AsStringList
    else Result := [];
end;

constructor TOptionParser.Create;
begin
  Inherited Create([doOwnsValues], 19);
end;

procedure TOptionParser.ClearValues;
begin
  for var Option in Values
   do Option.ClearValues;
end;

procedure TOptionParser.Debug(const Strings: TStrings);
begin
  for var Option in Values
   do Strings.Add(Option.Debug);
end;

procedure TOptionParser.Declare(const aName: String; aOption: TOption);
begin
  aOption.Name := aName;
  Add(LowerCase(aName), aOption);
end;

function TOptionParser.Declare<T>(const aName: String; const aDefaultValue: T): TOption<T>;
begin
  Result := TOption<T>.Create;
  Result.DefaultValue := aDefaultValue;
  Declare(aName, Result);
end;

function TOptionParser.Duplicate: string;
begin
  Result := DuplicateExcluding([]);
end;

function TOptionParser.DuplicateExcluding(const aNames: TArray<String>): String;
var
  List: TList<TOption>;
  opt: TOption;
  comp: TOptionComparer;
begin
  List := TList<TOption>.Create;
  try
    for opt in self.Values
    do begin
      for var name in aNames
      do if CompareText(name, opt.Name) = 0
       then Continue;
      List.Add(opt);
    end;
    comp := TOptionComparer.Create;
    try
      List.Sort(comp);
    finally
      comp.Free;
    end;
    Result := '';
    for opt in List
    do Result := Result + ' ' + opt.Duplicate;
  finally
    List.Free;
  end;
end;

function TOptionParser.Given(const aName: string): boolean;
var
  Option: TOption;
begin
  if TryGetValue(LowerCase(aName), Option)
   then Result := Option.Given
    else Result := False;
end;

function TOptionParser.Option<T>(const aName: string): TOption<T>;
var
  Option: TOption;
begin
  if TryGetValue(LowerCase(aName), Option)
   then Result := Option as TOption<T>
    else Result := nil;
end;

///  Without arguments: option /option -option --option
///
///  With flag: option- /option+ -option+ --option-
///
///  With single value: option:value /option : value -option= 0  --option: 2019.04.01
///
///  With quoted values - any character can be allowed in a quoted string until a matching end quote is found
///  option:"This is 'a' string"   /option: 'This is "a" string'
///
///  With a list of values: option:("some filename" ; 'another file name')

procedure TOptionParser.Parse(aOptions: string);

  function Get(chSet: TSysCharSet): String;
  begin
    Result := '';
    var p := 1;
    while (p <= Length(aOptions)) and CharInSet(aOptions[p], chSet)
    do begin
      var ch := aOptions[p];
      if (ch <> ' ')
       then Result := Result + ch;
      Inc(p);
    end;
    Delete(aOptions, 1, p - 1);
  end;

  function Grab(aQuote: Char): String;
  begin
    if aOptions[1] = aQuote
    then begin
      Delete(aOptions, 1,1);
      var p := Pos(aQuote, aOptions);
      if p <= 0
      then p := Length(aOptions) + 1;
      Result := Copy(aOptions, 1, p - 1);
      Delete(aOptions, 1, p);
    end;
  end;

  function GrabUntil(chSet: TSysCharSet): String;
  begin
    Result := '';
    var p := 1;
    var ch := #0;
    var l := Length(aOptions);
    if  l > 0
     then ch := aOptions[1];

    while (p <= l) and not CharInSet(ch, chSet)
    do begin
      Result := Result + ch;
      Inc(p);
      if  p <= l
       then ch := aOptions[p];
    end;
    Delete(aOptions, 1, Length(Result));
  end;

  function Peek: string;
  begin
    if aOptions <> ''
     then Result := aOptions[1]
      else Result := '';
  end;

var
  switch, name, flag, value, LastOptions: string;
  Option: TOption;
begin
  ClearValues;

  aOptions := Trim(aOptions);
  while aOptions <> ''
  do begin
    LastOptions := aOptions;
    {$ifdef debug}
//    CmdDebugOut('Parse:' + aOptions);
    {$endif}
    switch := Get(CmdSwitch);
    if Peek = ' '
     then Get(CmdSpace);

    name := Get(CmdName);
    flag := '';
    if Peek <> ' '
     then flag := Get(CmdFlag)
    else Get(CmdSpace);
    if (Peek = ':') or (Peek = '=')
     then flag := Get(CmdFlag);
    Get(CmdSpace);

    if (name <> '') and not TryGetValue(LowerCase(name), Option)
    then begin
      Option := Declare<String>(name, '');
      Option.Order := Self.Count;
    end;
    Option.Switch := switch;
    Option.Flag := flag;
    Option.Given := True;

    if (Pos(':', flag) + Pos('=', Flag)) > 0  // a parameter has been declared
    then begin
      if Peek = '('
      then begin // array of arguments
        Get(['('] + CmdSpace);
        repeat
          if Peek = '"'
           then value := Grab('"')
          else if Peek = ''''
           then value := Grab('''')
          else value := Trim(GrabUntil([')'] + CmdList));

          if Value <> ''
          then begin
            var param := Option.Add;
            param.AsString := value;
          end;
          Get(CmdList + CmdSpace);

        until (Peek = ')') or (Peek = '');
        Get([')'] + CmdSpace);

      end  // single argument
      else begin
        if Peek = '"'
         then value := Grab('"')
        else if Peek = ''''
         then value := Grab('''')
        else value := Trim(GrabUntil(CmdSpace));

        if Value <> ''
        then begin
          var param := Option.Add;
          param.AsString := value;
        end;
      end;

    end;

    Get(CmdSpace);
    if LastOptions = aOptions // nothing was consumed,
     then Delete(aOptions, 1, 1); // so deal with unexpected characters that cause a loop

    aOptions := Trim(aOptions);
  end;
end;

{ TCommandLine }

constructor TCommandLine.Create;
begin
  inherited;
  FCmdLn := '';
  for var ix := 1 to ParamCount
   do FCmdLn := FCmdLn + ParamStr(ix) + ' ';
  Parse(CmdLn);
{$ifdef debug}
  CmdDebugOut('Org: ' + CmdLn);
  CmdDebugOut('Dup: ' + Duplicate);
  var SL := TStringList.Create;
  try
    Debug(SL);
    CmdDebugOut(SL.Text);
  finally
    SL.Free;
  end;
{$endif}
end;


var
  CommandLineSection : TCriticalSection;
  CurrentCommandLine : TCommandLine;

function CommandLine:TCommandLine;
begin
  CommandLineSection.Acquire;
  try
    if not Assigned(CurrentCommandLine)
     then CurrentCommandLine := TCommandLine.Create;
    Result := CurrentCommandLine;
  finally
    CommandLineSection.Release;
  end;
end;

function CommandLineStr(const aName:String; const aDefault:String):String;
begin
  Result := CommandLine.AsString(aName, aDefault);
end;


initialization
  SetCmdDebugOutHandler(NoOutput);

  CommandLineSection := TCriticalSection.Create;
  CurrentCommandLine := nil;

finalization
  CommandLineSection.Acquire;
  try
    CurrentCommandLine.Free;
  finally
    CommandLineSection.Release;
    CommandLineSection.Free;
  end;

end.

TestFDCCommandLine.dpr

program TestFDCCommandLine;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Classes,
  System.SysUtils,
  System.TypInfo,
  FDC.CommandLine in 'FDC.CommandLine.pas';

type
  TExtendedParserExample = class(TOptionParser)
  public
    AnInt: TOption<Integer>;
    ADouble: TOption<Double>;
    AString: TOption<String>;
    ABool: TOption<Boolean>;
    AEnum: TOption<TTypeKind>;
    constructor Create; override;
  end;

{ TExtendedParserExample }

constructor TExtendedParserExample.Create;
begin
  inherited;
  AnInt := Declare<Integer>('anint', 1337);
  ADouble := Declare<Double>('adouble', 3.14);
  AString := Declare<String>('astring', 'hi there');
  ABool := Declare<Boolean>('abool', true);
  AEnum := Declare<TTypeKind>('Aenum', tkClass);
end;


begin
  FDC.CommandLine.SetCmdDebugOutHandler(
    procedure(const aMsg: string)
    begin
      Writeln(aMsg);
    end);

  try
    try
      var SL := TStringList.Create;
      var P := TOptionParser.Create;


      var TestLines := [
        ' /test+ -grab- --hold -files:( "A B C"; ''D E F'' ;) -wunder:(abc def; ghi jkl) - crap="gnarf',
        ' GlobalLocationId=1 ClientIdentifier=This_Is_A_Test'
        ];
      for var Test in TestLines
      do begin
        P.Clear; // will clear previously parsed options
        Writeln('Parse(''',Test,''')');
        P.Parse(Test);
        SL.Clear;
        P.Debug(SL);
        Writeln(SL.Text);
        Writeln;
        Writeln('ClientIdentifier = ', P.AsString('ClientIDentifier'));
        Writeln;

      end;

      var CL := TCommandLine.Create;
      Writeln('Original Cmd: ', CL.CmdLn);
      Writeln('CommandLine: ', CL.Duplicate);
      SL.Clear;
      CL.Debug(SL);
      Writeln(SL.Text);
      Writeln;

      var EP := TExtendedParserExample.Create;
      Writeln('Before: ', EP.AnInt.Value, ' ', EP.ADouble.Value, ' ', EP.AString.Value, ' ', EP.ABool.Value, ' ',
        GetEnumName(TypeInfo(TTypeKind), Ord(EP.AEnum.Value)));

      var Test := 'anint:14 adouble=' + Format('%f',[1.23]) + ' astring="ho ho ho" abool=false aenum=tkProcedure';
      Writeln('Parse(''',Test,''')');
      EP.Parse(Test);
      Writeln('After: ', EP.AnInt.Value, ' ', EP.ADouble.Value, ' ', EP.AString.Value, ' ', EP.ABool.Value, ' ',
        GetEnumName(TypeInfo(TTypeKind), Ord(EP.AEnum.Value)));

    except
      on E: Exception do
        Writeln(E.ClassName, ': ', E.Message);
    end;
  finally
    Writeln;
    Write('Press Enter: ');
    Readln;
  end;
end.