// Deprecated, in new programs use dgetopt
// FIXME do not use Writeln in non-console applications
{$MODE OBJFPC}
unit darg;

interface

uses
  dstrnum;

type
PArg = ^TArg;
PBoolean = ^Boolean;
PInteger = ^LongInt;
PAnsiString = ^AnsiString;
TArgCallback = function (Arg: PArg): AnsiString;

PArrayOfString = ^TArrayOfString;
TArrayOfString = array of AnsiString;
TFreeArgCallback = function (Start, Finish: LongInt): AnsiString;

TArg = record
  S: AnsiChar;
  L: AnsiString;
  NeedArgument: Boolean;
  B: PBoolean;
  I: PInteger;
  A: PAnsiString;
  Callback: TArgCallback;
end;

var
  Args: array of TArg;
  FreeArgSettings: record
    S: PAnsiString;
    A: PArrayOfString;
    P: TFreeArgCallback;
  end;
  CurrentArg: LongInt;

  Letter: AnsiChar;
  FullArg: AnsiString;
  Param: AnsiString;

procedure Arg(const S: Char; L: AnsiString; var B: Boolean; Def: Boolean = False; C: TArgCallback = nil); overload;
procedure Arg(const S: Char; L: AnsiString; var I: LongInt; Def: LongInt = 0; C: TArgCallback = nil); overload;
procedure Arg(const S: Char; L: AnsiString; var A: AnsiString; Def: AnsiString = ''; C: TArgCallback = nil); overload;
procedure Arg(const S: Char; L: AnsiString; C: TArgCallback = nil); overload;
procedure FreeArg(var S: AnsiString); overload;
procedure FreeArg(var S: TArrayOfString); overload;
procedure FreeArg(P: TFreeArgCallback); overload;
function GetArg(const Format: AnsiString): Boolean;
procedure ParseArgs;

procedure ParamShift(Count: LongInt = 1);

implementation

procedure AddArg(S: AnsiChar; L: AnsiString; Callback: TArgCallback);
begin
  SetLength(Args, Length(Args) + 1);
  Args[High(Args)].S := S;
  Args[High(Args)].L := L;
  Args[High(Args)].NeedArgument := True;
  Args[High(Args)].B := nil;
  Args[High(Args)].I := nil;
  Args[High(Args)].A := nil;
  Args[High(Args)].Callback := Callback;
end;

procedure Arg(const S: Char; L: AnsiString; var B: Boolean; Def: Boolean = False; C: TArgCallback = nil);
begin
  AddArg(S, L, C);
  B := Def;
  Args[High(Args)].B := @B;
  Args[High(Args)].NeedArgument := False;
end;

procedure Arg(const S: Char; L: AnsiString; var I: LongInt; Def: LongInt = 0; C: TArgCallback = nil);
begin
  AddArg(S, L, C);
  I := Def;
  Args[High(Args)].I := @I;
end;

procedure Arg(const S: Char; L: AnsiString; var A: AnsiString; Def: AnsiString = ''; C: TArgCallback = nil);
begin
  AddArg(S, L, C);
  A := Def;
  Args[High(Args)].A := @A;
end;

procedure Arg(const S: Char; L: AnsiString; C: TArgCallback = nil);
begin
end;

procedure FreeArg(var S: AnsiString);
begin
end;

procedure FreeArg(var S: TArrayOfString);
begin
end;

procedure FreeArg(P: TFreeArgCallback);
begin
end;

procedure ProcessArgument(const A: TArg);
begin
  if A.B <> nil then begin
    if A.NeedArgument then begin
      A.B^ := (Param <> '') and (Param <> '0') and (Param <> 'false');
    end else
      A.B^ := True;
  end else if A.I <> nil then begin
    A.I^ := StrToInt(Param);
  end else if A.A <> nil then begin
    A.A^ := Param;
  end;
  if A.Callback <> nil then
    A.Callback(@A);
end;

function GetArg(const Format: AnsiString): Boolean;
var
  S: AnsiString;
  I: LongInt;
begin
  while True do begin
    if CurrentArg > ParamCount then
      Exit(False);
    S := ParamStr(CurrentArg);
    if Length(S) < 1 then begin
      if IsConsole then Writeln(stderr, 'Unexpected argument: ', S);
      Exit(False);
    end;

    if S[2] <> '-' then begin
      Letter := S[2];
      for I := 0 to High(Args) do
        if Letter = Args[I].S then begin
          if not Args[I].NeedArgument then begin
            ProcessArgument(Args[I]);
            Inc(CurrentArg);
            Exit(True);
          end;
          if Length(S) > 2 then begin
            Param := Copy(S, 3, Length(S) - 2);
            ProcessArgument(Args[I]);
            Inc(CurrentArg);
            Exit(True);
          end else begin
            Param := ParamStr(CurrentArg + 1);
            ProcessArgument(Args[I]);
            Inc(CurrentArg, 2);
            Exit(True);
          end;
        end;
      for I := 1 to Length(Format) do
        if Letter = Format[I] then begin
          if (I >= Length(Format)) or (Format[I + 1] <> ':') then begin
            Inc(CurrentArg);
            Exit(True);
          end;
          Param := ParamStr(CurrentArg + 1);
          Inc(CurrentArg, 2);
          Exit(True);
        end;
      if IsConsole then Writeln(stderr, 'Unknown option -', Letter, ' in ', S);
      Exit(False);
    end;

    if Length(S) = 2 then begin
      Inc(CurrentArg);
      // TODO FreeArgs
      Exit(False);
    end;

    FullArg := Copy(S, 3, Length(S) - 2);
    for I := 0 to High(Args) do begin
      if FullArg = Args[I].L then begin
        if not Args[I].NeedArgument then begin
          ProcessArgument(Args[I]);
          Inc(CurrentArg);
          Exit(True);
        end;
        Param := ParamStr(CurrentArg + 1);
        ProcessArgument(Args[I]);
        Inc(CurrentArg, 2);
        Exit(True);
      end;
    end;
    if IsConsole then Writeln(stderr, 'Unknown option ', S);
    Exit(False);
  end;
end;

procedure ParseArgs;
begin
  while GetArg('') do;
end;

procedure ParamShift(Count: LongInt = 1);
begin
  Inc(CurrentArg);
end;

begin
  CurrentArg := 1;
end.
