# Options.pm: Process Single-Character Switches with Switch Clustering

package RDA::Options;

# $Id: Options.pm,v 1.8 2015/05/08 18:26:43 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Options.pm,v 1.8 2015/05/08 18:26:43 RDA Exp $
#
# Change History
# 20131114  MSC  Improve the documentation.

=head1 NAME

RDA::Options - Process Single-Character Switches with Switch Clustering

=head1 SYNOPSIS

 require RDA::Options;

=head1 DESCRIPTION

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @EXPORT_OK @ISA);
$VERSION   = sprintf('%d.%02d', q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw(getopts);
@ISA       = qw(Exporter);

# Define the global private constants

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<RDA::Options::getopts($list,\@arg[,$flg])>

The function processes single-character switches with switch clustering.

The first argument indicates the list of all switches to be
recognized. Switches, which take an argument, are followed by a C<:> character
or a C<*> character in the list. They are representing respectively a scalar
value or a comma-separated value list. They do not care whether or not there is
a space between the switch and the argument. However, empty lists require an
empty string as a separate argument.

If unspecified switches are found on the command-line, an error will be
generated unless the flag is set. In that case, they are discarded.

It returns a hash reference, where the hash keys are the switch names, and
their value is the value of the argument or 1 when no argument is specified.

To allow programs to process arguments that look like switches, the function
will stop processing switches when they see the argument C<-->. The C<--> will
be removed from the argument list array.

=cut

sub getopts
{ my ($lst, $arg, $flg) = @_;
  my ($hsh, $itm, $opt, $val, %opt);

  # Parse the option list
  $val = 0;
  $lst = q{} unless defined($lst);
  foreach my $chr (reverse split(/ */, $lst))
  { if ($chr eq q{:})
    { $val = 1;
    }
    elsif ($chr eq q{*})
    { $val = -1;
    }
    else
    { $opt{$chr} = $val if $chr =~ m/\w/;
      $val = 0;
    }
  }

  # Extract the options from the argument list
  $hsh = {};
  while (defined($itm = shift(@{$arg})))
  { # Detect the end of the options
    last if $itm eq q{--};
    unless ($itm =~ s/^-//)
    { unshift(@{$arg}, $itm);
      last;
    }

    # Treat option letters
    while (length($opt = substr($itm, 0, 1)))
    { $itm = substr($itm, 1);
      unless (exists($opt{$opt}))
      { die get_string('BAD_OPTION', $opt) unless $flg;
        next;
      }
      if ($val = $opt{$opt})
      { $hsh->{$opt} = ($val > 0)   ? $itm :
                       length($itm) ? [grep {length($_)} split(/\,/, $itm)] :
                                      []
          if length($itm) || defined($itm = shift(@{$arg}));
        last;
      }
      $hsh->{$opt} = 1;
    }
  }

  # Return the parsing result
  return $hsh;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut