package Argdom;
use 5.006;
require Exporter;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(new new setKeyChooser setSingleChooser chooseKeys chooseS
+ingles chooseArbs getArbitraries getArbs getSingles getKeys that that
+);
@EXPORT_OK = qw(ref ref);

our $VERSION = '1.0';

use warnings;
use strict;

{package Arg;

my $pos = 0;

sub new
{
    my ($self, $arg, $r) = (shift, shift, {});
    $r->{arg} = $arg;
    $r->{pos} = $pos++;
    bless $r, $self;
}
}

{sub new
{
    my ($self, $args, $r) = (shift, shift, {});
    my @argobjs = ();
    croak 'Argument to Argdom constructor must be an array reference (
+usually \@ARGV)' unless ref $args eq 'ARRAY';
    $r->{kc}   = undef;
    $r->{sc}   = undef;
    push @argobjs, new Arg($_) foreach (@{$args});
    $r->{args} = \@argobjs;
    bless $r, $self;
}

sub setKeyChooser
{
    my ($self, $chooser) = (shift, shift);
    croak 'Argument to Argdom::setKeyChooser must be a code reference'
+ unless ref $chooser eq 'CODE';
    $self->{kc} = $chooser;
    $self->chooseKeys;
    $self;
}

sub setSingleChooser
{
    my ($self, $chooser) = (shift, shift);
    croak 'Argument to Argdom::setSingleChooser must be a code referen
+ce' unless ref $chooser eq 'CODE';
    $self->{sc} = $chooser;
    $self->chooseSingles;
    $self;
}

sub chooseKeys
{
    my ($self, $keys, $pushNext, $pushNextTo, $notI) = (shift, {}, 0, 
+'', 0);
    foreach my $arg (@{$self->{args}})
    {
        if($pushNext)
        {
            $pushNext = 0;
            push @{$keys->{$pushNextTo}}, $arg->{arg};
            $self->{args}->[$notI]->{seen} = 1;
            next;
        }
        if($self->{kc}->($arg->{arg}))
        {
            $keys->{$arg->{arg}} = [] unless $keys->{$arg->{arg}};
            $pushNextTo   = $arg->{arg};
            $self->{args}->[$notI]->{seen} = 1;
            $pushNext     = 1;
        }
    }
    continue
    {
        ++$notI;
    }
    $self->{keys}       = $keys;
    $self->{keysChosen} = 1;
    $self->chooseArbs if $self->{singlesChosen};
    $notI;
}

sub chooseSingles
{
    my ($self, $notI) = (shift, 0);
    my @singles = ();
    foreach my $arg (@{$self->{args}})
    {
        if($self->{sc}->($arg->{arg}))
        {
            push @singles, $arg->{arg};
            $self->{args}->[$notI]->{seen} = 1;
        }
    }
    continue
    {
        ++$notI;
    }
    $self->{singles}       = \@singles;
    $self->{singlesChosen} = 1;
    $self->chooseArbs if $self->{keysChosen};
    $notI;
}

sub chooseArbs
{
    my ($self, $notI) = (shift, 0);
    my @arbs = ();
    foreach my $arg (@{$self->{args}})
    {
        unless($arg->{seen})
        {
            push @arbs, $arg->{arg};
            ++$notI;
        }
    }
    $self->{arbs} = \@arbs;
    $notI;
}

sub getArbitraries
{ 
    return @{(shift)->{arbs}} if wantarray;
    (shift)->{arbs};
}

sub getArbs
{ 
    return @{(shift)->{arbs}} if wantarray;
    (shift)->{arbs};
}

sub getSingles
{ 
    return @{(shift)->{singles}} if wantarray;
    (shift)->{singles};
}

sub getKeys { (shift)->{keys} }

}
1;

#    POD, now ...

__DATA__

=pod

=head1 NAME

Argdom.pm - Argument-managing module for Perl 5

