=head1 NAME

CFX5::CmdLine - Command line argument processing

=head1 SYNOPSIS

Argument parsing and miscellaneous functinos for CFX scripts.

Note that using this module implicitly uses L<CFX5::Help>.

=cut

package CFX5::CmdLine;
use Exporter;
use strict;

use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
@ISA=qw(Exporter);

@EXPORT_OK=qw(parse_cmdline option_seen conf_datafile conf_datafile_w
	      conf_datafile_m conf_datadir conf_datadir_w
	      conf_execfile show_syntax assert_no_repeat 
	      handle_std_arg is_std_arg is_in_arg_list
	      set_debug set_verbose %StandardArgs %MandatoryArgs);

%EXPORT_TAGS=(
	      'util' => [qw(conf_datafile conf_datafile_w conf_datafile_m
			    conf_execfile conf_datadir conf_datadir_w
			    show_syntax assert_no_repeat
			    handle_std_arg
			    set_debug set_verbose)],
	     );

use CFX5::Output qw(:all);

use CFX5::PkgLoader qw(cfx5_require);

=head1 DESCRIPTION

=head2 $Debug

Set $CFXNIX::CmdLine::Debug=1 for debugging information.

=cut

use vars qw($Debug);
BEGIN { $Debug=0; }

use vars qw(%StandardArgs %MandatoryArgs);

# note that we give the commands for all arguments here, rather than
# using aliases, so that if the caller overrides the main argument,
# the "aliases" still do the expected thing.  Think '-d+'.  

%MandatoryArgs = (
		  -verbose        => \&set_verbose,
		  '-v'            => '-verbose',
		  -help           => \&show_syntax,
		  '-h'            => '-help',
                  '-NoConsole'    => sub { 1; },
                  '-no-inherit'   => sub {
                    # this is actually done by CFX5::CurrentConfig
                    # when it starts up, as it needs to happen early,
                    # but we have to handle the argument anyway so we
                    # might as well re-do it.
                    $CFX5::CurrentConfig::IgnoreEnvironment = 1;
                  },
		 );

%StandardArgs = (
 		 -core           => \&allow_coredumps,
 		 -debug          => \&set_debug,
 		 '-display+'     => sub { $ENV{DISPLAY} = $_[1]; },
 		 '-disp+'        => '-display',
 		 '-d +'          => '-display',
 		 '-noautohelp'   => sub { 
                   _warn("The $_[0] argument is ignored");
                 },
 		 '-no-auto-help' => '-noautohelp',
 		 '-no_auto_help' => '-noautohelp',
		 '-attrs+'       => sub { 
                   cfx5_require('CFX5::Attr');
		   my $a=CFX5::Attr::from_config();
		   $a->merge_attr_list($_[1]);
		   $a->to_config();
		 },
                 '-win32-dlg'    => sub {
                   if ($^O eq 'MSWin32') {
                     _debug("Adding win32 dialogs for output");
                     cfx5_require('CFX5::Output::Win32Dialog');
                     add_output_object(CFX5::Output::Win32Dialog->new(),undef);
                   }
                 },
		);

use vars qw(%OptionsSeen $Break $AllowNonOpt $IgnoreUnknownOpts);

use vars qw($verbosity);
$verbosity=0;

=head2 parse_cmdline

Takes a hash representing the allowed command line options. The key is
the option name, and the value represents the action for that option.

If the key ends with a "+", the parameter takes a value (which cannot
be another option; if this is required, end the key with "-" instead);
if it ends with a "?" it can take a value if there is one there,
otherwise it takes no value. If the key is just the option, it takes
no value.

The "action" can be a scalar reference, in which case the value (or 1)
is placed into the referenced variable; a list reference, in which
case the value (or the argument itself) is pushed onto the referenced
list, or a subroutine reference, in which case the subroutine is
called with the option name, the option value if any (otherwise
"undef"), and a reference to the argument list (shifted if a value was
passed) which can be used for further manipulation of the arguments,
for example if the argument takes more than one option.

