unit dopt;

{$MODE FPC}
{$MODESWITCH RESULT}

interface

type
TOpts = object
private
  FErrorMsg: PAnsiChar; // human readable error description (if error raised)
  FArg: AnsiString;     // popped argument (only while parsing)
  FArgPos: LongInt;     // index for ParamStr just before argument
  FFreeArgsMode: Boolean;   // read all as free args
protected
  function Error(Code: LongInt; Msg: PAnsiChar): Boolean;
  function GetArgument: AnsiString;
  procedure SkipRest;
  procedure StartFreeArgs;
  function OnOpt(const S: AnsiString): Boolean; virtual;
  function OnLetter(Letter: AnsiChar): Boolean; virtual;
  function OnFreeArg(const S: AnsiString): Boolean; virtual;
public
  constructor Init;
  destructor Done; virtual;
  function ParseParams: Boolean;
  function BuildUsage: AnsiString; virtual;
  property ErrorMsg: PAnsiChar read FErrorMsg;
end;

POptBoolean = ^TOptBoolean;
TOptBoolean = record
  Letter: AnsiChar;
  Opt: AnsiString;
  Value: PBoolean;
  Usage: AnsiString;
end;

POptLongInt = ^TOptLongInt;
TOptLongInt = record
  Letter: AnsiChar;
  Opt: AnsiString;
  Value: PLongInt;
  Usage: AnsiString;
end;

POptString = ^TOptString;
TOptString = record
  Letter: AnsiChar;
  Opt: AnsiString;
  Value: PAnsiString;
  Usage: AnsiString;
end;

POptFreeArgs = ^TOptFreeArgs;
TOptFreeArgs = array of AnsiString;

TOptsGlobal = object(TOpts)
private type
  TTable = record
    Start: Pointer;
    Count: SizeUInt;
  end;
private
  FOptsBoolean: array of TTable;
  FOptsLongInt: array of TTable;
  FOptsString: array of TTable;
  FFreeArgs: POptFreeArgs;
protected
  function OnOpt(const S: AnsiString): Boolean; virtual;
  function OnLetter(Letter: AnsiChar): Boolean; virtual;
  function OnFreeArg(const S: AnsiString): Boolean; virtual;
public
  constructor Init;
  procedure AddTable(const T: array of TOptBoolean); overload;
  procedure AddTable(const T: array of TOptLongInt); overload;
  procedure AddTable(const T: array of TOptString); overload;
  procedure AddFreeArgs(var FreeArgs: TOptFreeArgs); overload;
  procedure AddFreeArgs(FreeArgs: POptFreeArgs); overload;
  function BuildUsage: AnsiString; virtual;
end;

implementation

function TOpts.Error(Code: LongInt; Msg: PAnsiChar): Boolean;
begin
  FErrorMsg := Msg;
  Exit(Code = 0);
end;

function TOpts.GetArgument: AnsiString;
begin
  if FArg <> '' then begin
    Result := FArg;
    FArg := '';
  end else begin
    Inc(FArgPos);
    if FArgPos <= ParamCount then begin
      Exit(ParamStr(FArgPos));
    end else
      Exit('');
  end;
end;

procedure TOpts.SkipRest;
begin
  FArgPos := ParamCount;
end;

procedure TOpts.StartFreeArgs;
begin
end;

function TOpts.OnOpt(const S: AnsiString): Boolean;
begin
  if S = '' then begin // --
    StartFreeArgs;
    Exit(True);
  end;
  Exit(Error(1, 'options are not allowed'));
end;

function TOpts.OnFreeArg(const S: AnsiString): Boolean;
begin
  Exit(Error(1, 'free arguments are not allowed'));
end;

function TOpts.OnLetter(Letter: AnsiChar): Boolean;
begin
  Exit(OnOpt(Letter));
end;

constructor TOpts.Init;
begin
  FErrorMsg := '';
  FFreeArgsMode := False;
end;

