# $Id: Compact.pm 15 2006-09-04 20:00:01Z andrew $
# Copyright (c) 2004-2006 Andrew Stewart Williams. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Getopt::Compact;
use strict;
use Getopt::Long;
use Config;
use File::Spec;
use Carp;
use vars qw($VERSION);
use constant CONSTRUCTOR_OPTIONS =>
    (qw/struct usage name version author cmd args configure modes/);
use constant DEFAULT_CONFIG => (no_auto_abbrev => 1, bundling => 1);

$VERSION = "0.04";

sub new {
    my($class, %args) = @_;
    my $self = bless {}, $class;
    my(%opt, $i);

    $args{struct} ||= [];
    for $i (CONSTRUCTOR_OPTIONS) {
        next unless exists $args{$i};
        $self->{$i} = delete $args{$i};
    }
    croak("unrecognised option: $_") for keys %args;

    my $struct = $self->{struct};
    $self->{usage} = 1 unless exists $self->{usage};
    unless ($self->{cmd}) {
        require File::Basename;
        $self->{cmd} = File::Basename::basename($0 || '');
    }

    # more version munging
    my $v = $self->{version} || $main::VERSION || '1.0';
    $v = $1 if $v =~ /\$?Revision:?\s*([\d\.]+)/;
    $self->{version} = $v;

    # add mode options
    if ($self->{modes}) {
        my @modeopt;
        for my $m (@{$self->{modes}}) {
            my($mc) = $m =~ /^(\w)/;
            $mc = 'n' if $m eq 'test';
            push @modeopt, [[$mc, $m], qq($m mode)];
        }
        unshift @$struct, @modeopt;
    }

    # add --help option if usage is enabled
    unshift @$struct, [[qw(h help)], qq(this help message)]
        if $self->{usage} && !$self->_has_option('help');

    # add --man option unless one already exists
    unless($self->_has_option('man')) {
        push @$struct, ['man', qq(Display documentation)];
        $self->{_allow_man} = 1;
    }

    my $opthash = {};
    $self->{opt} = \%opt;
    for my $s (@$struct) {
        my($m, $descr, $spec, $ref) = @$s;
	my @onames = $self->_option_names($m);
	my($longname) = grep length($_) > 1, @onames;  # first long name
        my $o = join('|', @onames).($spec || '');
	my $dest = $longname ? $longname : $onames[0];
        $opt{$dest} = undef;  # initialise destination
        $opthash->{$o} = ref $ref ? $ref : \$opt{$dest};
    }

    # configure getopt option preferences
    my %config = (DEFAULT_CONFIG, %{$self->{configure} || {}});
    my @gconf = grep $config{$_}, keys %config;
    Getopt::Long::Configure(@gconf) if @gconf;

    # parse options
    $self->{ret} = GetOptions(%$opthash);

    return $self;
}

sub opts {
    my($self) = @_;
    my $opt = $self->{opt};
    if ($self->{_allow_man} && $opt->{man}) {
        # display modified POD
        $self->pod2usage();
        exit !$self->status;
    } elsif ($self->{usage} && ($opt->{help} || $self->status == 0)) {
        # display usage message & exit
        print $self->usage;
        exit !$self->status;
    }
    return $opt;
}

# munge & print a POD manpage
sub pod2usage {
    my $self = shift;
    my $usage = $self->usage;
    my $script = $self->_find_program;

    require Getopt::Compact::PodMunger;
    my $pod = new Getopt::Compact::PodMunger;
    $pod->parse_from_file($script) if defined $script;
    $pod->insert('NAME', $self->{name} || $self->{cmd});
    $pod->insert('USAGE', $usage, 1);
    $pod->insert('VERSION', $self->{version});
    $pod->insert('AUTHOR', $self->{author});
    $pod->print_manpage;
}

# return return value of GetOptions
sub status { shift->{ret} }

# return a string explaining usage
sub usage {
    my($self) = @_;
    my $usage = "";
    my($v, @help);

    my($name, $version, $cmd, $struct, $args) = map
	$self->{$_} || '', qw/name version cmd struct args/;

    if($name) {
        $usage .= $name;
	$usage .= " v$version" if $version;
        $usage .= "\n";
    }
    $usage .= "usage: $cmd [options] $args\n";

    for my $o (@$struct) {
	my($opts, $desc) = @$o;
        next unless defined $desc;
	my @onames = $self->_option_names($opts);
        my $optname = join
            (', ', map { (length($_) > 1 ? '--' : '-').$_ } @onames);
	$optname = "    ".$optname unless length($onames[0]) == 1;
        push @help, [ $optname, ucfirst($desc) ];
    }
    require Text::Table;
    my $sep = '   ';
    my $tt = new Text::Table('options', \$sep, '');
    $tt->load(@help);
    $usage .= $tt."\n";
    return $usage;
}