If the action is a string beginning with a hyphen ("-"), it is taken
as the name of an option for which this option is an alias, and the
process is restarted with that option instead.

If an option is not found, C<parse_cmdline> will also look for the
first character of the option as an option taking an argument, for
example to emulate the B<-IE<lt>directoryE<gt>> option to a compiler.

And finally, if nothing is found to process an option and a
pseudo-option "-*" exists, the option is handled by this definition.

Non-option arguments can be handled by a key named simply '*'; if no
such key exists, behaviour is as below.

The return value of the C<parse_cmdline> function is the list of
remaining non-option arguments, if C<ALLOW_NON_OPTION> is given;
otherwise, it is always an empty list.  Errors will be signalled via
C<_error>.

Other arguments may be specified by passing certain magic strings
before the start of the option hash.  Available strings are:

=over

=item C<INCLUDE_STD>

Include all the standard arguments.

=item C<INCLUDE_REQ>

Include all the required arguments (-help and -v).

=item C<INCLUDE_OPT>

Include the rest of the standard arguments.

=item C<ALLOW_NON_OPTION>

By default, argments without a corresponding option will cause an
error.  This magic string will switch off this error, and return the
arguments.

=item C<PROCESS_SINGLE_ARG>

Process the first argument, and then return control to the caller.

=item C<PROCESS_KNOWN_ONLY>

Process all known arguments, but rather than aborting on unknown
arguments, simply return them from the function.  Use of this switch
implies C<ALLOW_NON_OPTION>.

=back

These option lists are brought into the hash and then overwritten by
the user arguments.  So one might do something like

  parse_cmdline(\@ARGV,
                'INCLUDE_STD',
                '-core' => \$allowcore, # override default processing for -core
                # ...
               );

A standard option which takes no arguments may be overridden with a
new option taking an argument or vice versa by simply specifying the
name; it does not require the other form to be explicitly disabled.

=cut

=head2 $Break

  $CFX5::CmdLine::Break = 1;

This can be set from a command-line-parsing function, and causes
C<parse_cmdline> to terminate processing of the command line. Any
un-parsed options are returned along with the non-option arguments.

This variable is reset at the start of every call to C<parse_cmdline>.

=cut

sub check_value {
  my $arg=shift;
  my $ra=shift;
  if (!defined($$ra[0]) || $$ra[0] =~ m/^-/) {
    cfx5_require('CFX5::Help');
    _error "Option $arg requires an argument", CFX5::Help::usage_msg_once();
    return 0;
  }
  1;
}

sub check_value_relaxed {
  my $arg=shift;
  my $ra=shift;
  if (!defined($$ra[0])) {
    cfx5_require('CFX5::Help');
    _error "Option $arg requires an argument", CFX5::Help::usage_msg_once();
    return 0;
  }
  1;
}

sub query_value {
  my $arg=shift;
  my $ra=shift;
  if (defined($$ra[0]) and $$ra[0] !~ m/^-/) {
    return shift @$ra;
  } else {
    return undef;
  }
}

