(******************************************************************************

Copyright (c) 2022+ Pepak (https://www.pepak.net)
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.
    * Neither the name of Pepak nor the
      names of his contributors may be used to endorse or promote products
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL PEPAK BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

******************************************************************************)

unit pkCommandLine;
{$INCLUDE 'pepak.inc'}

interface

uses
  SysUtils, Classes, uCompatibility;

type
  TCommandLineParserFoundArgumentProc = procedure(Sender: TObject; const Name: string; var AllowSuccessiveOptions: boolean) of object;
    // Gets called on arguments (values not beginning with a minus).
    // Normally options must precede arguments, but you can override this
    // behavior by setting AllowSuccessiveOptions to True.
  TCommandLineParserFoundOptionProc = procedure(Sender: TObject; const Name, Value: string; HasValue: boolean) of object;
    // Gets called on options (values beginning with a minus).
    // If the option has a '=', Name is the part before it and Value the part after it

type
  TBaseCommandLineParser = class
  private
    FParamList: TStringList;
    FLastParamIndex: integer;
    FLongOptionsWithArguments: boolean;
    FOnFoundArgument: TCommandLineParserFoundArgumentProc;
    FOnFoundOption: TCommandLineParserFoundOptionProc;
  protected
    procedure InitializeParamList; virtual; abstract;
    procedure DoFoundOption(const Name, Value: string; HasValue: boolean); virtual;
    procedure DoFoundArgument(const Name: string; var AllowSuccessiveOptions: boolean); virtual;
    property ParamList: TStringList read FParamList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Reset; virtual;
    function GetNext(out Param: string): boolean; virtual;
    // This section handles a loop over all the arguments
    procedure Process; virtual;
    property LongOptionsWithArguments: boolean read FLongOptionsWithArguments write FLongOptionsWithArguments;
    property OnFoundArgument: TCommandLineParserFoundArgumentProc read FOnFoundArgument write FOnFoundArgument;
    property OnFoundOption: TCommandLineParserFoundOptionProc read FOnFoundOption write FOnFoundOption;
    function FetchValue(out Value: string; const InValue: string; InValueAvailable: boolean): boolean; overload;
    function FetchValue(out Value: integer; const InValue: string; InValueAvailable: boolean): boolean; overload;
    function FetchValue(out Value: boolean; const InValue: string; InValueAvailable: boolean): boolean; overload;
    function FetchEnum(out OptionIndex: integer; const InValue: string; InValueAvailable: boolean; const Options: array of string): boolean;
    // (end)
  end;

  // Parser based on the ParamStr/ParamCount functions
  TCommandLineParser = class(TBaseCommandLineParser)
  protected
    procedure InitializeParamList; override;
  end;

  // Parser based on a command-line as a single string
  TCommandLineStringParser = class(TBaseCommandLineParser)
  private
    FCommandLine: string;
    procedure SetCommandLine(const Value: string);
  protected
    procedure InitializeParamList; override;
  public
    constructor Create(const CommandLine: string);
    property CommandLine: string read FCommandLine write SetCommandLine;
  end;

implementation

{ TBaseCommandLineParser }

constructor TBaseCommandLineParser.Create;
begin
  inherited Create;
  FParamList := TStringList.Create;
  FLongOptionsWithArguments := True;
  Reset;
end;

destructor TBaseCommandLineParser.Destroy;
begin
  FreeAndNil(FParamList);
  inherited;
end;

procedure TBaseCommandLineParser.DoFoundArgument(const Name: string; var AllowSuccessiveOptions: boolean);
begin
  if Assigned(OnFoundArgument) then
    OnFoundArgument(Self, Name, AllowSuccessiveOptions);
end;

procedure TBaseCommandLineParser.DoFoundOption(const Name, Value: string; HasValue: boolean);
begin
  if Assigned(OnFoundOption) then
    OnFoundOption(Self, Name, Value, HasValue);
end;

function TBaseCommandLineParser.FetchEnum(out OptionIndex: integer; const InValue: string; InValueAvailable: boolean; const Options: array of string): boolean;
var
  s: string;
  i: integer;
begin
  Result := False;
  if FetchValue(s, InValue, InValueAvailable) then
  begin
    for i := Low(Options) to High(Options) do
    begin
      if AnsiCompareText(s, Options[i]) = 0 then
      begin
        OptionIndex := i;
        Result := True;
        Exit;
      end;
    end;
  end;
end;

function TBaseCommandLineParser.FetchValue(out Value: string; const InValue: string; InValueAvailable: boolean): boolean;
begin
  if InValueAvailable then
  begin
    Value := InValue;
    Result := True;
  end
  else
    Result := GetNext(Value);
end;

function TBaseCommandLineParser.FetchValue(out Value: integer; const InValue: string; InValueAvailable: boolean): boolean;
var
  s: string;
  i: integer;
begin
  Result := False;
  if FetchValue(s, InValue, InValueAvailable) then
  begin
    if TryStrToInt(s, i) then
    begin
      Value := i;
      Result := True;
    end;
  end;
end;

function TBaseCommandLineParser.FetchValue(out Value: boolean; const InValue: string; InValueAvailable: boolean): boolean;
var
  s: string;
  i: integer;
begin
  Result := False;
  if FetchValue(s, InValue, InValueAvailable) then
  begin
    Result := True;
    if AnsiCompareText(s, 'true') = 0 then
      Value := True
    else if AnsiCompareText(s, 'on') = 0 then
      Value := True
    else if AnsiCompareText(s, 'yes') = 0 then
      Value := True
    else if AnsiCompareText(s, 'false') = 0 then
      Value := False
    else if AnsiCompareText(s, 'off') = 0 then
      Value := False
    else if AnsiCompareText(s, 'no') = 0 then
      Value := False
    else if TryStrToInt(s, i) then
      if i = 0 then
        Value := False
      else
        Value := True
    else
      Result := False;
  end;
end;

function TBaseCommandLineParser.GetNext(out Param: string): boolean;
begin
  Result := False;
  if Succ(FLastParamIndex) >= ParamList.Count then
    Exit;
  Inc(FLastParamIndex);
  Param := ParamList[FLastParamIndex];
  Result := True;
end;

procedure TBaseCommandLineParser.Process;
var
  ProcessingArguments: boolean;
  Param: string;
  Value: string;
  HasValue: boolean;
  ValueSeparatorPos: integer;
begin
  ProcessingArguments := True;
  while GetNext(Param) do
  begin
    if ProcessingArguments then
    begin
      if Param = '--' then
      begin
        ProcessingArguments := False;
        Continue;
      end;
      if (Param <> '') and (Param[1] = '-') then
      begin
        HasValue := False;
        Value := '';
        if LongOptionsWithArguments then
        begin
          ValueSeparatorPos := Pos('=', Param);
          if ValueSeparatorPos > 0 then
          begin
            HasValue := True;
            Value := Copy(Param, ValueSeparatorPos + 1, MaxInt);
            SetLength(Param, ValueSeparatorPos - 1);
          end;
        end;
        DoFoundOption(Param, Value, HasValue);
        Continue;
      end;
    end;
    ProcessingArguments := False;
    DoFoundArgument(Param, ProcessingArguments);
  end;
end;

procedure TBaseCommandLineParser.Reset;
begin
  ParamList.Clear;
  InitializeParamList;
  FLastParamIndex := -1;
end;

{ TCommandLineParser }

procedure TCommandLineParser.InitializeParamList;
var
  i, n: integer;
begin
  ParamList.Clear;
  n := System.ParamCount;
  for i := 1 to n do
    ParamList.Add(System.ParamStr(i));
end;

{ TCommandLineStringParser }

constructor TCommandLineStringParser.Create(const CommandLine: string);
begin
  FCommandLine := CommandLine;
  inherited Create;
end;

procedure TCommandLineStringParser.InitializeParamList;
const
  Whitespace: TSysCharSet = [' ', #9, #10, #13];
var
  CommandLine, CommandLineEnd: PChar;
  InQuote: boolean;
  Param: string;
begin
  ParamList.Clear;
  CommandLine := PChar(Self.CommandLine);
  CommandLineEnd := @(Self.CommandLine[Length(CommandLine)]);
  SetLength(Param, Length(Self.CommandLine));
  repeat
    // Skip whitespace
    while (CommandLine <= CommandLineEnd) and CharInSet(CommandLine^, Whitespace) do
      Inc(CommandLine);
    if CommandLine > CommandLineEnd then
      Break;
    // Extract the parameter
    InQuote := False;
    Param := '';
    while (CommandLine <= CommandLineEnd) do
    begin
      if CommandLine^ = '"' then
        InQuote := not InQuote
      else if (not InQuote) and CharInSet(CommandLine^, WhiteSpace) then
        Break
      else
        Param := Param + CommandLine^;
      Inc(CommandLine);
    end;
    // Save it and move to the next parameter
    ParamList.Add(Param);
  until False;
end;

procedure TCommandLineStringParser.SetCommandLine(const Value: string);
begin
  FCommandLine := Value;
  Reset;
end;

end.

