Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

syncing changes. parser done-ish, tests pending

  • Loading branch information...
commit 8c65440986e5afd8cae70469971ac124ee790013 1 parent 3bdf9dd
@garu garu authored
View
23 Changes
@@ -1,12 +1,33 @@
Revision history for App-Rad
-1.05 2009/08/
+1.05_01 2009/08/
+
+ *** KNOWN BUG ***
+ @ARGV is left unchanged. As a result, $c->getopt no longer works.
+ This should be fixed by the time 1.05 comes out.
+ ******************
+
*** API CHANGE ***
$c->execute does not call 'default' or 'invalid' commands anymore if
it can't find the command name. Rad itself still does, but via
parse_input. You don't have to worry about this unless you make
explicit calls to $c->execute.
******************
+
+ *** API CHANGE ***
+ if you redefine invalid(), note the invalid command is no longer
+ passed as $c->cmd. This was inconsistent, being it's not an actual
+ command. Now, the invalid subroutine receives 2 arguments: $c and
+ the offending command, so you can do:
+
+ sub invalid {
+ my ($c, $invalid_command) = (@_);
+ ...
+ }
+
+ all other subroutines keep receiving just $c as argument.
+ ******************
+
$c->path and $c->realpath new auxiliary methods for giving you the
app's bin path and realbin path (via FindBin core module) -
View
595 lib/App/Rad.pm
@@ -9,19 +9,19 @@ use strict;
our $VERSION = '1.04';
{
- #========================#
- # INTERNAL FUNCTIONS #
- #========================#
+#========================#
+# INTERNAL FUNCTIONS #
+#========================#
- my @OPTIONS = ();
+my @OPTIONS = ();
- # - "I'm so excited! Feels like I'm 14 again" (edenc on Rad)
- sub _init {
+# - "I'm so excited! Feels like I'm 14 again" (edenc on Rad)
+sub _init {
my $c = shift;
# instantiate references for the first time
$c->{'_ARGV'} = [];
- $c->{'_options'} = {};
+ #$c->{'_options'} = {};
$c->{'_stash'} = {};
$c->{'_config'} = {};
$c->{'_plugins'} = [];
@@ -37,6 +37,9 @@ our $VERSION = '1.04';
'invalid' => \&invalid,
'teardown' => \&teardown,
};
+
+ # create our standard global command
+ $c->register( '', sub {} );
#load extensions
App::Rad::Help->load($c);
@@ -64,14 +67,14 @@ our $VERSION = '1.04';
$c->debug( 'initializing: default commands are: '
. join( ', ', $c->commands() ) );
}
- }
+}
- sub import {
+sub import {
my $class = shift;
@OPTIONS = @_;
- }
+}
- sub load_plugin {
+sub load_plugin {
my $c = shift;
my $plugin = shift;
my $class = ref $c;
@@ -103,18 +106,18 @@ our $VERSION = '1.04';
# fill $c->plugins()
push @{ $c->{'_plugins'} }, $plugin;
}
- }
+}
- # this function browses a file's
- # symbol table (usually 'main') and maps
- # each function to a hash
- #
- # FIXME: if I create a sub here (Rad.pm) and
- # there is a global variable with that same name
- # inside the user's program (e.g.: sub ARGV {}),
- # the name will appear here as a command. It really
- # shouldn't...
- sub _get_subs_from {
+# this function browses a file's
+# symbol table (usually 'main') and maps
+# each function to a hash
+#
+# FIXME: if I create a sub here (Rad.pm) and
+# there is a global variable with that same name
+# inside the user's program (e.g.: sub ARGV {}),
+# the name will appear here as a command. It really
+# shouldn't...
+sub _get_subs_from {
my $package = shift || 'main';
$package .= '::';
@@ -128,12 +131,12 @@ our $VERSION = '1.04';
}
}
return %subs;
- }
+}
- # overrides our pre-defined control
- # functions with any available
- # user-defined ones
- sub _register_functions {
+# overrides our pre-defined control
+# functions with any available
+# user-defined ones
+sub _register_functions {
my $c = shift;
my %subs = _get_subs_from('main');
@@ -145,11 +148,173 @@ our $VERSION = '1.04';
$c->{'_functions'}->{$_} = $subs{$_};
}
}
+}
+
+# retrieves command line arguments
+# to be executed by the main program
+#
+#When the parser starts, it fetches tokens left to right, validating them agains Global options. At the first argument not specified by a previous Global option, or at the first token that doesn't start with a hyphen (i.e. the first non-option given), the parser will determine which command it is. If the token is not a valid command, the invalid command is called. If there is no token at all, then the default command is called instead.
+#TODO: handle ARGV
+sub parse_input {
+ my $c = shift;
+ my @input = @_ || @ARGV; #TODO: keep doing this?
+ my $slurp = 0;
+ my $invalid;
+
+print STDERR ">>> starting parser\n";
+ # we start with the global command
+ #my $current_command = $c->{'_globals'};
+ my $current_command = $c->{'_commands'}->{''};
+ my ($option_name, $option_value, $arguments_left);
+
+ while (my $token = shift @input) {
+print STDERR ">>> token is '$token'\n";
+ # '--' marks the end of options
+ if ($token eq '--') {
+print STDERR ">>> slurping...\n";
+ $slurp = 1;
+ }
+ # option found
+ elsif ( $token =~ s/^-// ) {
+print STDERR ">>> option found\n";
+ Carp::croak "Missing $arguments_left argument(s) for option $option_name"
+ if $arguments_left;
+
+ # -foo=bar, --foo, --foo=bar
+ #if ( $token =~ m/^-?([^=]+)(?:=(.+))?/o ) {
+ #TODO: regex improvement?
+ #if ( $token =~ m/^(?:-([^=]+)(?:=(.+))?)|([^-=])+=(.+)$/o ) {
+ if ( $token =~ m/^(?:-([^=]+)(?:=(.+))?|([^-=]+)=(.+))$/o ) {
+ ($option_name, $option_value) = (defined $4 ? ($3, $4) : ($1, $2));
+print STDERR ">>> -foo=bar, --foo, --foo=bar\n";
+ }
+ # -foo
+ else {
+print STDERR ">>> -foo\n";
+ my @flags = split //, $token;
+ # -f -o -o (if all elements are valid options, we push them back)
+ if (@flags > 1
+ && @flags == (grep { $current_command->is_option($_) } @flags) ) {
+print STDERR ">>> '@flags' are valid options, pushing them back\n";
+ unshift @input, map { '-' . $_ } @flags;
+ next;
+ }
+ # otherwise, -foo means the "foo" option
+ else {
+print STDERR ">>> '$token' means the '$token' option\n";
+ ($option_name, $option_value) = ($token, undef);
+ }
+ }
+print STDERR ">>> setting option '$option_name' with value '$option_value'\n";
+ $arguments_left = $current_command->setopt($option_name, $option_value);
+print STDERR ">>> returned $arguments_left as the number of arguments left for that option\n";
+ }
+ # when in slurp mode, tokens are arguments
+ elsif ($slurp or $arguments_left) {
+print STDERR ">>> we are in slurp mode, or there are arguments left\n";
+ if (defined $option_name) {
+print STDERR ">>> pushing yet another argument to option '$option_name' (value: '$token')\n";
+ $arguments_left = $current_command->setopt($option_name, $token);
+print STDERR ">>> number of arguments left for option '$option_name': $arguments_left\n";
+ }
+ else {
+print STDERR ">>> pushing token '$token' to c->argv queue\n";
+ push @{$c->argv}, $token;
+ }
+ }
+ # we already have a command, so it's a stand-alone argument
+ # TODO: should we allow it in all cases?
+ # TODO: parsing chained commands
+ elsif ( defined $c->cmd or defined $invalid) {
+print STDERR ">>> we already have a command, push token '$token' to c->argv queue\n";
+ push @{$c->argv}, $token;
+ }
+ # it's a command, and no previous command was set
+ elsif ( $c->is_command($token) ) {
+ $current_command = $c->{'_commands'}->{$token};
+ $c->cmd = $current_command->name;
+print STDERR ">>> got command: '" . $c->cmd . "'\n";
+ }
+ # it's an invalid command
+ else {
+print STDERR ">>> TODO: invalid command\n";
+ $invalid = $token; #TODO: pass it as something else, maybe?
+ # return;
+ # set as invalid and mark $c->cmd, but keep parsing the invalid
+ # command as '' (global)
+ #$invalid = 1;
+ }
+ }
+ Carp::croak "missing $arguments_left argument(s) for option '$option_name'"
+ if $arguments_left;
+
+ # TODO: this should be done whenever a command is 'done',
+ # not when the input is over
+ check_required($current_command); # TODO: this goes into Parser.pm
+ check_conflicts($current_command); # TODO: this goes into Parser.pm
+ set_defaults($current_command); # TODO: this goes into Parser.pm
+ push_to_stash($c, $current_command); # TODO: this goes into Parser.pm
+
+ # let caller know if command was set or if we'll use the default
+ $c->cmd = '' unless defined $c->cmd;
+ return $invalid;
+}
+
+sub check_required {
+ my $command = shift;
+ foreach my $option (keys %{ $command->{opts} }) {
+ if ( $command->{opts}->{$option}->{required}
+ and not exists $command->options->{$option}
+ ) {
+ require Carp;
+ Carp::croak "option '$option' is required for command " . $command->name;
+ }
}
+}
- # retrieves command line arguments
- # to be executed by the main program
- sub parse_input {
+sub check_conflicts {
+ my $command = shift;
+ foreach my $option (sort keys %{ $command->{options} }) {
+ my $conflicts = $command->{opts}->{$option}->{conflicts_with};
+ if ( $conflicts ) {
+ # TODO make sure we store it as a ref, so we don't have to do the below
+ $conflicts = [ $conflicts ] unless ref $conflicts;
+
+ foreach my $conflict ( @{$conflicts} ) {
+ if (defined $command->{options}->{$conflict}) {
+ require Carp;
+ Carp::croak "options '$option' and '$conflict' conflict and can not be used together";
+ }
+ }
+ }
+ }
+}
+
+sub set_defaults {
+ my $command = shift;
+ foreach my $option (keys %{ $command->{opts} }) {
+ if ( $command->{opts}->{$option}->{default}
+ and not exists $command->options->{$option}
+ ) {
+ $command->options->{$option} = $command->{opts}->{$option}->{default};
+ }
+ }
+}
+
+sub push_to_stash {
+ my ($c, $command) = (@_);
+ foreach my $option (keys %{ $command->{opts} }) {
+ if ( $command->options->{$option} and (my $stash = $command->{opts}->{$option}->{to_stash} )) {
+ $stash = [ $stash ] unless ref $stash; # TODO: always store to_stash under an array ref
+
+ foreach my $elem ( @{$stash} ) {
+ $c->stash->{$elem} = $command->options->{$option};
+ }
+ }
+ }
+}
+
+sub __parse_input {
my $c = shift;
# parse global arguments out of ARGV
@@ -184,9 +349,9 @@ our $VERSION = '1.04';
$c->_parse( \@tARGV, $cmd_obj );
}
return $cmd; # default (''), invalid (undef), command ($cmd)
- }
+}
- sub _parse {
+sub _parse {
my ( $c, $arg_ref, $cmd_obj ) = (@_);
# al newkirk: conflict support
@@ -201,8 +366,8 @@ our $VERSION = '1.04';
# single option (could be grouped)
if ( $arg =~ m/^\-([^\-\=]+)$/o ) {
- my @args = split //, $1;
- foreach (@args) {
+ my @args = split //, $1;
+ foreach (@args) {
# _parse_arg returns the options' name
# and its "to_stash" values as an arrayref,
@@ -213,13 +378,13 @@ our $VERSION = '1.04';
# improve it will be **much** appreciated. Thanks!
my ( $opt, $to_stash ) = ( $_, undef );
if ( defined $cmd_obj ) {
- ( $opt, $to_stash ) = $cmd_obj->_parse_arg($opt);
- unless ($opt) {
- die "Error: $to_stash";
+ ( $opt, $to_stash ) = $cmd_obj->_parse_arg($opt);
+ unless ($opt) {
+ die "Error: $to_stash";
- # TODO x 2: this should be forwared to an
- # overridable help error handler or whatever
- }
+ # TODO x 2: this should be forwared to an
+ # overridable help error handler or whatever
+ }
}
$c->options->{$opt} =
@@ -228,10 +393,10 @@ our $VERSION = '1.04';
: 1;
foreach my $stash_key (@$to_stash) {
- $c->stash->{$stash_key} =
- ( defined $c->stash->{$stash_key} )
- ? $c->stash->{$stash_key} + 1
- : 1;
+ $c->stash->{$stash_key} =
+ ( defined $c->stash->{$stash_key} )
+ ? $c->stash->{$stash_key} + 1
+ : 1;
}
}
}
@@ -303,45 +468,47 @@ our $VERSION = '1.04';
}
}
- sub _run_full_round {
+sub _run_full_round {
my $c = shift;
- my $sub = shift;
+ my $cmd = shift;
$c->debug('calling pre_process function...');
$c->{'_functions'}->{'pre_process'}->($c);
$c->debug('executing command...');
- $c->{'output'} = $sub->($c);
+ $c->{'output'} = $cmd->run($c, @_);
$c->debug('calling post_process function...');
$c->{'_functions'}->{'post_process'}->($c);
$c->debug('reseting output');
$c->{'output'} = undef;
- }
+}
- #========================#
- # PUBLIC METHODS #
- #========================#
+#========================#
+# PUBLIC METHODS #
+#========================#
- sub load_config {
+sub load_config {
require App::Rad::Config;
App::Rad::Config::load_config(@_);
- }
+}
+
+#TODO save_config
- sub path {
+sub path {
require FindBin;
return $FindBin::Bin;
- }
+}
- sub real_path {
+sub real_path {
require FindBin;
return $FindBin::RealBin;
- }
+}
- # - "Wow! you guys rock!" (zoso on Rad)
- #TODO: this code probably could use some optimization
- sub register_commands {
+# - "Wow! you guys rock!" (zoso on Rad)
+#TODO: this code probably could use some optimization
+sub register_commands {
my $c = shift;
my %help_for_sub = ();
my %rules = ();
@@ -352,34 +519,31 @@ our $VERSION = '1.04';
# if we receive a hash ref, it could be commands or
# rules for fetching commands.
if ( ref($item) ) {
- Carp::croak
- '"register_commands" may receive only HASH references'
- unless ref $item eq 'HASH';
-
- foreach my $params ( keys %{$item} ) {
- Carp::croak
-'registered elements may only receive strings or hash references'
- if ref $item->{$params}
- and ref $item->{$params} ne 'HASH';
-
- # we got a rule - push it in.
- if ( $params eq '-ignore_prefix'
- or $params eq '-ignore_suffix'
- or $params eq '-ignore_regexp' )
- {
- $rules{$params} = $item->{$params};
- }
-
- # not a rule, so it's either a command with
- # help text or a command with an argument list.
- # either way, we push it to our 'help' hash.
- else {
- $help_for_sub{$params} = $item->{$params};
- }
- }
+ Carp::croak '"register_commands" may receive only HASH references'
+ unless ref $item eq 'HASH';
+
+ foreach my $params ( keys %{$item} ) {
+ Carp::croak 'registered elements may only receive strings or hash references'
+ if ref $item->{$params} and ref $item->{$params} ne 'HASH';
+
+ # we got a rule - push it in.
+ if ( $params eq '-ignore_prefix'
+ or $params eq '-ignore_suffix'
+ or $params eq '-ignore_regexp'
+ ) {
+ $rules{$params} = $item->{$params};
+ }
+
+ # not a rule, so it's either a command with
+ # help text or a command with an argument list.
+ # either way, we push it to our 'help' hash.
+ else {
+ $help_for_sub{$params} = $item->{$params};
+ }
+ }
}
else {
- $help_for_sub{$item} = undef; # no help text
+ $help_for_sub{$item} = undef; # no help text
}
}
@@ -394,77 +558,66 @@ our $VERSION = '1.04';
# list if it's *not* a control function
if ( not defined $c->{'_functions'}->{$cmd} ) {
- if ( $cmd eq '-globals' ) {
-
- # use may set it as a flag to enable global arguments
- # or elaborate on each available argument
- my %command_options = ( name => '', code => sub { } );
- if ( ref $help_for_sub{$cmd} ) {
- $command_options{args} = $help_for_sub{$cmd};
- }
- my $cmd_obj = App::Rad::Command->new( \%command_options );
- $c->{'_globals'} = $cmd_obj;
-
- # $c->register(undef, undef, $help_for_sub{$cmd});
- }
-
- # user wants to register a valid (existant) sub
- elsif ( exists $subs{$cmd} ) {
- $c->register( $cmd, $subs{$cmd}, $help_for_sub{$cmd} );
- }
- else {
- Carp::croak
-"'$cmd' does not appear to be a valid sub. Registering seems impossible.\n";
- }
+ if ( $cmd eq '-globals' ) {
+ # use may set it as a flag to enable global arguments
+ # or elaborate on each available argument
+ #my %command_options = ( name => '', code => sub { } );
+ #if ( ref $help_for_sub{$cmd} ) {
+ # $command_options{opts} = $help_for_sub{$cmd};
+ #}
+ #my $cmd_obj = App::Rad::Command->new( \%command_options );
+ #$c->{'_globals'} = $cmd_obj;
+ # globals is a command named ''
+ $c->register( '', sub {} );
+ # TODO: help showing 'Global options:'
+
+ # $c->register(undef, undef, $help_for_sub{$cmd});
+ }
+
+ # user wants to register a valid (existant) sub
+ elsif ( exists $subs{$cmd} ) {
+ $c->register( $cmd, $subs{$cmd}, $help_for_sub{$cmd} );
+ }
+ else {
+ Carp::croak "'$cmd' does not appear to be a valid sub. Registering seems impossible.\n";
+ }
}
}
# no parameters, or params+rules: try to register everything
if ( ( !%help_for_sub ) or %rules ) {
foreach my $subname ( keys %subs ) {
-
- # we only add the sub to the commands
- # list if it's *not* a control function
- if ( not defined $c->{'_functions'}->{$subname} ) {
-
- if ( $rules{'-ignore_prefix'} ) {
- next
- if (
- substr(
- $subname, 0,
- length( $rules{'-ignore_prefix'} )
- ) eq $rules{'-ignore_prefix'}
- );
- }
- if ( $rules{'-ignore_suffix'} ) {
- next
- if (
- substr(
- $subname,
- length($subname) -
- length( $rules{'-ignore_suffix'} ),
- length( $rules{'-ignore_suffix'} )
- ) eq $rules{'-ignore_suffix'}
- );
- }
- if ( $rules{'-ignore_regexp'} ) {
- my $re = $rules{'-ignore_regexp'};
- next if $subname =~ m/$re/o;
- }
-
- # avoid duplicate registration
- if ( !exists $help_for_sub{$subname} ) {
- $c->register( $subname, $subs{$subname} );
- }
- }
+ # we only add the sub to the commands
+ # list if it's *not* a control function
+ if ( not defined $c->{'_functions'}->{$subname} ) {
+ if ( $rules{'-ignore_prefix'} ) {
+ next if substr( $subname, 0, length( $rules{'-ignore_prefix'} ) )
+ eq $rules{'-ignore_prefix'};
+ }
+ if ( $rules{'-ignore_suffix'} ) {
+ next if substr( $subname,
+ length($subname) - length( $rules{'-ignore_suffix'} ),
+ length( $rules{'-ignore_suffix'} )
+ ) eq $rules{'-ignore_suffix'};
+ }
+ if ( $rules{'-ignore_regexp'} ) {
+ my $re = $rules{'-ignore_regexp'};
+ next if $subname =~ m/$re/o;
+ }
+
+ # avoid duplicate registration
+ if ( !exists $help_for_sub{$subname} ) {
+ $c->register( $subname, $subs{$subname} );
+ }
+ }
}
}
- }
+}
- sub register_command { return register(@_) }
+sub register_command { return register(@_) }
- sub register {
- my ( $c, $command_name, $coderef, $extra ) = @_;
+sub register {
+ my ( $c, $command_name, $coderef, $extra ) = @_;
# short circuit
return unless ref $coderef eq 'CODE';
@@ -478,10 +631,10 @@ our $VERSION = '1.04';
# or an argument hashref
if ($extra) {
if ( ref $extra ) {
- $command_options{args} = $extra;
+ $command_options{opts} = $extra;
}
else {
- $command_options{help} = $extra;
+ $command_options{help} = $extra;
}
}
@@ -493,11 +646,11 @@ our $VERSION = '1.04';
$c->{'_commands'}->{$command_name} = $cmd_obj;
return $command_name;
- }
+}
- sub unregister_command { return unregister(@_) }
+sub unregister_command { return unregister(@_) }
- sub unregister {
+sub unregister {
my ( $c, $command_name ) = @_;
if ( $c->{'_commands'}->{$command_name} ) {
@@ -506,43 +659,45 @@ our $VERSION = '1.04';
else {
return undef;
}
- }
+}
- sub create_command_name {
+#TODO: move this to the 'include' plugin
+sub create_command_name {
my $id = 0;
foreach ( commands() ) {
if (m/^cmd(\d+)$/) {
- $id = $1 if ( $1 > $id );
+ $id = $1 if ( $1 > $id );
}
}
return 'cmd' . ( $id + 1 );
- }
+}
- sub commands {
- return ( keys %{ $_[0]->{'_commands'} } );
- }
+sub commands {
+ return ( grep { $_ ne '' } keys %{ $_[0]->{'_commands'} } );
+}
- sub is_command {
+sub is_command {
my ( $c, $cmd ) = @_;
+ return 0 unless defined $cmd and $cmd ne '';
return (
defined $c->{'_commands'}->{$cmd}
? 1
: 0
);
- }
-
- sub command : lvalue {
+}
+use diagnostics;
+sub command : lvalue {
cmd(@_);
- }
+}
- sub cmd : lvalue {
+sub cmd : lvalue {
$_[0]->{'cmd'};
- }
+}
- # - "I'm loving having something else write up the 80% drudge
- # code for the small things." (benh on Rad)
- sub run {
- my $class = shift;
+# - "I'm loving having something else write up the 80% drudge
+# code for the small things." (benh on Rad)
+sub run {
+ my $class = shift;
my $c = {};
bless $c, $class;
@@ -558,45 +713,40 @@ our $VERSION = '1.04';
# now we get the actual input from
# the command line (someone using the app!)
- my $cmd = $c->parse_input();
-
- if ( not defined $cmd ) {
- $c->debug( "'"
- . $c->cmd
- . "' is not a valid command. Falling to invalid." );
- $cmd = $c->{'_functions'}->{'invalid'};
+# my $cmd_name = $c->parse_input();
+ my $arg = $c->parse_input();
+ my $cmd_obj = $c->{'_commands'}->{$c->cmd};
+
+ # handle special cases (default and invalid)
+ if ( defined $arg ) {
+ $c->debug( "'$arg' is not a valid command. Falling to invalid." );
+ $cmd_obj->{code} = $c->{'_functions'}->{'invalid'};
}
- elsif ( $cmd eq '' ) {
+ elsif ( $c->cmd eq '' ) {
$c->debug('no command detected. Falling to default');
- $cmd = $c->{'_functions'}->{'default'};
- }
- else {
- my $obj = $c->{'_commands'}->{$cmd};
-
- # set default values for command (if available)
- $obj->_set_default_values( $c->options, $c->stash );
-
- $cmd = sub { $obj->run(@_) }
+ $cmd_obj->{code} = $c->{'_functions'}->{'default'};
}
+
+# $cmd = sub { $obj->run(@_) }
# run the specified command
- $c->_run_full_round($cmd);
+ $c->_run_full_round($cmd_obj, $arg);
# that's it. Tear down everything and go home :)
$c->{'_functions'}->{'teardown'}->($c);
return 0;
- }
+}
- # run operations
- # in a shell-like environment
- sub shell {
+# run operations
+# in a shell-like environment
+sub shell {
my $class = shift;
require App::Rad::Shell;
App::Rad::Shell::shell($class);
- }
+}
- sub execute {
+sub execute {
my ( $c, $cmd ) = @_;
# given command has precedence
@@ -614,28 +764,28 @@ our $VERSION = '1.04';
# set default values for command (if available)
$cmd_obj->_set_default_values( $c->options, $c->stash );
- $c->_run_full_round( sub { $cmd_obj->run(@_) } );
+ $c->_run_full_round( $cmd_obj, @_ );
return $cmd;
}
else {
-
# if not a command, return undef
return;
}
- }
+}
- sub argv { return $_[0]->{'_ARGV'} }
- sub options { return $_[0]->{'_options'} }
- sub stash { return $_[0]->{'_stash'} }
- sub config { return $_[0]->{'_config'} }
+sub argv { return $_[0]->{'_ARGV'} }
+#sub options { return $_[0]->{'_options'} }
+sub options { return $_[0]->{'_commands'}->{ $_[0]->{'cmd'} }->options }
+sub stash { return $_[0]->{'_stash'} }
+sub config { return $_[0]->{'_config'} }
- # $c->plugins is sort of "read-only" externally
- sub plugins {
+# $c->plugins is sort of "read-only" externally
+sub plugins {
my @plugins = @{ $_[0]->{'_plugins'} };
return @plugins;
- }
+}
- sub getopt {
+sub getopt {
require Getopt::Long;
Carp::croak "Getopt::Long needs to be version 2.36 or above"
unless $Getopt::Long::VERSION >= 2.36;
@@ -644,6 +794,7 @@ our $VERSION = '1.04';
# reset values from tinygetopt
#$c->{'_options'} = {};
+ #TODO: how the new parser copes with this?
%{ $c->options } = ();
my $parser = new Getopt::Long::Parser;
@@ -661,11 +812,11 @@ our $VERSION = '1.04';
if ( shift->{'debug'} ) {
print "[debug] @_\n";
}
- }
+}
- # gets/sets the output (returned value)
- # of a command, to be post processed
- sub output {
+# gets/sets the output (returned value)
+# of a command, to be post processed
+sub output {
my ( $c, @msg ) = @_;
if (@msg) {
$c->{'output'} = join( ' ', @msg );
@@ -673,35 +824,35 @@ our $VERSION = '1.04';
else {
return $c->{'output'};
}
- }
+}
- #=========================#
- # CONTROL FUNCTIONS #
- #=========================#
+#=========================#
+# CONTROL FUNCTIONS #
+#=========================#
- sub setup { $_[0]->register_commands( { -ignore_prefix => '_' } ) }
+sub setup { $_[0]->register_commands( { -ignore_prefix => '_' } ) }
- sub teardown { }
+sub teardown {}
- sub pre_process { }
+sub pre_process {}
- sub post_process {
+sub post_process {
my $c = shift;
if ( $c->output() ) {
print $c->output() . $/;
}
- }
+}
- sub default {
+sub default {
my $c = shift;
return $c->{'_commands'}->{'help'}->run($c);
- }
+}
- sub invalid {
+sub invalid {
my $c = shift;
return $c->{'_functions'}->{'default'}->($c);
- }
+}
}
42; # ...and thus ends thy module ;)
View
213 lib/App/Rad/Command.pm
@@ -21,6 +21,7 @@ sub new {
my $self = {
name => ($options->{name} || '' ),
code => ($options->{code} || sub {} ),
+ options => {},
};
bless $self, $class;
@@ -34,8 +35,8 @@ sub new {
$self->{help} = App::Rad::Help->get_help_attr_for($self->{name});
}
- $self->set_arguments($options->{args})
- if $options->{args};
+ $self->set_options($options->{opts})
+ if $options->{opts};
return $self;
}
@@ -43,21 +44,23 @@ sub new {
# - "I gotta get a job that pays me to do this -- it's just too much fun"
# (SmokeMachine on Rad)
-sub set_arguments {
- my ($self, $arguments) = (@_);
- return unless ref $arguments;
+sub set_options {
+ my ($self, $options) = (@_);
+ return unless ref $options;
- foreach my $arg (keys %{ $arguments }) {
- $self->set_arg($arg, $arguments->{$arg});
+ foreach my $opt (keys %{ $options }) {
+ $self->set_opt($opt, $options->{$opt});
}
}
-sub set_arg {
- my ($self, $arg, $options) = (@_);
+
+# TODO: rename this
+sub set_opt {
+ my ($self, $opt, $options) = (@_);
my $opt_type = ref $options;
if ($opt_type) {
- Carp::croak "arguments can only receive HASH references"
+ Carp::croak "options can only receive HASH references"
unless $opt_type eq 'HASH';
my %accepted = (
@@ -70,15 +73,16 @@ sub set_arg {
default => 1,
error_msg => 1,
conflicts_with => 1,
+ arguments => 1,
);
foreach my $value (keys %{$options}) {
- Carp::croak "unknown attribute '$value' for argument '$arg'\n"
+ Carp::croak "unknown attribute '$value' for option '$opt'\n"
unless $accepted{$value};
# stupid error checking
my $opt_ref = ref $options->{$value};
if ($value eq 'type') {
- Carp::croak "Invalid type (should be 'num', 'str' or 'any')\n"
+ Carp::croak "Invalid type (should be 'num' or 'str')\n"
unless $opt_ref or $TYPES{ lc $options->{$value} };
}
elsif ($value eq 'condition' and (!$opt_ref or $opt_ref ne 'CODE')) {
@@ -115,28 +119,130 @@ sub set_arg {
elsif ($value eq 'conflicts_with' and ($opt_ref and $opt_ref ne 'ARRAY')) {
Carp::croak "'conflicts_with' attribute must be a scalar or an ARRAY ref\n";
}
- $self->{args}->{$arg}->{$value} = $options->{$value};
+ $self->{opts}->{$opt}->{$value} = $options->{$value};
}
}
- # got a string. Set it as the help for the argument
+ # got a string. Set it as the help for the option
else {
- $self->{args}->{$arg}->{help} = $options;
+ $self->{opts}->{$opt}->{help} = $options;
}
}
+sub options {
+ return $_[0]->{'options'};
+}
+
+# this function is here to replace _parser_opt
+# we should find a better name for it, but...later.
+
+# it returns the number of arguments left
+sub setopt {
+ my ($self, $opt_name, $opt_val) = (@_);
+ my $arguments_left = 0;
+
+ # if the app has custom options for that command,
+ # we check them now. Otherwise, just accept it.
+ if ( keys ( %{$self->{opts}} ) > 0 ) {
+ my $actual_opt_name = $self->_get_option_name($opt_name)
+ || die "invalid option '$opt_name'\n";
+
+ $opt_name = $actual_opt_name;
+ my $opt = $self->{opts}->{$opt_name};
+
+ # if no value was given to the option, here's what we do:
+ if ( not defined $opt_val ) {
+ # first, if we have a default value to use, use it.
+ if (defined $opt->{default} ) {
+ $opt_val = $opt->{default}
+ }
+ # if a required number of arguments was set
+ # for the option, we will not use the auto-increment
+ elsif ( defined $opt->{arguments} ) {
+ return $opt->{arguments};
+ }
+ # otherwise, do an auto-increment
+ else {
+ # TODO: on the test below, do a looks_like_number ?
+ $opt_val = defined $self->{options}->{$opt_name}
+ ? $self->{options}->{$opt_name} + 1
+ : 1
+ ;
+ }
+ }
+
+ # type check (TODO: it would be nice if we allowed pluggable types)
+ if ( $opt->{type} and not $TYPES{$opt->{type}}->($opt_val) ) {
+ die "option '$opt_name' requires a value of type '" . $opt->{type} . "'\n";
+ }
+
+ # condition check
+ if ( $opt->{condition} and not $opt->{condition}->($opt_val) ) {
+ die "incorrect value for option '$opt_name'" .
+ (defined $opt->{error_msg} ? ": " . $opt->{error_msg} : '')
+ . "\n";
+ }
+
+ #TODO: conflict check?
+
+ #TODO: arguments left check
+ }
+ else {
+ # no custom options, so we just make sure
+ # there is a value to set.
+ if (not defined $opt_val) {
+ $opt_val = defined $self->{options}->{$opt_name}
+ ? $self->{options}->{$opt_name} + 1
+ : 1
+ ;
+ }
+ }
+ $self->options->{$opt_name} = $opt_val;
+ return $arguments_left;
+}
+
+# returns option name, or undef if it's not found
+sub _get_option_name {
+ my ($self, $opt) = (@_);
+
+ return $opt if exists $self->{opts}->{$opt};
+
+ALIAS_CHECK: # try to find whether we were given an alias instead
+ foreach my $valid_opt (keys %{$self->{opts}}) {
+
+ # get aliases list
+ my $aliases = $self->{opts}->{$valid_opt}->{aliases};
+ $aliases = [$aliases] unless ref $aliases;
+
+ # get token if it's inside alias list,
+ foreach my $alias ( @{$aliases} ) {
+ return $valid_opt if $alias and $opt eq $alias;
+ }
+ }
+ return;
+}
+
+sub is_option {
+ my ($self, $opt) = (@_);
+
+ # if there are no registered options, everything can be an option
+ return 1 unless scalar keys %{$self->{opts}};
+
+ return (exists $self->{opts}->{$opt}) ? 1 : 0;
+}
+
sub _set_default_values {
my ($self, $options_ref, $stash_ref) = (@_);
- foreach my $arg ( keys %{$self->{args}} ) {
- if (my $default = $self->{args}->{$arg}->{default}) {
+ foreach my $opt ( keys %{$self->{opts}} ) {
+ if (my $default = $self->{opts}->{$opt}->{default}) {
- unless (defined $options_ref->{$arg}) {
- $options_ref->{$arg} = $default;
+ unless (defined $options_ref->{$opt}) {
+ $options_ref->{$opt} = $default;
- # if the argument has a to_stash value or hashref,
+ # if the option has a to_stash value or hashref,
# we fill the stash.
- if (my $stashed = $self->{args}->{$arg}->{to_stash}) {
- push my @keys, ref $stashed ? @{$stashed} : $arg;
+ if (my $stashed = $self->{opts}->{$opt}->{to_stash}) {
+ push my @keys, ref $stashed ? @{$stashed} : $opt;
foreach (@keys) {
$stash_ref->{$_} = $default;
}
@@ -147,69 +253,69 @@ sub _set_default_values {
}
-# _parse_arg should return the options' name
+# _parse_opt should return the options' name
# and its "to_stash" values
# code here should probably be separated in different subs
# for better segregation and testing
-sub _parse_arg {
+sub _parse_opt {
my ($self, $token, $val, $c) = (@_);
# short circuit
return ($token, undef)
- unless defined $self->{args};
+ unless defined $self->{opts};
- # first we see if it's a valid arg
- my $arg_ref = undef;
- my $arg_real_name = $token;
- if (defined $self->{args}->{$token}) {
- $arg_ref = $self->{args}->{$token};
+ # first we see if it's a valid opt
+ my $opt_ref = undef;
+ my $opt_real_name = $token;
+ if (defined $self->{opts}->{$token}) {
+ $opt_ref = $self->{opts}->{$token};
}
else {
ALIAS_CHECK: # try to find if user given an alias instead
- foreach my $valid_arg (keys %{$self->{args}}) {
+ foreach my $valid_opt (keys %{$self->{opts}}) {
# get aliases list
- my $aliases = $self->{args}->{$valid_arg}->{aliases};
+ my $aliases = $self->{opts}->{$valid_opt}->{aliases};
$aliases = [$aliases] unless ref $aliases;
foreach my $alias (@{$aliases}) {
# get token if it's inside alias list,
if ($alias and $token eq $alias) {
- $arg_ref = $self->{args}->{$valid_arg};
- $arg_real_name = $valid_arg;
+ $opt_ref = $self->{opts}->{$valid_opt};
+ $opt_real_name = $valid_opt;
last ALIAS_CHECK;
}
}
}
}
- return (undef, "argument '$token' not accepted by command '" . $self->{name} . "'\n")
- unless keys %{$arg_ref}; # al newkirk: changed from defined $arg_ref
+ return (undef, "option '$token' not accepted by command '" . $self->{name} . "'\n")
+ unless keys %{$opt_ref}; # al newkirk: changed from defined $opt_ref
- # now that we have the argument name,
+ # now that we have the option name,
# we need to validate it.
- if (defined $arg_ref->{type} ) {
+ if (defined $opt_ref->{type} ) {
# al newkirk: when defaulting to a value of one, the type
# if exists, must be changed to "num" to avoid attempting to validate "1"
# as "any" or "str" and failing.
# ! Note: This changes the value for the duration of the request.
- $arg_ref->{type} = "num" if $val eq "1";
+ $opt_ref->{type} = "num" if $val eq "1";
- if (not defined $val or not $TYPES{$arg_ref->{type}}->($val)) {
- return (undef, "argument '$token' expects a (" . $arg_ref->{type} . ") value\n");
+ if (not defined $val or not $TYPES{$opt_ref->{type}}->($val)) {
+ return (undef, "option '$token' expects a (" . $opt_ref->{type} . ") value\n");
}
}
- # al newkirk: arg option to_stash support
+ # al newkirk: opt option to_stash support
# current to_stash values must be in arrayref format [...]
- if ( defined $self->{args}->{$arg_real_name}->{to_stash} ) {
- if ( ref $self->{args}->{$arg_real_name}->{to_stash} eq "ARRAY" ) {
- foreach my $var ( @{ $self->{args}->{$arg_real_name}->{to_stash} } ) {
+ if ( defined $self->{opts}->{$opt_real_name}->{to_stash} ) {
+ if ( ref $self->{opts}->{$opt_real_name}->{to_stash} eq "ARRAY" ) {
+ foreach my $var ( @{ $self->{opts}->{$opt_real_name}->{to_stash} } ) {
$c->stash->{$var} = $val;
}
}
- elsif ( $self->{args}->{$arg_real_name}->{to_stash} ne "" ) {
- $c->stash->{$self->{args}->{$arg_real_name}->{to_stash}} = $val;
+ elsif ( $self->{opts}->{$opt_real_name}->{to_stash} ne "" ) {
+ $c->stash->{$self->{opts}->{$opt_real_name}->{to_stash}} = $val;
}
else {
die
@@ -217,8 +323,8 @@ ALIAS_CHECK: # try to find if user given an alias instead
}
}
- # return argument and stash list ref
- return ($arg_real_name, undef);
+ # return option and stash list ref
+ return ($opt_real_name, undef);
}
@@ -235,7 +341,7 @@ sub run {
#TODO: a.k.a. long help - called with ./myapp help command
#sub description {
# my $self = shift;
-# return help . argument_help # or something like that
+# return help . option_help # or something like that
#}
42;
@@ -255,7 +361,7 @@ You can register a command in App::Rad in three diferent ways:
$c->register('foo', \&bar, 'this is the help for command foo');
-=head2 Extended arguments registering
+=head2 Extended options registering
$c->register(
'foo' => {
@@ -265,9 +371,8 @@ You can register a command in App::Rad in three diferent ways:
aliases => [ 'len', 'l' ],
to_stash => 'mylength',
required => 1,
- help => 'help for the length attribute',
+ help => 'help for the --length option',
}
}
)
-
-
+
View
2  lib/App/Rad/FAQ.pod
@@ -67,4 +67,4 @@ The "help" command is registered by Rad automatically. To disable it, just unreg
$c->register_commands();
}
-
+=head2 How do I explicitly Rad's internal "help" command?
View
4 lib/App/Rad/Plugin/Abbrev.pm
@@ -16,7 +16,7 @@ sub execute {
$cmd = $cmds[0];
}
}
- return $c->SUPER::execute($cmd);
+ return $c->_execute($cmd);
}
sub get_commands_like {
@@ -25,7 +25,7 @@ sub get_commands_like {
my @cmds = ();
my $len = length($cmd);
- foreach (@{$c->commands}) {
+ foreach ($c->commands) {
push (@cmds, $_) if substr ($_, 0, $len) eq $cmd;
}
return @cmds;
View
21 t/02-defaultprogram-new.t
@@ -1,21 +0,0 @@
-use Test::More tests => 2;
-use App::Rad::Tester;
-
-my ($out, $filename) = test_app(\*DATA);
-
-my $helptext = <<"EOHELP";
-Usage: $filename command [arguments]
-
-Available Commands:
- help\tshow syntax and available commands
-
-EOHELP
-
-is($out, $helptext);
-
-$out = test_app($filename, 'help');
-is($out, $helptext);
-
-__DATA__
-use App::Rad;
-App::Rad->run();
View
30 t/02-defaultprogram.t
@@ -1,21 +1,7 @@
use Test::More tests => 2;
+use App::Rad::Tester;
-SKIP: {
- eval "use File::Temp qw{ tempfile tempdir }";
- skip "File::Temp not installed", 2 if $@;
-
- my ($fh, $filename) = tempfile(UNLINK => 1);
- diag("using temporary program file '$filename' to test functionality");
-
- my $contents = <<"EOT";
-use App::Rad;
-App::Rad->run();
-EOT
-
- print $fh $contents;
- close $fh;
-
- my $ret = `$^X $filename`;
+my ($out, $filename) = test_app(\*DATA);
my $helptext = <<"EOHELP";
Usage: $filename command [arguments]
@@ -25,9 +11,11 @@ Available Commands:
EOHELP
- is($ret, $helptext);
+is($out, $helptext);
+
+$out = test_app($filename, 'help');
+is($out, $helptext);
- $ret = '';
- $ret = `$^X $filename help`;
- is($ret, $helptext);
-}
+__DATA__
+use App::Rad;
+App::Rad->run();
View
2  t/03-default_override.t
@@ -20,9 +20,9 @@ EOT
close $fh;
my $ret = `$^X $filename`;
-
is($ret, "this is an override of the default command\n");
+ $ret = '';
$ret = `$^X $filename unknown`;
is($ret, "this is an override of the default command\n");
View
7 t/03.5-default_and_invalid.t
@@ -22,9 +22,10 @@ sub default {
}
}
+# TODO: let 'invalid' receive the invalid command name
sub invalid {
my $c = shift;
- return 'sorry, but "' . $c->cmd . '" does not exist.';
+ return 'invalid command';
}
EOT
@@ -38,10 +39,10 @@ EOT
is($ret, "keys: 1\n", 'no command, with parameters (should fall to default)');
$ret = `$^X $filename test`;
- is($ret, "sorry, but \"test\" does not exist.\n", 'invalid command (should fall to invalid)');
+ is($ret, "invalid command\n", 'invalid command (should fall to invalid)');
$ret = `$^X $filename test --something`;
- is($ret, "sorry, but \"test\" does not exist.\n", 'invalid command, with parameters (should fall to invalid)');
+ is($ret, "invalid command\n", 'invalid command, with parameters (should fall to invalid)');
View
43 t/07-argv_and_opt.t
@@ -1,22 +1,59 @@
-use Test::More tests => 18;
+use Test::More tests => 36;
use App::Rad::Tester;
+# kids, don't try this at home...
@ARGV = qw(commandname bla -x -abc --def --test1=0 --test2=test ble -vvv -x);
-
my $c = get_controller;
+$c->parse_input();
+
+is(scalar @ARGV, 10, '@ARGV should have all 10 elements when Rad finds an invalid command');
+is(scalar @{$c->argv}, 2, '$c->argv should have 2 arguments');
+is(keys %{$c->options}, 8, '$c->options should have 8 elements');
+
+is($c->cmd, '', 'command name should NOT be set for unknown command');
+
+is_deeply(\@ARGV, [qw(commandname bla -x -abc --def --test1=0 --test2=test ble -vvv -x)],
+ '@ARGV should have all passed arguments for an unknown command'
+ );
+
+is_deeply($c->argv, ['bla', 'ble'], '$c->argv arguments should be consistent');
+is($c->options->{'a'}, 1, "'-a' should be set");
+is($c->options->{'b'}, 1, "'-b' should be set");
+is($c->options->{'c'}, 1, "'-c' should be set");
+
+ok(!defined $c->options->{'abc'}, "'--abc' should *not* be set");
+ok(!defined $c->options->{'d'} , "'-d' should *not* be set");
+ok(!defined $c->options->{'e'} , "'-e' should *not* be set");
+ok(!defined $c->options->{'f'} , "'-f' should *not* be set");
+
+ok(defined $c->options->{'def'}, "'--def' should be set");
+is($c->options->{'test1'}, 0, "'--test1' should be set to '0'");
+is($c->options->{'test2'}, 'test', "'--test2' should be set to 'test'");
+is($c->options->{'v'}, 3, "single arguments can be incremented when put together");
+is($c->options->{'x'}, 2, "single arguments can be incremented when invoked separately");
+
+
+### rerun tests, this time with the simplest 'commandname' command
# kids, don't try this at home...
+@ARGV = qw(commandname bla -x -abc --def --test1=0 --test2=test ble -vvv -x);
+$c = get_controller;
+$c->register(commandname, sub {});
$c->parse_input();
-is(scalar @ARGV, 9, '@ARGV should have 9 elements');
is(scalar @{$c->argv}, 2, '$c->argv should have 2 arguments');
is(keys %{$c->options}, 8, '$c->options should have 8 elements');
is($c->cmd, 'commandname', 'command name should be set');
+TODO: {
+ local $TODO = 'handle @ARGV on a per-command basis';
+
+is(scalar @ARGV, 9, '@ARGV should have 9 elements');
is_deeply(\@ARGV, ['bla', '-x', '-abc', '--def', '--test1=0', '--test2=test', 'ble', '-vvv', '-x'],
'@ARGV should have just the passed arguments, not the command name'
);
+}
is_deeply($c->argv, ['bla', 'ble'], '$c->argv arguments should be consistent');
is($c->options->{'a'}, 1, "'-a' should be set");
View
2  t/08-getopt_long.t
@@ -3,12 +3,14 @@ use Test::More tests => 17;
SKIP: {
eval "use Getopt::Long 2.36";
skip "Getopt::Long 2.36 or higher not installed", 17, if $@;
+ skip '@ARGV handling needs to be fixed', 17;
use App::Rad::Tester;
@ARGV = qw(herculoids --igoo=ape -t 4 --zok=3.14 --glup -abc);
my $c = get_controller;
+ $c->register('herculoids', sub {});
# kids, don't try this at home...
$c->parse_input();
View
270 t/21-named_arguments.t
@@ -1,123 +1,221 @@
-use Test::More tests => 17;
+use Test::More;# tests => 17;
use App::Rad::Tester;
sub foo { }
-my $c = get_controller;
-
-$c->register(
- 'cmd1',
- \&foo,
- {
- 'arg1' => {
- type => 'num',
- condition => sub { $_ < 42 },
- error_msg => 'number must be below 42',
- aliases => [ 'a1', 'a3' ],
- to_stash => ['somearg'],
- help => 'help for --arg1',
- },
- 'arg2' => {
- conflicts_with => 'arg1',
- aliases => 'a2',
- type => 'str'
-
- #arguments => 2,
- },
- 'arg3' => {
- default => 42,
- to_stash => [ 'one', 'two' ],
- },
- 'arg4' => {
- required => 1,
- type => 'str',
- },
- 'arg5' => 'standard argument with help',
- 'arg6' => { to_stash => 'one' },
- 'arg7' => { type => 'num' },
- -help => 'help for cmd2',
- }
-);
-
-
-# Testing incorrect arguments --------------------------------------------------------
-# Lack of required argument
+
+sub new_app {
+ my $c = get_controller;
+
+ $c->register(
+ 'cmd1',
+ \&foo,
+ {
+ 'opt1' => {
+ type => 'num',
+ condition => sub { $_[0] < 42 },
+ error_msg => 'number must be below 42',
+ aliases => [ 'a1', 'a3' ],
+ to_stash => ['someopt'],
+ help => 'help for --opt1',
+ },
+ 'opt2' => {
+ conflicts_with => 'opt1',
+ aliases => 'a2',
+ type => 'str'
+
+ #arguments => 2,
+ },
+ 'opt3' => {
+ default => 42,
+ to_stash => [ 'one', 'two' ],
+ },
+ 'opt4' => {
+ required => 1,
+ type => 'str',
+ arguments => 1,
+ },
+ 'opt5' => 'standard option with help',
+ 'opt6' => { to_stash => 'one' },
+ 'opt7' => { type => 'num' },
+ -help => 'help for command 1',
+ }
+ );
+# use Data::Dumper;
+# diag (Dumper($c));
+ return $c;
+}
+my $c;
+
+#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+# Testing incorrect options #
+#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+
+
+# Lack of required option
+##############################################
+$c = new_app(); # reset context for re-parse
@ARGV = qw( cmd1 );
eval { $c->parse_input; };
-is ($@, "Error: command 'cmd1' needs argument 'arg4'\n");
+is ($@, "option 'opt4' is required for command cmd1 at t/21-named_arguments.t line 58\n");
+
-# Lack of value in required argument
-@ARGV = qw( cmd1 --arg4 );
+# Lack of explicit argument in required option
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4 );
eval { $c->parse_input };
-is ($@, "Error: argument 'arg4' requires a value of type 'str'\n");
+is ($@, "missing 1 argument(s) for option 'opt4' at t/21-named_arguments.t line 66\n");
-# wrong type in argument arg7
-@ARGV = qw( cmd1 --arg2=42 --arg7=foo);
+
+# wrong type in option opt7
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=42 --opt7=foo);
eval { $c->parse_input };
-is( $@, "Error: argument 'arg7' requires a value of type 'str'\n" );
+is( $@, "option 'opt7' requires a value of type 'num'\n" );
+
# Condition returned false
-@ARGV = qw( cmd1 --arg4=somestring --arg1=43 );
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=somestring --opt1=43 );
eval { $c->parse_input };
-is ($@, "Error: incorrect value for argument 'arg1': number must be below 42\n");
+is ($@, "incorrect value for option 'opt1': number must be below 42\n");
-# Conflicting arguments
-@ARGV = qw( cmd1 --arg4=somestring --arg1=40 --arg2 );
+
+# Conflicting options
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=somestring --opt1=40 --opt2 );
eval { $c->parse_input };
-is ($@, "Error: you can't provide both 'arg1' and 'arg2'\n");
+is ($@, "options 'opt2' and 'opt1' conflict and can not be used together at t/21-named_arguments.t line 90\n");
# Condition returned false (using aliases)
-@ARGV = qw( cmd1 --arg4=somestring --a1=50 --arg2 );
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=somestring --a1=50 --opt2 );
eval { $c->parse_input };
-is ($@, "Error: incorrect value for argument 'a1': number must be below 42\n");
+is ($@, "incorrect value for option 'opt1': number must be below 42\n");
-# Conflicting arguments (using aliases)
-@ARGV = qw( cmd1 --arg4=somestring --a1=40 --arg2 );
+# Conflicting options (using aliases)
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=somestring --a1=40 --opt2 );
eval { $c->parse_input };
-is ($@, "Error: you can't provide both 'arg1' and 'arg2'\n");
+is ($@, "options 'opt2' and 'opt1' conflict and can not be used together at t/21-named_arguments.t line 104\n");
-# TODO: Conflicts with default values (how do you tell which one has been
-# passed?) --estebanm 20090830
+# test for conflicting aliases
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=somestring --a1=33 --a2=bar );
+eval { $c->parse_input };
+is ($@, "options 'opt2' and 'opt1' conflict and can not be used together at t/21-named_arguments.t line 111\n");
+
+# test invalid option
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw(cmd1 --opt4=somestring --baz);
+eval { $c->parse_input };
+is( $@, "invalid option 'baz'\n" );
-# Testing correct arguments ----------------------------------------------------------
-@ARGV = qw( cmd1 --arg2=foo );
+#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+# Testing correct options #
+#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+
+##############################################
+$c = new_app();
+@ARGV = qw( cmd1 --opt4=foo );
$c->parse_input;
-is_deeply( \@ARGV, ['--arg2=foo'], "test: mismatched parameters" );
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+
+is ($c->options->{'opt3'}, 42, 'default value for opt3 was set');
+is( $c->stash->{one}, 42, 'opt3 set stash with default value (1)' );
+is( $c->stash->{two}, 42, 'opt3 set stash with default value (2)' );
-is( $c->options->{arg2}, 'foo', "test: value mismatch (isn't 'foo')" );
-# we didn't die, so it's safe to test for arg3's default behavior
-@ARGV = qw( cmd1 --arg3 );
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 -opt4=foo --opt3 );
$c->parse_input;
-is( $c->options->{arg3}, 42, "test: proper default value" );
-is( $c->stash->{one}, 42, "test: set stash value (1)" );
-is( $c->stash->{two}, 42, "test: set stash value (2)" );
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt3}, 42, 'opt3 got proper default value' );
+is( $c->stash->{one}, 42, 'opt3 set stash value (1)' );
+is( $c->stash->{two}, 42, 'opt3 set stash value (2)' );
-@ARGV = qw( cmd1 --arg2=foo --arg3=meep );
+
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=foo --opt3=meep );
$c->parse_input;
-is( $c->options->{arg3}, 'meep', 'test: set a proper default value' );
-is( $c->stash->{one}, 'meep', 'test: override stash value(1)' );
-is( $c->stash->{two}, 'meep', 'test: override stash value(2)' );
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt3}, 'meep', 'opt3 got non-default value' );
+is( $c->stash->{one}, 'meep', 'opt3: override stash value(1)' );
+is( $c->stash->{two}, 'meep', 'opt3: override stash value(2)' );
+
-@ARGV = qw( cmd1 --arg3=foo --arg5 );
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt2=foo --opt4=foo );
$c->parse_input;
-is( $c->options->{arg5}, "", "test: another default value test" );
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt2}, 'foo', 'option opt2 was set' );
-# test for alias support and conflict support
-@ARGV = qw( cmd1 --a1=33 --a2=bar );
-eval { $c->parse_input };
-ok( $@, "test: values that conflict" );
-is( $c->options->{arg1}, 33, "test: alias value (1)" );
-is( $c->options->{arg2}, "bar", "test: alias value (2)" );
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --a2=foo --opt4=foo );
+$c->parse_input;
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt2}, 'foo', 'option opt2 set via alias' );
+is( $c->options->{a2}, undef, 'a2 is just an alias');
+
+
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=foo --opt5 );
+$c->parse_input;
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt5}, 1, 'opt5 default value test' );
+
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=foo --opt5 --opt5 --opt5);
+#TODO: should ->parse_input reset options values?
+$c->parse_input;
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt5}, 3, "opt5 default value test" );
+
+##############################################
+$c = new_app(); # reset context for re-parse
+@ARGV = qw( cmd1 --opt4=foo --opt6 );
+$c->parse_input;
+is ($c->cmd, 'cmd1', 'command was set');
+is ($c->options->{'opt4'}, 'foo', 'option opt4 was set');
+is( $c->options->{opt6}, 1, "opt6 default value test" );
+is( $c->stash->{one}, 1, "opt6 default value test" );
+
+# TODO: repeat ALL tests using different styles of @ARGV (--foo bar instead of --foo=bar, etc)
+# Note: currently, when the parser sees "--foo bar" it only tries "bar" to fill "--foo" if
+# we explicitly set the "arguments" attribute for option "foo". We can fix this with some
+# lookahead or something, assuming it's a bug
+
+#TODO: make sure you test having two conflicting AND required options
+
+# TODO: Conflicts with default values (how do you tell which one has been
+# passed?) --estebanm 20090830
+
+#TODO: test setting two aliases of the same command
-@ARGV = qw( cmd1 --arg6=99 );
-eval { $c->parse_input };
-ok( !$@, "test: invalid to_stash option" );
-@ARGV = qw(cmd1 --baz);
-eval { $c->parse_input };
-ok( $@, "test: command not accepted" );
+done_testing;
# EOF
Please sign in to comment.
Something went wrong with that request. Please try again.