sub parse_cmdline {
  my @args=@{shift;};

  local $Break = 0;
  local $AllowNonOpt = 0;
  local $IgnoreUnknownOpts = 0;

  my (%arghash,%passedhash);
 
  # check for a request to include the standard argument list
 MAGIC: while(@_) {
    if ($_[0] eq 'INCLUDE_STD') {
      shift;
      for my $k (keys %MandatoryArgs) {
	$arghash{$k}=$MandatoryArgs{$k};
      }
      for my $k (keys %StandardArgs) {
	$arghash{$k}=$StandardArgs{$k};
      }
      next MAGIC;
    }
    if ($_[0] eq 'INCLUDE_REQ') {
      shift;
      for my $k (keys %MandatoryArgs) {
	$arghash{$k}=$MandatoryArgs{$k};
      }
      next MAGIC;
    }
    if ($_[0] eq 'INCLUDE_OPT') {
      shift;
      for my $k (keys %StandardArgs) {
	$arghash{$k}=$StandardArgs{$k};
      }
      next MAGIC;
    }
    if ($_[0] eq 'ALLOW_NON_OPTION') {
      shift;
      $AllowNonOpt = 1;
      next MAGIC;
    }
    if ($_[0] eq 'PROCESS_KNOWN_ONLY') {
      shift;
      $AllowNonOpt = 1;
      $IgnoreUnknownOpts = 1;
      next MAGIC;
    }
    if ($_[0] eq 'PROCESS_SINGLE_ARG') {
      shift;
      $Break = 1;
      next MAGIC;
    }
    last MAGIC;
  }

  %passedhash=@_;
  # Firstly, make sure we remove all possible arguments with this name
  for my $k (keys %passedhash) {
    my $kb=$k;

    $kb=~s/[^A-Z0-9a-z]*$//;	# strip any indicator symbols
    for my $suff ('+','=','*', '-', '?') {
      my $nk=$kb.$suff;
      if (exists $arghash{$nk}) {
	_debug("Overriding standard argument $nk");
	delete $arghash{$nk};
      }
    }
  }

  # and now push these into the new hash
  for my $k (keys %passedhash) {
    $arghash{$k}=$passedhash{$k};
  }

  my @nonopt=();

  while (scalar(@args) gt 0) {
    my $arg=shift @args;
    process_arg($arg,$arg,\@args,\@nonopt,\%arghash);
    last if $Break;
  }

  if ((@nonopt or @args) and !$AllowNonOpt and !$Break) {
    cfx5_require('CFX5::Help');
    _error("Unexpected argument(s)\n", (@nonopt, @args), "\nwithout an associated option were found on the command line.", CFX5::Help::usage_msg_once());
    return ();
  }
  
  return (@nonopt,@args);
}

sub do_arg {
  my $arg=shift;
  my $as=shift;
  my $argkey=shift;
  my $val=shift;
  my $rargs=shift;
  my $rnonopt=shift;
  my $rarghash=shift;

  my $action=$rarghash->{$argkey};
  if (ref($action) eq "SCALAR") {
    $$action=(defined $val ? $val : 1);
  } elsif (ref($action) eq "CODE") {
#    $as = $arg unless ($action=~m/-_opt/) ;
    &$action($as, $val, $rargs);
  } elsif (ref($action) eq "ARRAY") {
    push @$action, (defined $val ? $val : $as);
  } elsif (!ref($action)) {
    $as = $arg if ($action=~m/-_opt/) ;
    unshift @$rargs, $val if defined $val;
    process_arg($action,$as,$rargs,$rnonopt,$rarghash);
  } else {
    internal_error "Bad type ".ref($action)." for argument action $arg+";
  }
}

