Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
FDC Generic Command Line Parser for Delphi 10.3.x
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.
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.