sub version { $VERSION }

######################################################################
# Private subs/methods

sub _option_names {
    my($self, $m) = @_;
    return sort _opt_sort (ref $m eq 'ARRAY' ? @$m : $m);
}
sub _opt_sort {
    my($la, $lb) = map length($_), $a, $b;
    return $la <=> $lb if $la < 2 or $lb < 2;
    return 0;
}

sub _has_option {
    my($self, $option) = @_;
    return 1 if grep $_ eq $option, map
	$self->_option_names($_->[0]), @{$self->{struct}};
    return 0;
}

# find the full path to the program, or undefined if it couldn't be found
sub _find_program {
    my($self) = @_;
    return $self->{_program} if exists $self->{_program};
    my $script = $0;
    if(defined $script && ! -e $script) {
	# $0 is not the full path to script.  look for script in path.
        require Env::Path;
        ($script) = Env::Path->Whence($script);
    }
    return $self->{_program} = $script;
}

1;

=head1 NAME

Getopt::Compact - getopt processing in a compact statement with both
long and short options, and usage functionality.

=head1 SYNOPSIS

inside foobar.pl:

    use Getopt::Compact;

    # (1) simple usage:
    my $opts = new Getopt::Compact
        (struct =>
         [[[qw(b baz)], qq(baz option)],  # -b or --baz
          ["foobar", qq(foobar option)],  # --foobar only
         ])->opts();

    # (2) or, a more advanced usage:
    my $go = new Getopt::Compact
        (name => 'foobar program', modes => [qw(verbose test debug)],
         struct =>
         [[[qw(w wibble)], qq(specify a wibble parameter), ':s'],
          [[qw(f foobar)], qq(apply foobar algorithm)],
          [[qw(j joobies)], qq(jooby integer list), '=i', \@joobs],
         ]
        );
    my $opts = $go->opts;

    print "applying foobar algorithm\n" if $opt->{foobar};
    print "joobs: @joobs\n" if @joobs;
    print $go->usage if MyModule::some_error_condition($opts);

using (2), running the command './foobar.pl -x' results in the
following output:

    Unknown option: x
    foobar program v1.0
    usage: foobar.pl [options]
    options
    -h, --help      This help message
    -v, --verbose   Verbose mode
    -n, --test      Test mode
    -d, --debug     Debug mode
    -w, --wibble    Specify a wibble parameter
    -f, --foobar    Apply foobar algorithm
    -j, --joobies   Jooby integer list
        --man       Display documentation

=head1 DESCRIPTION

This is yet another Getopt related module.  Getopt::Compact is geared
towards compactly and yet quite powerfully describing an option
syntax.  Options can be parsed, returned as a hashref of values,
and/or displayed as a usage string or within the script POD.

=head1 PUBLIC METHODS

=over 4

=item new()

    my $go = new Getopt::Compact(%options)

Instantiates a Getopt::Compact object.  This will parse the command
line arguments and store them for later retrieval (via the opts()
method).  On error a usage string is printed and exit() is called,
unless you have set the 'usage' option to false.

The following constructor options are recognised:

=over 4

=item C<name>

The name of the program.  This is printed at the start of the usage string.

=item C<cmd>

The command used to execute this program.  Defaults to $0.  This will be
printed as part of the usage string.

=item C<version>

Program version.  Can be an RCS Version string, or any other string.
Displayed in usage information.  The default is ($main::VERSION || '1.0')

=item C<usage>

'usage' is set to true by default.  Set it to false (0) to disable the
default behaviour of automatically printing a usage string and exiting
when there are parse errors or the --help option is given.

=item C<args>

A string describing mandatory arguments to display in the usage string.
eg: 

    print new Getopt::Compact
        (args => 'foo', cmd => 'bar.pl')->usage;

displays:

    usage: bar.pl [options] foo

=item C<modes>