sub process_arg {
  my $arg=shift;
  my $as=shift;
  my $rargs=shift;
  my $rnonopt=shift;
  my $rarghash=shift;
  my $skipvalcheck=0;

  _debug "process_arg  : $arg (as $arg): ", join(" ", @$rargs), "\n" if $Debug;

  internal_error "undefined \$arg in process_arg" unless defined($arg);

  # -Ww,* becomes -Ww *, similarly -opt:* becomes -opt *
  if ($arg =~ /[,:]/ and $arg =~ m!^-!) {
    my ($narg, $nval)=split(/[:,]/,$arg,2);
    @$rargs=($nval,@$rargs);
    $arg=$narg;
    $skipvalcheck=1;
  }
  
  my $pe_dbg = sub {
    _debug "process_arg: $arg => $_[0] => $rarghash->{$_[0]}\n"
      if $Debug;
  };
  if (exists($rarghash->{$arg."?"})) {
    &$pe_dbg($arg."?");
    # argument may take a value
    my $val=query_value($arg,$rargs);
    do_arg($arg, $as, $arg."?", $val, $rargs, $rnonopt, $rarghash);
  } elsif (exists($rarghash->{$arg."-"})) {
    &$pe_dbg($arg."-");
    # argument takes a value, but the value can begin with a -
    if ($skipvalcheck or check_value_relaxed($arg,$rargs)) {
      do_arg($arg, $as, $arg."-", shift @$rargs, $rargs, $rnonopt, $rarghash);
    }
  } elsif (exists($rarghash->{$arg."+"})) {
    &$pe_dbg($arg."+");
    # argument takes a value
    if ($skipvalcheck or check_value($arg,$rargs)) {
      do_arg($arg, $as, $arg."+", shift @$rargs, $rargs, $rnonopt, $rarghash);
    }
  } elsif (exists($rarghash->{$arg})) {
    &$pe_dbg($arg);
    # argument takes no value (or wants to handle it itself)
    do_arg($arg, $as, $arg, undef, $rargs, $rnonopt, $rarghash);
  } elsif (exists($rarghash->{substr($arg,0,2)."+"})) {
    # like -L<dir>
    my $narg=substr($arg,0,2);
    my $nval=substr($arg,2);
    do_arg($narg, $as, $narg."+", $nval, $rargs, $rnonopt, $rarghash);
  } elsif (exists($rarghash->{$arg." +"})) {
    &$pe_dbg($arg." +");
    # argument takes a value, and if it's a single-letter argument,
    # still requires a space
    if ($skipvalcheck or check_value($arg,$rargs)) {
      do_arg($arg, $as, $arg." +", shift @$rargs, $rargs, $rnonopt, $rarghash);
    }
  } elsif ($arg =~ /^-/ and exists($rarghash->{'-*'})) {
    &$pe_dbg('-*');
    # we have a fallback argument processing thingo
    do_arg($arg, $as, "-*", undef, $rargs, $rnonopt, $rarghash);
  } elsif ($arg =~ /^-/) {
    unless ($IgnoreUnknownOpts) {
      cfx5_require('CFX5::Help');
      _error "Unrecognised argument $as", CFX5::Help::usage_msg_once();
    } else {
      push @$rnonopt, $arg;
    }
  } elsif (exists($rarghash->{'*'})) {
    # we've got a fallback everything thingo (!)  pretend that the
    # argument and its value are one and the same, as this is a
    # non-option argument ...
    do_arg($arg,$as,'*',$arg,$rargs,$rnonopt,$rarghash);
  } else {
    push @$rnonopt,$arg;
  }
  $OptionsSeen{$arg}=1;
}

=head2 option_seen

  _error("You can't pass -sfp more than once")
    if (option_seen("-sfp"));

Returns true if this is the second (or more) occurrence of the
argument as an option on the command line.

=cut

sub option_seen {
  my $opt=shift;
  return (exists($OptionsSeen{$opt}) and $OptionsSeen{$opt});
}

=head1 UTILITY FUNCTIONS

These utility functions are designed to be passed to the
C<parse_cmdline> function to do common tasks, to save the user from
having to write their own equivalents. Use them by declaring an
argument to be a subroutine reference, like the following:

  -exec+ => sub { conf_execfile('CFX_BUILD_EXEC',undef,@_); },

These functions can be imported with the C<:util> import tag.

If the second argument is not B<undef>, it is used instead of the
string "File <file> passed to <argument>" in any error messages. Any
occurrence of the string "%%" in this argument will be replaced by
the filename.

=head2 conf_datafile

=head2 conf_datafile_m

=head2 conf_datafile_w

=head2 conf_execfile

  conf_datafile("CONF-RECORD","file description",...)

Test the filename supplied with this argument, and then set the named
configuration record its absolute path and export it as an environment
variable. If the first argument is a scalar reference, it instead sets
the referenced variable to the value.

See the corresponding functions in C<CFX5::FileTests> for the details
of the tests performed by these functions.

=cut