destructor TOpts.Done;
begin
end;

function TOpts.ParseParams: Boolean;
label
  LOpts, LFreeArgs;
var
  I: LongInt;
  S: AnsiString;
begin
  FErrorMsg := '';
  FFreeArgsMode := False;
  FArg := '';
  I := 1;

LOpts:
  while I <= ParamCount do begin
    FArg := '';
    FArgPos := I;
    S := ParamStr(I);
    if Length(S) = 0 then begin
      if not OnFreeArg(S) then
        Exit(False);
    end else if S[1] <> '-' then begin
      if not OnFreeArg(S) then
        Exit(False);
    end else if Length(S) <= 1 then begin
      Exit(Error(1, 'single minus sign is not allowed'));
    end else if S[2] <> '-' then begin
      if Length(S) > 2 then begin
        FArg := Copy(S, 3, Length(S) - 2);
      end else
        FArg := '';
      if not OnLetter(S[2]) then
        Exit(False);
    end else begin
      if not OnOpt(Copy(S, 3, Length(S) - 2)) then
        Exit(False);
    end;
    I := FArgPos + 1;
    if FFreeArgsMode then
      goto LFreeArgs;
  end;

LFreeArgs:
  while I <= ParamCount do begin
    FArg := '';
    FArgPos := I;
    S := ParamStr(I);
    OnFreeArg(S);
    I := FArgPos + 1;
    if not FFreeArgsMode then
      goto LOpts;
  end;

  if I > ParamCount + 1 then begin
    Exit(Error(1, 'last argument missed'));
  end else
    Exit(True);
end;

function TOpts.BuildUsage: AnsiString;
begin
  Exit('');
end;

function TOptsGlobal.OnOpt(const S: AnsiString): Boolean;
var
  T, I: LongInt;
  P: Pointer;
begin
  for T := 0 to High(FOptsBoolean) do begin
    for I := 0 to FOptsBoolean[T].Count - 1 do begin
      P := POptBoolean(FOptsBoolean[T].Start) + I;
      if POptBoolean(P)^.Opt = S then begin
        POptBoolean(P)^.Value^ := True;
        Exit(True);
      end;
    end;
  end;
  for T := 0 to High(FOptsLongInt) do begin
    for I := 0 to FOptsLongInt[T].Count - 1 do begin
      P := POptBoolean(FOptsLongInt[T].Start) + I;
      if POptLongInt(P)^.Opt = S then begin
        Val(GetArgument, POptLongInt(P)^.Value^);
        Exit(True);
      end;
    end;
  end;
  for T := 0 to High(FOptsString) do begin
    for I := 0 to FOptsString[T].Count - 1 do begin
      P := POptString(FOptsString[T].Start) + I;
      if POptString(P)^.Opt = S then begin
        POptString(P)^.Value^ := GetArgument;
        Exit(True);
      end;
    end;
  end;
  Exit(Error(1, 'unknown option'));
end;

function TOptsGlobal.OnLetter(Letter: AnsiChar): Boolean;
var
  T, I: LongInt;
  P: Pointer;
begin
  for T := 0 to High(FOptsBoolean) do begin
    for I := 0 to FOptsBoolean[T].Count - 1 do begin
      P := POptBoolean(FOptsBoolean[T].Start) + I;
      if POptBoolean(P)^.Letter = Letter then begin
        POptBoolean(P)^.Value^ := True;
        Exit(True);
      end;
    end;
  end;
  for T := 0 to High(FOptsLongInt) do begin
    for I := 0 to FOptsLongInt[T].Count - 1 do begin
      P := POptLongInt(FOptsLongInt[T].Start) + I;
      if POptLongInt(P)^.Letter = Letter then begin
        Val(GetArgument, POptLongInt(P)^.Value^);
        Exit(True);
      end;
    end;
  end;
  for T := 0 to High(FOptsString) do begin
    for I := 0 to FOptsString[T].Count - 1 do begin
      P := POptString(FOptsString[T].Start) + I;
      if POptString(P)^.Letter = Letter then begin
        POptString(P)^.Value^ := GetArgument;
        Exit(True);
      end;
    end;
  end;
  Exit(Error(1, 'unknown letter'));