=head1 SYNOPSIS

    #! /usr/bin/perl
    use Argdom;
    use warnings;
    use strict;
    #    This will result in a script that takes some of the commonly-
+used GCC commands, and tell you what it deems them as:
    my $isItSingle =
    sub
    {
        my $who = shift;
        foreach my $sk (qw(--help -S -E -c -g -pg -pedantic -pedantic-
+errors))
        {
            return 1 if $sk eq $who;
        }
        foreach my $sk (qw(-std= -O -W -I -L -D -U -f -m))
        {
            return 1 if substr($who, 0, length $sk) eq $sk and (length
+ $who > length $sk);
        }
        0;
    };
    my $isItAKey = 
    sub
    {
        my $who = shift;
        foreach my $kk (qw(-o -x))
        {
            return 1 if $kk eq $who;
        }
        0;
    };
    my $args = \@ARGV;
    my $a = new Argdom($args);
    $a->setKeyChooser($isItAKey);
    $a->setSingleChooser($isItSingle);
    my @s = @{$a->getSingles};
    my %k = %{$a->getKeys};
    print "\n";
    print $_, " was passed as a single argument.\n" foreach (@s);
    print "\n";
    foreach my $k1 (keys %k)
    {
        printf "The values passed for the %s switch are:\n", $k1;
        print "\t", $_, "\n" foreach (@{$k{$k1}});
    }
    print $_, " was passed as an ``arbitrary'' argument.\n" foreach (@
+{$a->getArbs});

=head1 DESCRIPTION

Argdom helps you manage arguments (usually C<@ARGV>). The name is take
+n from B<Arg>uments + B<DOM> (I like to think of it as C<@ARGV>'s Doc
+ument Object Model).

The whole idea is to separate arguments into three groups: key-value a
+rguments (the paired ones, like C<-o outputfile -x language>), single
+ arguments (like C<-pedantic -DSOME_MACRO_DEFINITION>), and the ``arb
+itrary'' arguments (the ones that are not paired and do not give the 
+program a directive, like the input file for perl). Using this module
+ is I<very> easy.

In the end, anyway, your code decides which argument to treat as what,
+ and more about what happens is below.

=head1 USAGE

=head2 Initialisation

The Argdom cunstructor takes only one argument E<#8212> the reference 
+to the argument array.

    my $a = new Argdom(\@ARGV);    #    Will suffice

From then on, you may not have to worry yourself with C<@ARGV> (except
+ to work around the weakness noted L<here|/"Order-of-Passing is Garbl
+ed Across Argument Types">, if the work-around trick explained L<here
+|/"Work-around"> is not used).

=head2 Choosers-n-Pickers

You've got to attach two references to predicate subs to the object. T
+hey are used to determine which class an arg belongs to.

=head3 C<setKeyChooser>

C<setKeyChooser> is used to attach a reference to a sub that, when fed
+ with an argument, should return true if that argument is expected, b
+y the script, as the key part of a key-value pair of args.