sub conf_execfile {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;

  cfx5_require('CFX5::FileTests', 'CFX5::Config', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  $desc="File $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::execfile($file, $desc);
  if ($rv) {
    $file=CFX5::PathManip::fullpath($file);
    if (ref($var) eq "SCALAR") {
      $$var=$file;
    } elsif (defined ref($var) and ref($var)) {
      internal_error("Non-scalar reference: $var => ".ref($var));
    } else {
      CFX5::Config::setconf($var, $file);
      CFX5::Config::export_conf($var);
    }
  }

  return $rv;
}
sub conf_datafile {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;
  
  cfx5_require('CFX5::FileTests', 'CFX5::Config', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  $desc="File $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::datafile($file, $desc);
  if ($rv) {
    _debug("$file (\"$desc\") is a datafile");
    $file=CFX5::PathManip::fullpath($file);
    _debug("  Absolute path name is $file");
    if (ref($var) eq "SCALAR") {
      $$var=$file;
    } elsif (ref($var) eq 'CODE') {
      $var->($file, $desc);
    } elsif (defined ref($var) and ref($var)) {
      internal_error("Non-scalar reference");
    } else {
      CFX5::Config::setconf($var, $file);
      CFX5::Config::export_conf($var);
    }
  }

  return $rv;
}
sub conf_datafile_w {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;
  
  cfx5_require('CFX5::FileTests', 'CFX5::Config', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  $desc="File $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::datafile_w($file, $desc);
  if ($rv) {
    _debug("$file (\"$desc\") is a datafile");
    $file=CFX5::PathManip::fullpath($file);
    _debug("  Absolute path name is $file");
    if (ref($var) eq "SCALAR") {
      $$var=$file;
    } elsif (ref($var) eq 'CODE') {
      $var->($file, $desc);
    } elsif (defined ref($var) and ref($var)) {
      internal_error("Non-scalar reference");
    } else {
      CFX5::Config::setconf($var, $file);
      CFX5::Config::export_conf($var);
    }
  }

  return $rv;
}
sub conf_datafile_m {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;
  
  cfx5_require('CFX5::FileTests', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  if (ref($var) ne 'ARRAY') {
    internal_error("Non-array reference");
    return undef;
  }

  $desc="File $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::datafile($file, $desc);
  if ($rv) {
    _debug("$file (\"$desc\") is a datafile");
    $file=CFX5::PathManip::fullpath($file);
    _debug("  Absolute path name is $file");
    push @$var, $file;
  }
  return $rv;
}

sub conf_datadir {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;
  
  cfx5_require('CFX5::FileTests', 'CFX5::Config', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  $desc="Directory $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::datadir($file, $desc);
  if ($rv) {
    _debug("$file (\"$desc\") is a datafile");
    $file=CFX5::PathManip::fullpath($file);
    _debug("  Absolute path name is $file");
    if (ref($var) eq "SCALAR") {
      $$var=$file;
    } elsif (ref($var) eq 'CODE') {
      $var->($file, $desc);
    } elsif (defined ref($var) and ref($var)) {
      internal_error("Non-scalar reference");
    } else {
      CFX5::Config::setconf($var, $file);
      CFX5::Config::export_conf($var);
    }
  }

  return $rv;
}

sub conf_datadir_w {
  my $var=shift;
  my $desc=shift;
  my $arg=shift;
  my $file=shift;
  
  cfx5_require('CFX5::FileTests', 'CFX5::Config', 'CFX5::PathManip');

  $desc=~s{%%}{$file}g if defined $desc;

  $desc="Directory $file passed to $arg" unless defined $desc;
  my $rv=CFX5::FileTests::datadir_w($file, $desc);
  if ($rv) {
    _debug("$file (\"$desc\") is a datafile");
    $file=CFX5::PathManip::fullpath($file);
    _debug("  Absolute path name is $file");
    if (ref($var) eq "SCALAR") {
      $$var=$file;
    } elsif (ref($var) eq 'CODE') {
      $var->($file, $desc);
    } elsif (defined ref($var) and ref($var)) {
      internal_error("Non-scalar reference");
    } else {
      CFX5::Config::setconf($var, $file);
      CFX5::Config::export_conf($var);
    }
  }

  return $rv;
}


=head2 show_syntax

Displays the help text for this command to stdout, via a pager, and
exits. Uses the C<CFX5::Help::show_help> function.

=cut

sub show_syntax {
  cfx5_require('CFX5::Help');
  CFX5::Help::show_help();
  exit(0);
}

=head2 assert_no_repeat

Signals an error if this option has been seen before.

=cut

sub assert_no_repeat {
  my $arg=shift;
  my $rv=option_seen($arg);

  if ($rv) {
    cfx5_require('CFX5::Help');
    _error("The $arg option may only be specified once"), CFX5::Help::usage_msg_once();
  }

  return !$rv;
}

=head2 set_debug

Set (and export) the CFX5DEBUG configuration record to "debug".

=cut

sub set_debug {
  cfx5_require('CFX5::Config');
  $CFX5::Config::Config{CFX5DEBUG}="debug";
}

=head2 set_verbose

Switch on "info" output.

=cut

sub set_verbose {
  if (($verbosity++) == 0) {
    CFX5::Output::set_verbosity("info");
  } else {
    CFX5::Output::set_verbosity("moreinfo");
  }
}

=head2 handle_std_arg

Standard argument handling for various arguments which should be
common to all CFX-5 scripts, and for other arguments which should
always be consistent if they are present. The mandatory switches (in
the form in which they should be used in the hash passed to
C<parse_cmdline>) are:

=over

=item C<-verbose> or C<-v>

Sets verbose mode the first time it is passed. If it is found again,
it makes the script even more verbose.

=item C<-help> or C<-h>

Displays the help text for this script, based on the POD found in the
script (currently!).

=back

and the following switches may also be parsed by this function:

=over

=item C<-debug>

Sets the CFX5DEBUG environment variable, to indicate that various
executables etc should be found in the *_debug directories.

=item C<-core>

Allow core dumps.

=item C<-display+> or C<-disp+> or C<-d+>

Set the DISPLAY to run on.

=item C<-noautohelp> or C<-no-auto-help> or C<-no_auto_help>

Switch off automatic starting of the help server.

=item C<-NoConsole>

This argument is ignored (it it parsed earlier on when L<CFX5::Output>
initialises).

=item C<-attrs+>

Allows the user to set the CFX5_ARCH_ATTRS variable from the command
line.

=back

This functionality may also be attained -- probably better -- by using
the magic C<'INCLUDE_STD'> argument to L<parse_cmdline>.

=cut

sub handle_std_arg {
  my ($arg, $val, $rargs)=@_;
  my @cmdline=($arg,(defined $val ? $val : ()));
  parse_cmdline(\@cmdline,
		%StandardArgs,
		%MandatoryArgs,
		);
  1;
}

=head2 is_std_arg

  if (is_std_arg($args[0])) {
    parse_cmdline(\@args,qw(INCLUDE_STD PROCESS_SINGLE_ARG));
  }

Returns TRUE if the argument is one of the standard arguments, FALSE
otherwise.

=cut

sub is_std_arg {
  return is_in_arg_list($_[0],%StandardArgs,%MandatoryArgs);
}

=head3 is_in_arg_list

  my %args=(...);
  if (is_in_arg_list($args[0],%args)) {
    parse_cmdline(\@args,qw(INCLUDE_STD PROCESS_SINGLE_ARG), %args);
  }

Returns TRUE if the argument appears in the passed set, or FALSE if
not.  This handles things like the trailing +, and the special '-*'
etc options.

=cut

sub is_in_arg_list {
  my $arg=shift;
  my %list=@_;

  if (exists($list{$arg."?"}) or exists($list{$arg."-"}) or exists($list{$arg."+"}) or exists($list{$arg}) or exists($list{substr($arg,0,2)."+"}) or $arg =~ /^-/ and exists($list{'-*'})) {
    return 1;
  } elsif ($arg =~ /^-/) {
    # it's an argument, but not one we know
    return '';
  } elsif (exists($list{'*'})) {
    # non-option argument, but we can cope
    return 1;
  } else {
    return '';
  }
}

1;