This is a shortcut for defining boolean mode options, such as verbose
and test modes.  Set it to an arrayref of mode names, eg
[qw(verbose test)].  The following statements are equivalent:

    # longhand version
    my $go = new Getopt::Compact
        (struct => [[[qw(v verbose)], qw(verbose mode)],
                    [[qw(n test)],    qw(test mode)],
                    [[qw(d debug)],   qw(debug mode)],
                    [[qw(f foobar)],  qw(activate foobar)],
                   ]);

and

    # shorthand version
    my $go = new Getopt::Compact
        (modes => [qw(verbose test debug)],
         struct => [[[qw(f foobar)], qq(activate foobar)]]);

Mode options will be prepended to any options defined via the 'struct'
option.

=item C<struct>

This is where most of the option configuration is done.  The format
for a struct option is an arrayref of arrayrefs (see C<SYNOPSIS>) in
the following form (where [ ] denotes an array reference):

    struct => [optarray, optarray, ...]

and each optarray is an array reference in the following form:
(only 'name specification' is required)

    [name spec, description, argument spec, destination]

name specification may be a scalar string, eg "length", or a reference
to an array of alternate option names, eg [qw(l length)].  The option
name specification is also used to determine the key to the option
value in the hashref returned by C<opts()>.  See C<opts()> for more
information.

The argument specification is passed directly to Getopt::Long, so any
syntax recognised by Getopt::Long should also work here.  Some argument
specifications are:

    =s  Required string argument
    :s  Optional string argument
    =i  Required integer argument
    +   Value incrementing
    !   Negatable option

Refer to L<Getopt::Long> documentation for more details on argument
specifications.

The 'destination' is an optional reference to a variable that will
hold the option value.  If destination is not specified it will be
stored internally by Getopt::Compact and can be retrieved via the
opts() method.
This is useful if you want options to accept multiple values.  The
only way to achieve this is to use a destination that is a reference
to a list (see the joobies option in C<SYNOPSIS> by way of example).

=item C<configure>

Optional configure arguments to pass to Getopt::Long::Configure in the form
of a hashref of key, boolean value pairs.
By default, the following configuration is used:

{ no_auto_abbrev => 1, bundling => 1 }

To disable bundling and have case insensitive single-character options you
would do the following:

new Getopt::Compact
    (configure => { ignorecase_always => 1, bundling => 0 });

see Getopt::Long documentation for more information on configuration options.

=back

=item $go->usage()

    print $go->usage();

Returns a usage string.  Normally the usage string will be printed
automatically and the program will exit if the user supplies an
unrecognised argument or if the -h or --help option is given.
Automatic usage and exiting can be disabled by setting 'usage'
to false (0) in the constructor (see new()).
This method uses L<Text::Table> internally to format the usage output.

The following options may be automatically added by Getopt::Compact:

=over 4

=item "This help message" (-h or --help)

A help option is automatically prepended to the list of available
options if the C<usage> constructor option is true (this is enabled by
default).  When invoked with -h or --help, Getopt::Compact
automatically displays the usage string and exits.

=item "Display documentation" (--man)

This option is appended to the list of available options unless an
alternative --man option has been defined.  When invoked with --man,
Getopt::Compact prints a modified version of its POD to stdout and
exits.

=back

=item $go->pod2usage()

Displays the POD for the script.  The POD will be altered to include
C<USAGE>, C<NAME> and C<VERSION> sections unless they already exist.
This is invoked automatically when the --man option is given.

=item $go->status()

    print "getopt ".($go->status ? 'success' : 'error'),"\n";

The return value from Getopt::Long::Getoptions(). This is a true value
if the command line was processed successfully. Otherwise it returns a
false result.

=item $go->opts()

    $opt = $go->opts;

Returns a hashref of options keyed by option name.  If the
constructor usage option is true (on by default), then a usage string
will be printed and the program will exit if it encounters an
unrecognised option or the -h or --help option is given.

The key in %$opt for each option is determined by the option names
in the specification used in the C<struct> definition.  For example:

=over 4

=item ["foo", qw(foo option)]

The key will be "foo".

=item [[qw(f foo)], qw(foo option)]

=item [[qw(f foo foobar)], qw(foo option)]

In both cases the key will be "foo".  If multiple option names are
given, the first long option name (longer than one character) will be
used as the key.

=item [[qw(a b)], qq(a or b option)]

The key here will be "a".  If all alternatives are one character, the first option name in the list is used as the key

=back

=back

=head1 AUTHOR

Andrew Stewart Williams

=head1 SEE ALSO

Getopt::Long

=cut