Example: your script (called `greeter') requires args, and one of them
+ is `-o' to denote the file into which the output should be written.
C<greeter -o outfile>

You would set the key chooser (C<Argdom::setKeyChooser>'s arg) to be a
+ reference to a sub that returns true when given the string `-o'. Thi
+s will make object's internal logic associate the other argument, C<o
+utfile> with C<-o>, and return C<outfile> the next time you ask for t
+he vakues of the key C<-o>.

That is used I<comme ci>:

    $a->setKeyChooser(sub { $_[0] eq '-o'  } );

=over 4

=item Note:

If an argument is deemed a key in a key-value pair, the next argument 
+is, automatically, deemed as it's value, and it is not passed to any 
+predicates for classification. It is just pushed against the key, as 
+its value.

=back

=head3 C<setSingleChooser>

The same applies to C<setSingleChooser>, except that the sub ref set b
+y C<setSingleChooser> should return true if the argument is a single 
+key.

Example: greeter takes an argument `-xclaim', to tell it whether it sh
+ould put an exclamation mark at the end of the output string. As in:
C<greeter -xclaim>

That's not a paired argument (because it doesn't take an arg after the
+ `-xclaim' as additional data), and, if your code deems it as a singl
+e argument, all the other args passed after it (even immediately afte
+r) are not related to it. So, C<greeter -xclaim someother> doesn't ma
+ke C<someother> a value of the key C<-xclaim>.

    $a->setSingleChooser(sub { ($_[0] eq '-xclaim') or (substr($_[0], 
+0, 2) eq '-4')  } );

That is used I<comme E<ccedil>a>.

You may have noticed that the sub ref also returns true for a string p
+assed to it that starts with `-4'. That's to display another thing yo
+u could do. You may want to classify some args that are not pre-known
+ E<#8212> they are single args, but they are not definite. Like C<gre
+eter '-4Somebody;World;Nurse'>. You only return true if it matches th
+e beginning bit, for example.

=head3 How The Arbitrary Arguments Are Chosen

When both C<setSingleChooser> and C<setKeyChooser> have been set, the 
+object automatically calls the method to set the arbitrary arguments.
Remember, the arbitrary args are those that, simply-put, are neither d
+enoted as singles or keys. Also, when you set the choosers, the choos
+ing is done there and then, with your set choosers.

=head2 Working With The Arguments

After the object has worked with the arguments, you can get them back,
+ classified and (where applicable) linked with other args with which 
+they correspond.

Example:

=head3 C<getSingles>

    my @singles = @{$a->getSingles};
    my @singles = $a->getSingles;


C<Argdom::getSingles> returns a reference to an array containing the s
+ingle keys, in the order in which they were passed in.
So, C<join(', ', @singles) eq '-xclaim, -4Somebody;World;Nurse'> for t
+he invocation: C<greeter -xclaim '-4Somebody;World;Nurse'>. If called
+ in list context, it returns a list of the items, not a reference to 
+that list; as in the second line of code, above.

=head3 C<getKeys>

    my %keyvals = %{$a->getKeys};

C<Argdom::keyVals> returns a reference to a hash containing all the ke
+y-value args, with the keys having an array ref of the respective val
+ues. This enables you to get many values on the same key arg. Like, 
C<greeter -o outfile1 -xclaim -o outfile2 -o ->
would make C<getKeys> return a hash ref like this:
C<{'-o' =E<gt> ['outfile', 'outfile2', '-']}>.

=head3 C<getArbs> or C<getArbitraries>

    my @arbs = @{$a->getArbs};
    my @arbs = $a->getArbs;

C<Argdom::getArbitraries> is a synonym for C<Argdom::getArbs>, which r
+eturns a ref of an array containing all the arbitrary args, in their 
+order. If called in a list context, it returns the array itself, not 
+its reference; as in the second line of code, above.
This enables the program to take args in just any order, since there i
+s no such things as the-last-arg-is-the-this-and-that. You just insis
+t on proper denoting of arguments (say, directives having `-' at the 
+start and keys always having their values attached), and use the same
+ criterion in the choosers, and you have the args as you want them.
The invocation C<greeter -o outfile "Some Text"> would cause C<getArbs
+> to return C<['Some Text']>, since that's the only arbitrary argumen
+t there.

=head2 Example: C<greeter>

=head3 Source Code

    #! /usr/bin/perl
    use warnings;
    use strict;
    use Argdom;
    my $a = new Argdom(\@ARGV);
    $a->setSingleChooser(sub { $_[0] eq '-xclaim' or substr($_[0], 0, 
+2) eq '-4'  } );
    $a->setKeyChooser(sub { $_[0] eq '-o'  } );
    my @arbs  = $a->getArbs;
    my @sings = $a->getSingles;
    my ($greeting, $x, $forWhom, $outs) = ('', 0, '-4World;to you', ['
+-']);
    #    --help and -h can only be in @arbs, since they are never iden
+tified as keys or singles
    foreach (@arbs)
    {
        if($_ eq '-h' or $_ eq '--help')
        {
            my $hlp =
    qq/--help | -h displays this help message and quits.
    -o outfile is the file to which the output is written. Can be many
+, as in -o f1 -o f2 -o f3. `-' means the STDOUT (default).
    -xclaim means the output should be exclamatory.
    -4X;Y;Z means the greeting should be for X, Y, and Z. Default is `
+`World'' and yourself!.
    any other args are the greeting. Default is "Hello"./;
            printf "\ngreeter is a sample program for Argdom.pm.\n%s\n
+\n", $hlp;
            exit 0;
        }
        $greeting .= $_;
    }
    $greeting = 'Hello' unless $greeting;
    foreach (@sings)
    {
        $x = 1 if $_ eq '-xclaim';
        $forWhom = $_ if substr($_, 0, 2) eq '-4'
    }
    my @toWhom = ();
    my $ls = substr $forWhom, 2;
    @toWhom = split /;/, $ls;
    $outs = $a->getKeys->{'-o'} if $a->getKeys->{'-o'};
    foreach my $outfile (@{$outs})
    {
        my $string = '';
        $string .= "$greeting, $_" . ($x ? '!' : '.') . "\n" foreach (
+@toWhom);
        print $string if $outfile eq '-';
        unless($outfile eq '-')
        {
            open(OUTHANDLE), '>', $outfile or croak "Could not open $o
+utfile for writing: $!";
            print OUTHANDLE $string;
            close OUTHANDLE;
        }
    }

=head3 Sample Runs

    greeter
    Hello, World.
    Hello, to you.
    
    greeter -xclaim
    Hello, World!
    Hello, to you!
    
    greeter '-4Me;You;World;Nurse' -xclaim 'How on Earth are you doing
+'
    How on Earth are you doing, Me!
    How on Earth are you doing, You!
    How on Earth are you doing, World!
    How on Earth are you doing, Nurse!
    
    greeter -xclaim '-4Captain;Skipper;Sir Hal;Lord Cumbrae' 'Aye, aye
+'
    Aye, aye, Captain!
    Aye, aye, Skipper!
    Aye, aye, Sir Hal!
    Aye, aye, Lord Cumbrae!
    
    (Eh, I see you've been reading some Wilbur Smith, too, eh?)
    
    greeter -xclaim '-4you blank-minded nincompoop' 'Git da frig outta
+ ' here
    Git da frig outta here, you blank-minded nincompoop!
    
    (It doesn't always have to be formal. It's why we put the args, in
+ the first place.)
    
    greeter -o 1.gr -o 2.gr -o -
    Hello, World.
    Hello, to you.
    cat 1.gr 2.gr
    Hello, World.
    Hello, to you.
    Hello, World.
    Hello, to you.

C<greeter --help> and C<greeter -h> give you help.

=head1 BUGS

Because missing features are bugs ...

=head2 Order-of-Passing is Garbled Across Argument Types

While the order in which the arguments has been passed is preserved, t
+he module does not ease the job of finding out which args came before
+ which, if they are not of the same kind.

This is a problem, when how you treat some arguments depends on the po
+sition of other arguments of a different kind.

=head3 Work-around

To work around this, you can keep track of the arguments consciously, 
+via the sub referred to by the argument to C<setSingleChooser>, since
+ it gets every argument passed to it.

=head2 Private Members not Denoted

The coding convention of private members beginning with a double under
+line (C<__>) is not obeyed here. I wasn't too sure what was supposed 
+to be ``hidden'' and what wasn't.

=head3 Work-around

Do not use methods and stuff that are not documented here, because thi
+s is all that has been explained, either by documentation or by conve
+ntion.

=head1 AUTHOR

Revence XXVII <revence27@praize.com>

=head1 COPYRIGHT

No copyright.
No licence.
This module, the ideas, and all the related intellectual property here
+in, I hereby place in the Public Domain.

=cut
[download]