end;

function TOptsGlobal.OnFreeArg(const S: AnsiString): Boolean;
begin
  if FFreeArgs = nil then
    Exit(Error(1, 'free args are not allowed'));
  SetLength(FFreeArgs^, Length(FFreeArgs^) + 1);
  FFreeArgs^[High(FFreeArgs^)] := S;
  Exit(True);
end;

constructor TOptsGlobal.Init;
begin
  inherited Init;
  FFreeArgs := nil;
end;

procedure TOptsGlobal.AddTable(const T: array of TOptBoolean);
begin
  SetLength(FOptsBoolean, Length(FOptsBoolean) + 1);
  with FOptsBoolean[High(FOptsBoolean)] do begin
    Start := @T[0];
    Count := Length(T);
  end;
end;

procedure TOptsGlobal.AddTable(const T: array of TOptLongInt);
begin
  SetLength(FOptsLongInt, Length(FOptsLongInt) + 1);
  with FOptsLongInt[High(FOptsLongInt)] do begin
    Start := @T[0];
    Count := Length(T);
  end;
end;

procedure TOptsGlobal.AddTable(const T: array of TOptString);
begin
  SetLength(FOptsString, Length(FOptsString) + 1);
  with FOptsString[High(FOptsString)] do begin
    Start := @T[0];
    Count := Length(T);
  end;
end;

procedure TOptsGlobal.AddFreeArgs(var FreeArgs: TOptFreeArgs);
begin
  AddFreeArgs(@FreeArgs);
end;

procedure TOptsGlobal.AddFreeArgs(FreeArgs: POptFreeArgs);
begin
  FFreeArgs := FreeArgs;
end;

function TOptsGlobal.BuildUsage: AnsiString;
var
  T, I: LongInt;
  P: Pointer;
  Line: AnsiString;
begin
  Result := '[options]' + #10#13;
  for T := 0 to High(FOptsBoolean) do begin
    for I := 0 to FOptsBoolean[T].Count - 1 do begin
      Result := Result + '  ';
      P := POptBoolean(FOptsBoolean[T].Start) + I;
      if POptBoolean(P)^.Letter <> #0 then
        Result := Result + '-' + POptBoolean(P)^.Letter + ' ';
      if POptBoolean(P)^.Opt <> '' then
        Result := Result + '--' + POptBoolean(P)^.Opt + ' ';
      Result := Result + #10#13'    ' + POptBoolean(P)^.Usage + #10#13;
    end;
  end;
  for T := 0 to High(FOptsLongInt) do begin
    for I := 0 to FOptsLongInt[T].Count - 1 do begin
      Result := Result + '  ';
      P := POptLongInt(FOptsLongInt[T].Start) + I;
      if POptLongInt(P)^.Letter <> #0 then
        Result := Result + '-' + POptLongInt(P)^.Letter + ' ';
      if POptLongInt(P)^.Opt <> #0 then
        Result := Result + '--' + POptLongInt(P)^.Opt + ' ';
      Result := Result + '<int> '#10#13'    ' + POptLongInt(P)^.Usage + #10#13;
    end;
  end;
  for T := 0 to High(FOptsString) do begin
    for I := 0 to FOptsString[T].Count - 1 do begin
      Result := Result + '  ';
      P := POptString(FOptsString[T].Start) + I;
      if POptString(P)^.Letter <> #0 then
        Result := Result + '-' + POptString(P)^.Letter + ' ';
      if POptString(P)^.Opt <> #0 then
        Result := Result + '--' + POptString(P)^.Opt + ' ';
      Result := Result + '<str> '#10#13'    ' + POptString(P)^.Usage + #10#13;
    end;
  end;
end;

end.
