@@ -1,3 +1,7 @@ Getopt-Chain-* Makefile inc +DBICx-Sucrose +Directory-Deploy +Sd +local .gitignore @@ -8,7 +8,7 @@ our $DEBUG = DEBUG; =head1 NAME -Getopt::Chain - Option and subcommand processing in the style svn(1) and git(1) +Getopt::Chain - Option and subcommand processing in the style of svn and git =head1 VERSION @@ -20,62 +20,6 @@ our $VERSION = '0.005'; =head1 SYNPOSIS - #!/usr/bin/perl -w - - use strict; - use Getopt::Chain; - - # A partial, pseudo-reimplementation of git(1): - - Getopt::Chain->process( - - options => [qw/ version bare git-dir=s /] - - run => sub { - my $context = shift; - my @arguments = @_; # Remaining, unparsed arguments - - # ... do stuff before any subcommand ... - - } - - commands => { - - init => { - options => [qw/ quiet|q --template=s /] - run => sub { - my $context = shift; - my @arguments = @_; # Again, remaining unparsed arguments - - # ... do init stuff ... - } - } - - commit => { - options => [qw/ all|a message|m=s /] - run => sub { - my $context = shift; - - # ... do commit stuff .. - } - } - - add => ... - - help => ... - - ... - } - ) - - # The above will allow the following (example) usage: - # - # ./script --version - # ./script --git-dir path/to/repository init - # ./script --git-dir path/to/repository commit -a --message '...' - # ./script commit -m '~' - - =head1 DESCRIPTION Getopt::Chain can be used to provide C<svn(1)>- and C<git(1)>-style option and subcommand processing. Any option specification @@ -90,90 +34,6 @@ for the subcommand. For example: So, for now, try to use distinct option names/aliases :) -Finally, this code fairly new so aspects of the API *might* change (particularly abort/error-handling). Let me know if you're using it and have any suggestions. - -TODO: Default values, option descriptions (like L<Getopt::Long::Descriptive>) and constraints (validation). - -=head1 Basic configuration - -A Getopt::Chain configuration is pretty straightforward - -Essentially you declare a command, which consists of (optional) <options> and an (optional) <run> subroutine (a CODE reference) - -<options> should be an ARRAY reference consisting of a L<Getopt::Long> specification - -<run> should be a CODE reference which is a subroutine that accepts a L<Getopt::Chain::Context> as the first argument and any remaining command-line -arguments (left after option parsing) as the rest of @_ - -A third parameter exists, <commands> in which you associate a <name> with a command, consisting (recursively) of <options>, <run>, and <commands> - -The <name> indicates what should be typed on the command-line to "trigger" the command. All-in-all, a configuration -looks something like this: - - options => [ ... ] - - run => sub {} - - commands => { - - <name1> => { - - options => [ ... ] - - run => sub {} - - commands => ... - }, - - <name2> => { - ... - }, - - ... Rinse, repeat, etc. - } - -See SYNPOSIS for an example - -=head1 Error-handling configuration - -Alongside <options>, <run>, and <commands>, you can designate a third parameter, <error> which is a either a CODE or HASH reference - -This is an error handler for dealing with the following situations: - - option_processing_error A Getopt::Long parsing error - - have_remainder When a dash or dash-dash string remains on the argument stack without being processed - - unknown_command When you've indicated that you want to accept a command but the user entered an unknown one - -You can either give a single subroutine to deal with all three, or give a HASH with: - -=over - -=item A subroutine for dealing with that specific error - -=item A value of '0' for disabling/ignoring that error - -=back - -For more detail (for now), look at the source: - - perldoc -m Getopt::Chain - -=head1 METHODS - -=head2 Getopt::Chain->process( <arguments>, ... ) - -<arguments> should be an ARRAY reference - -... should consist of a Getopt::Chain configuration - -=head2 Getopt::Chain->process( ... ) - -@ARGV will be used for <arguments> - -... should consist of a Getopt::Chain configuration - =cut use Moose; @@ -194,44 +54,6 @@ sub process { carp "Deprecated: Use Getopt::Chain::v005->process( ... ) to avoid this warning"; return Getopt::Chain::v005->process( @_ ); } -# my $self = shift; -# unless (ref $self) { -# my @process; -# push @process, shift if ref $_[0] eq "ARRAY"; -# my $self = $self->new; -# $self->parse( @_ ); -# return $self->process(@process); -# } -# my $self = shift; -# return $self->run( @_ ); -} - -sub parse { - my $self = shift; - my %schema = @_; - - $self->_parse_command( [] => \%schema ); -} - -sub _parse_command { - my $self = shift; - my $path = shift; - my $schema = shift; - - if ( ref $schema eq 'CODE' ) { - $schema = { run => $schema }; - } - - my $path_as_string = join ' ', @$path; - warn "Chain::_parse_command <$path_as_string>" if $DEBUG; - $self->builder->on( $path_as_string => ($schema->{options}, $schema->{run}), always_run => 1 ); - - if ( my $commands = $schema->{commands} ) { - - while( my ($command, $schema) = each %$commands ) { - $self->_parse_command( [ @$path, $command ] => $schema ); - } - } } sub run { lib/Getopt/Chain.pm @@ -15,6 +15,116 @@ use Hash::Param; use constant DEBUG => Getopt::Chain->DEBUG; our $DEBUG = DEBUG; +=head1 NAME + +Getopt::Chain::Context - Per-command context + +=head1 DESCRIPTION + +A context encapsulates the current state of execution, including: + + The name of the current command (or undef if at the "root") + Every option parsed so far + Options local to the current command + The arguments as they were BEFORE parsing options for this command + The arguments remaining AFTER parsing options for this command + +=head1 METHODS + +=head2 $context->command + +Returns the name of the current command (or undef in a special case) + + ./script --verbose edit --file xyzzy.c + # The command name is "edit" in the edit subroutine + + ./script --help + # The command name is undef in the root subroutine + +=head2 $context->option( <name> ) + +Returns the value of the option for <name> + +<name> should be primary name of the option (see L<Getopt::Long> for more information +on primary/alias naming) + +If called in list context and the value of option is an ARRAY reference, +then this method returns a list: + + ./script --exclude apple --exclude banana --exclude --cherry + ... + my @exclude = $context->option( exclude ) + +See L<Hash::Param> for more usage information + +=head2 $context->options( <name>, <name>, ... ) + +Similar to ->option( <name> ) except for many-at-once + +Returns a list in list context, and an ARRAY reference otherwise (you could +end up with a LoL situation in that case) + +See L<Hash::Param> for more usage information + +=head2 $context->options + +Returns the keys of the option hash in list context + +Returns the option HASH reference in scalar context + + ./script --verbose + ... + if ( $context->options->{verbose} ) { ... } + +See L<Hash::Param> for more usage information + +=head2 $context->local_option + +=head2 $context->local_options + +Behave similarly to ->option and ->options, except only cover options local to the current command + + ./script --verbose edit --file xyzzy.c + $context->local_option( file ) # Returns 'xyzzy.c' + $context->local_option( verbose ) # Doesn't return anything + $context->option( verbose ) # Returns 1 + +=head2 $context->stash + +An initially empty HASH reference that can be used for sharing inter-command information + +Similar to the stash in L<Catalyst> + +=head2 $context->arguments + +Returns a copy of the arguments (@ARGV) for the current command BEFORE option parsing + +Returns an ARRAY reference (still a copy) when called in scalar context + + ./script --verbose edit --file xyzzy.c + + # At the very beginning: + $context->arguments # Returns ( --verbose edit --file xyzzy.c ) + + # In the "edit" subroutine: + $context->arguments # Returns ( edit --file xyzzy.c ) + +=head2 $context->remaining_arguments + +Returns a copy of the remaining arguments (@ARGV) for the current command AFTER option parsing + +Returns an ARRAY reference (still a copy) when called in scalar context + + ./script --verbose edit --file xyzzy.c + + # At the very beginning: + $context->remaining_arguments # Returns ( edit --file xyzzy.c ) + + # In the "edit" subroutine: + $context->remaining_arguments # Returns ( ) + +=cut + # Should probably move these into Getopt::Chain # ...or even... Getopt::Longer :) sub is_option_like($) { @@ -252,326 +362,3 @@ sub run { 1; -__END__ - -=head1 NAME - -Getopt::Chain::Context - Per-command context - -=head1 DESCRIPTION - -A context encapsulates the current state of execution, including: - - The name of the current command (or undef if at the "root") - Every option parsed so far - Options local to the current command - The arguments as they were BEFORE parsing options for this command - The arguments remaining AFTER parsing options for this command - -=head1 METHODS - -=head2 $context->command - -Returns the name of the current command (or undef in a special case) - - ./script --verbose edit --file xyzzy.c - # The command name is "edit" in the edit subroutine - - ./script --help - # The command name is undef in the root subroutine - -=head2 $context->option( <name> ) - -Returns the value of the option for <name> - -<name> should be primary name of the option (see L<Getopt::Long> for more information -on primary/alias naming) - -If called in list context and the value of option is an ARRAY reference, -then this method returns a list: - - ./script --exclude apple --exclude banana --exclude --cherry - ... - my @exclude = $context->option( exclude ) - -See L<Hash::Param> for more usage information - -=head2 $context->options( <name>, <name>, ... ) - -Similar to ->option( <name> ) except for many-at-once - -Returns a list in list context, and an ARRAY reference otherwise (you could -end up with a LoL situation in that case) - -See L<Hash::Param> for more usage information - -=head2 $context->options - -Returns the keys of the option hash in list context - -Returns the option HASH reference in scalar context - - ./script --verbose - ... - if ( $context->options->{verbose} ) { ... } - -See L<Hash::Param> for more usage information - -=head2 $context->local_option - -=head2 $context->local_options - -Behave similarly to ->option and ->options, except only cover options local to the current command - - ./script --verbose edit --file xyzzy.c - $context->local_option( file ) # Returns 'xyzzy.c' - $context->local_option( verbose ) # Doesn't return anything - $context->option( verbose ) # Returns 1 - -=head2 $context->stash - -An initially empty HASH reference that can be used for sharing inter-command information - -Similar to the stash in L<Catalyst> - -=head2 $context->arguments - -Returns a copy of the arguments (@ARGV) for the current command BEFORE option parsing - -Returns an ARRAY reference (still a copy) when called in scalar context - - ./script --verbose edit --file xyzzy.c - - # At the very beginning: - $context->arguments # Returns ( --verbose edit --file xyzzy.c ) - - # In the "edit" subroutine: - $context->arguments # Returns ( edit --file xyzzy.c ) - -=head2 $context->remaining_arguments - -Returns a copy of the remaining arguments (@ARGV) for the current command AFTER option parsing - -Returns an ARRAY reference (still a copy) when called in scalar context - - ./script --verbose edit --file xyzzy.c - - # At the very beginning: - $context->remaining_arguments # Returns ( edit --file xyzzy.c ) - - # In the "edit" subroutine: - $context->remaining_arguments # Returns ( ) - -=head2 $context->abort( [ ... ] ) - -Immediately exit the process with exit code of -1 - -If the optional ... (message) is given, then print that out to STDERR first - -=head1 SEE ALSO - -L<Getopt::Chain> - -=cut - -use Hash::Param; - -has options => qw/reader _options lazy_build 1 isa HashRef/; -sub _build_options { - my $self = shift; - return {}; -} - -has options_ => qw/is ro isa Hash::Param lazy_build 1/, handles => {qw/option param options params/}; -sub _build_options_ { - my $self = shift; - return Hash::Param->new(params => $self->_options); -} - -has chain => qw/is ro isa ArrayRef/, default => sub { [] }; - -has stash => qw/is ro isa HashRef/, default => sub { {} }; - -sub BUILD { - my $self = shift; - my $given = shift; -} - -sub push { - my $self = shift; - my $link = Getopt::Chain::Context::Link->new(context => $self, @_); - push @{ $self->chain }, $link; - return $link; -} - -sub pop { - my $self = shift; - pop @{ $self->chain }; -} - -sub run { - my $self = shift; - my $path = shift || ""; - - my @path = grep { length $_ } split m/[ \/]+/, $path; - - my $link = $self->link; - my $processor = $self->link(0)->processor; - for (@path) { - # TODO Probably call this 'resolve' - $processor = $processor->commands->{$_} or croak "Couldn't traverse $path: $_ not found"; - } - - $self->push(processor => $processor, command => $path[-1], - arguments => $link->_arguments, remaining_arguments => $link->_remaining_arguments, options => scalar $link->options); - - $processor->run->($self, @_); - - $self->pop; -} - -sub update { - my $self = shift; - - my $link = $self->link; - - my $local_options = $self->local_options_; - my $options = $self->options_; - - for my $key ($local_options->params) { - $options->param($key => scalar $local_options->param($key)); - } -} - -sub link { - my $self = shift; - my $at = shift; - - $at = -1 unless defined $at; - return $self->chain->[$at]; -} - -sub local_option { - my $self = shift; - return $self->link->option(@_); -} - -sub local_options { - my $self = shift; - return $self->link->options(@_); -} - -sub local_options_ { - my $self = shift; - return $self->link->options_(@_); -} - -for my $method (qw/processor command arguments remaining_arguments remainder valid/) { - no strict 'refs'; - *$method = sub { - my $self = shift; - return $self->link->$method(@_); - }; -} - -sub abort { - my $self = shift; - print STDERR "$0: "; - if (@_) { - my @__ = @_; # Modification of read-only value ... - chomp $__[-1]; - print STDERR join "", @__, "\n"; - } - else { - print STDERR "Unknown error: aborting"; - } - exit -1; -} - -package Getopt::Chain::Context::Link; - -use Moose; -use Getopt::Chain::Carp; - -use Hash::Param; - -has context => qw/is ro required 1 isa Getopt::Chain::Context/, handles => [qw/all_options/]; - -has processor => qw/is ro required 1 isa Getopt::Chain/; - -has command => qw/is ro required 1 isa Maybe[Str]/; - -has options => qw/reader _options required 1 isa HashRef/; - -has options_ => qw/is ro isa Hash::Param lazy_build 1/, handles => {qw/option param options params/}; -sub _build_options_ { - my $self = shift; - return Hash::Param->new(params => $self->_options); -} - -has arguments => qw/is ro reader _arguments required 1 isa ArrayRef/; -sub arguments { - my @arguments = @{ shift->_arguments }; - return wantarray ? @arguments : \@arguments; -} - -has remaining_arguments => qw/is ro reader _remaining_arguments required 1 isa ArrayRef/; -sub remaining_arguments { - my @arguments = @{ shift->_remaining_arguments }; - return wantarray ? @arguments : \@arguments; -} - -sub remainder { - return scalar shift->remaining_arguments; -} - -has valid => qw/is rw/; - -1; - -__END__ - -sub options { - my $self = shift; - - if (@_) { - return $self->option(@_); - } - else { - return wantarray ? keys %{ $self->_options } : $self->_options; - } -} - -sub option { - my $self = shift; - - if (@_ == 0) { - return $self->options; - } - - if (@_ == 1) { - - my $option = shift; - - unless (exists $self->_options->{$option}) { - return wantarray ? () : undef; - } - - if (ref $self->_options->{$option} eq 'ARRAY') { - return (wantarray) - ? @{ $self->_options->{$option} } - : $self->_options->{$option}->[0]; - } - else { - return (wantarray) - ? ($self->_options->{$option}) - : $self->_options->{$option}; - } - } - elsif (@_ > 1) { - my @options = map { scalar $self->option($_) } @_; - return wantarray ? @options : \@options; - } -} - -1; lib/Getopt/Chain/Context.pm 2885726c4b555fce8a83e0c5e58030d40d4b7971 robertkrimen robertkrimen@gmail.com http://github.com/robertkrimen/Getopt-Chain/commit/ab0b6c1f73cb6887058b93eaec5d5bbd301be48c ab0b6c1f73cb6887058b93eaec5d5bbd301be48c 2009-05-11T13:56:35-07:00 2009-05-11T13:56:35-07:00 Boilerplate documentation, but need to rework bb951465ec9fe20af335378365b7104418f8e9e9 robertkrimen robertkrimen@gmail.com