PaxHeader/Getopt-ArgParse-1.0.6000755 777777 777777 00000000214 12521122003 015513 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589013 19 SCHILY.nlink=11 Getopt-ArgParse-1.0.6/000755 €`ÐЀ&‚q00000000000 12521122003 014355 5ustar00mtma000000 000000 Getopt-ArgParse-1.0.6/PaxHeader/Changes000644 777777 777777 00000000261 12521121567 017100 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561776 38 LIBARCHIVE.creationtime=1425639484 23 SCHILY.dev=16777220 23 SCHILY.ino=30457164 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/Changes000644 €`ÐЀ&‚q00000003351 12521121567 015670 0ustar00mtma000000 000000 Revision history for Getopt-ArgParse 1.0.6 2015-05-02 20:12:44 - Added new functionality to print_usage #8 - Merged the pull request from apinco@github (https://github.com/mytram/perl-argparse/pull/8 for the above change 1.0.5 2015-03-06 21:46:00 - Added new line in die to surpress developmental text (RT#102491) - Started using the terms: postional arguments vs. named arguments in replacement of "optional" arguments (RT#102497) - Updated to output argument help texts in required and optional sections for positional arguments and named arguments - Merged apinco@github for suggesting the above change - Merged rbonthond@github's pull (#5) for help text consistency improvement 1.0.4 2014-11-24 15:48:43 - Added artistic 2 license (issue#2) - Worked around what seemed to be a corrupted stack issue, which caused "Bizarre copy of HASH in list assignment at Carp" to be thrown (issue#3) - Updated error messages to be more consisten with Getopt::Long (issue#3) 1.0.3 2013-10-28 07:41:38 - Added module dependency Test::Exception in Makefile - Fixed a typo in perldoc 1.0.2 2013-10-04 14:27:23 - The same release as 1.0.2 as uploading 1.0.1 to CPAN before by mistake 1.0.1 2013-10-04 14:08:32 - Added add_arg and add_args aliases to add_argument and add_arguments, respectively, based on feedback on prepan - Fixed the unknown option error for current_command if not parsing for subcommands - Updates to conform to CPAN conventions - Perldoc improvement 1.0.0 2013-09-26 - Initial Release Getopt-ArgParse-1.0.6/PaxHeader/lib000755 777777 777777 00000000213 12521122003 016260 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589017 18 SCHILY.nlink=3 Getopt-ArgParse-1.0.6/lib/000755 €`ÐЀ&‚q00000000000 12521122003 015123 5ustar00mtma000000 000000 Getopt-ArgParse-1.0.6/PaxHeader/Makefile.PL000644 777777 777777 00000000213 12434533654 017563 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561787 23 SCHILY.dev=16777220 23 SCHILY.ino=24743945 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/Makefile.PL000644 €`ÐЀ&‚q00000001501 12434533654 016351 0ustar00mtma000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( 'ABSTRACT' => 'Parsing args with a richer and more user-friendly API', 'AUTHOR' => 'Mytram ', 'BUILD_REQUIRES' => {}, 'DISTNAME' => 'Getopt-ArgParse', 'EXE_FILES' => [], 'LICENSE' => 'artistic_2', 'NAME' => 'Getopt-ArgParse', MIN_PERL_VERSION => '5.008', 'PREREQ_PM' => { 'Moo' => '1.003', 'Getopt::Long' => '2.38', 'Test::Exception' => '0.31', }, 'VERSION_FROM' => 'lib/Getopt/ArgParse.pm', 'test' => { 'TESTS' => 't/*.t' }, META_MERGE => { resources => { repository => 'https://github.com/mytram/perl-argparse', }, }, ); WriteMakefile(%WriteMakefileArgs); Getopt-ArgParse-1.0.6/PaxHeader/MANIFEST000644 777777 777777 00000000213 12433611111 016722 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589024 18 SCHILY.nlink=1 Getopt-ArgParse-1.0.6/MANIFEST000644 €`ÐЀ&‚q00000000740 12433611111 015514 0ustar00mtma000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README.md TODO lib/Getopt/ArgParse.pm lib/Getopt/ArgParse/Parser.pm lib/Getopt/ArgParse/ActionAppend.pm lib/Getopt/ArgParse/ActionCount.pm lib/Getopt/ArgParse/ActionStore.pm lib/Getopt/ArgParse/Namespace.pm lib/Getopt/ArgParse/Parser.pm t/argparse.t t/choices.t t/default.t t/help3.t t/merge.t t/nargs.t t/perldoc.pl t/required.t t/store.t t/usage.t t/array.t t/count.t t/help2.t t/help.t t/name.t t/pair.t t/split.t t/subcommand.t Getopt-ArgParse-1.0.6/PaxHeader/META.json000644 777777 777777 00000000213 12521122003 017205 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589048 18 SCHILY.nlink=1 Getopt-ArgParse-1.0.6/META.json000644 €`ÐЀ&‚q00000002061 12521122003 015775 0ustar00mtma000000 000000 { "abstract" : "Parsing args with a richer and more user-friendly API", "author" : [ "Mytram " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.133380", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Getopt-ArgParse", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Getopt::Long" : "2.38", "Moo" : "1.003", "Test::Exception" : "0.31", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/mytram/perl-argparse" } }, "version" : "v1.0.6" } Getopt-ArgParse-1.0.6/PaxHeader/META.yml000644 777777 777777 00000000213 12521122003 017035 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589047 18 SCHILY.nlink=1 Getopt-ArgParse-1.0.6/META.yml000644 €`ÐЀ&‚q00000001151 12521122003 015624 0ustar00mtma000000 000000 --- abstract: 'Parsing args with a richer and more user-friendly API' author: - 'Mytram ' build_requires: {} configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.133380' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Getopt-ArgParse no_index: directory: - t - inc requires: Getopt::Long: 2.38 Moo: 1.003 Test::Exception: 0.31 perl: 5.008 resources: repository: https://github.com/mytram/perl-argparse version: v1.0.6 Getopt-ArgParse-1.0.6/PaxHeader/README.md000644 777777 777777 00000000213 12476304074 017066 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561776 23 SCHILY.dev=16777220 23 SCHILY.ino=30457165 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/README.md000644 €`ÐЀ&‚q00000044534 12476304074 015671 0ustar00mtma000000 000000 NAME Getopt::ArgParse - Parsing command line arguments with a richer and more user-friendly API interface, similar to python's argpare but with perlish extras. In particular, the modules provides the following features: - generating usage messages - storing parsed arg values in an object, which can be also used to load configuration values from files and therefore the ability for applications to combine configurations in a single interface - A more user-friendly interface to specify arguments, such as argument types, argument values split, etc. - Subcommand parsing, such svn - Supporting both flag based named arguments and positional arguments VERSION version 1.0.3 SYNOPSIS use Getopt::ArgParse; $ap = Getopt::ArgParse->new_parser( prog => 'MyProgramName', description => 'This is a program', epilog => 'This appears at the bottom of usage', ); # Parse an option: '--foo value' or '-f value' $ap->add_arg('--foo', '-f', required => 1); # Parse a boolean: '--bool' or '-b' using a different name from # the option $ap->add_arg('--bool', '-b', type => 'Bool', dest => 'boo'); # Parse a positonal option. # But in this case, better using subcommand. See below $ap->add_arg('command', required => 1); # $ns is also accessible via $ap->namespace $ns = $ap->parse_args(split(' ', 'test -f 1 -b')); say $ns->command; # 'test' say $ns->foo; # false say $ns->boo; # false say $ns->no_boo; # true - 'no_' is added for boolean options # You can continue to add arguments and parse them again # $ap->namespace is accumulatively populated # Parse an Array type option and split the value into an array of values $ap->add_arg('--emails', type => 'Array', split => ','); $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org,c@perl.org')); # Because this is an array option, this also allows you to specify the # option multiple times and splitting $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org --emails c@perl.org')); # Below will print: a@perl.org|b@perl.org|c@perl.org|a@perl.org|b@perl.org|c@perl.org # Because Array types are appended say join('|', $ns->emails); # Parse an option as key,value pairs $ap->add_arg('--param', type => 'Pair', split => ','); $ns = $ap->parse_args(split(' ', '--param a=1,b=2,c=3')); say $ns->param->{a}; # 1 say $ns->param->{b}; # 2 say $ns->param->{c}; # 3 # You can use choice to restrict values $ap->add_arg('--env', choices => [ 'dev', 'prod' ],); # or use case-insensitive choices # Override the previous option with reset $ap->add_arg('--env', choices_i => [ 'dev', 'prod' ], reset => 1); # or use a coderef # Override the previous option $ap->add_args( '--env', choices => sub { die "--env invalid values" if $_[0] !~ /^(dev|prod)$/i; }, reset => 1, ); # subcommands $ap->add_subparsers(title => 'subcommands'); # Must be called to initialize subcommand parsing $list_parser = $ap->add_parser( 'list', help => 'List directory entries', description => 'A multiple paragraphs long description.', ); $list_parser->add_args( [ '--verbose', '-v', type => 'Count', help => 'Verbosity', ], [ '--depth', help => 'depth', ], ); $ns = $ap->parse_args(split(' ', 'list -v')); say $ns->current_command(); # current_command stores list, # Don't use this name for your own option $ns =$ap->parse_args(split(' ', 'help list')); # This will print the usage for the list command # help subcommand is automatically added for you say $ns->help_command(); # list # Copy parsing $common_args = Getopt::ArgParse->new_parser(); $common_args->add_args( [ '--dry-run', type => 'Bool', help => 'Dry run', ], ); $sp = $ap->add_parser( 'remove', aliases => [qw(rm)], # prog remove or prog rm parents => [ $command_args ], # prog rm --dry-run ); # Or copy explicitly $sp = $ap->add_parser( 'copy', aliases => [qw(cp)], # prog remove or prog rm ); $sp->copy_args($command_parser); # You can also copy_parsers() but in this case # $common_parser doesn't have subparsers DESCRIPTIOIN Getopt::ArgParse, Getopt::ArgParse::Parser and related classes together aim to provide user-friendly interfaces for writing command-line interfaces. A user should be able to use it without looking up the document most of the time. It allows applications to define argument specifications and it will parse them out of @AGRV by default or a command line if provided. It implements both named arguments, using Getopt::Long for parsing, and positional arguments. The class also generates help and usage messages. The parser has a namespace property, which is an object of ArgParser::Namespace. The parsed argument values are stored in this namespace property. Moreover, the values are stored accumulatively when parse_args() is called multiple times. Though inspired by Python's argparse and names and ideas are borrowed from it, there is a lot of difference from the Python one. Getopt::ArgParser::Parser This is the underlying parser that does the heavylifting. Getopt::ArgParse::Parser is a Moo class. Constructor my $parser = Getopt::ArgParse->new_parser( help => 'short description', description => 'long description', ); The former calls Getopt::ArgParser::Parser->new to create a parser object. The parser constructor accepts the following parameters. All parsers are created with a predefined Bool option --help|-h. The program can choose to reset it, though. * prog The program's name. Default $0. * help A short description of the program. * description A long description of the program. * namespace An object of Getopt::ArgParse::Namespace. An empty namespace is created if not provided. The parsed values are stored in it, and they can be refered to by their argument names as the namespace's properties, e.g. $parser->namespace->boo. See also Getopt::ArgParse::Namespace * parser_configs The Getopt::Long configurations. See also Getopt::Long * parents Parent parsents, whose argument and subparser specifications the new parser will copy. See copy() below * error_prefix Customize the message prefixed to error messages thrown by Getop::ArgParse, default to 'Getopt::ArgParse: ' * print_usage_if_help Set this to false to not display usage messages even if --help is on or the subcommand help is called. The default behavior is to display usage messages if help is set. add_arg, add_argument, add_args, and add_arguments $parser->add_args( [ '--foo', required => 1, type => 'Array', split => ',' ], [ 'boo', required => 1, nargs => '+' ], ); The object method, arg_arg or the longer version add_argument, defines the specfication of an argument. It accepts the following parameters. add_args or add_arguments() is to add multiple multiple arguments. * name or flags Either a name or a list of option strings, e.g. foo or -f, --foo. If dest is not specified, the name or the first option without leading dashes will be used as the name for retrieving values. If a name is given, this argument is a positional argument. Otherwise, it's an named argument. Hyphens can be used in names and flags, but they will be replaced with underscores '_' when used as option names. For example: $parser->add_argument( [ '--dry-run', type => 'Bool' ]); # command line: prog --dry-run $parser->namespace->dry_run; # The option's name is dry_run A name or option strings are following by named paramters. * dest The name of the attribute to be added to the namespace populated by parse_args(). * type => $type Specify the type of the argument. It can be one of the following values: * Scalar The option takes a scalar value. * Array The option takes a list of values. The option can appear multiple times in the command line. Each value is appended to the list. It's stored in an arrayref in the namespace. * Pair The option takes a list of key-value pairs separated by the equal sign '='. It's stored in a hashref in the namespace. * Bool The option does not take an argument. It's set to true if the option is present or false otherwise. A 'no_bool' option is also available, which is the negation of bool(). For example: $parser->add_argument('--dry-run', type => 'Bool'); $ns = $parser->parse_args(split(' ', '--dry-run')); print $ns->dry_run; # true print $ns->no_dry_run; # false * Count The option does not take an argument and its value will be incremented by 1 every time it appears on the command line. * split split should work with types 'Array' and 'Pair' only. split specifies a string by which to split the argument string e.g. if split => ',', a,b,c will be split into [ 'a', 'b', 'c' ].When split works with type 'Pair', the parser will split the argument string and then parse each of them as pairs. * choices or choices_i choices specifies a list of the allowable values for the argument or a subroutine that validates input values. choices_i specifies a list of the allowable values for the argument, but case insenstive, and it doesn't allow to use a subroutine for validation. Either choices or chioces_i can be present or completely omitted, but not both at the same time. * default The value produced if the argument is absent from the command line. Only one value is allowed for scalar argument types: Scalar, Count, and Bool. * required Whether or not the command-line option may be omitted (optionals only). This has no effect on types 'Bool' and 'Count'. An optional option is marked by the question mark ? in the generated usage, e.g. --help, -h ? show this help message and exit This parameter is ignored for Bool and Count types for they will already have default values. * help A brief description of what the argument does. * metavar A name for the argument in usage messages. * reset Set reset to override the existing definition of an option. This will clear the value in the namspace as well. * nargs - Positional option only This only instructs how many arguments the parser consumes. The program still needs to specify the right type to achieve the desired result. * n 1 if not specified * ? 1 or 0 * + 1 or more * * 0 or many. This will consume the rest of arguments. parse_args $namespace = $parser->parse_args(@command_line); This object method accepts a list of arguments or @ARGV if unspecified, parses them for values, and stores the values in the namespace object. A few things may be worth noting about parse_args(). First, parsing for named Arguments is done by Getopt::Long Second, parsing for positional arguments takes place after that for named arguments. It will consume what's still left in the command line. Finally, the Namespace object is accumulatively poplulated. If parse_args() is called multiple times to parse a number of command lines, the same namespace object is accumulatively populated. For Scalar and Bool options, this means the previous value will be overwrittend. For Pair and Array options, values will be appended. And for a Count option, it will add on top of the previous value. In face, the program can choose to pass a already populated namespace when creating a parser object. This is to allow the program to pre-load values to a namespace from conf files before parsing the command line. And finally, it does NOT display usage messages if the argument list is empty. This may be contrary to many other implementations of argument parsing. argv @argv = $parser->argv; # called after parse_args Call this after parse_args() is invoked to get the unconsumed arguments. It's up to the application to decide what to do if there is a surplus of arguments. The Namespace Object The parsed values are stored in a namespace object. Any class with the following three methods: * A constructor new() * set_attr(name => value) * get_attr(name) can be used as the Namespace class. The default one is Getopt::ArgParse::Namespace. It uses autoload to provide a readonly accessor method using dest names to access parsed values. However, this is not required for user-defined namespace. So within the implementation, $namespace->get_attr($dest) should always be used. Subcommand Support Note only ne level of subcommand parsing is supported. Subcommands cannot have subcommands. Call add_subparsers() first to initialize the current parser for subcommand support. A help subcommand is created as part of the initialization. The help subcommand has the following options: required positional arguments: COMMAND ? Show the usage for this command optional named arguments: --help, -h ? show this help message and exit --all, -a ? Show the full usage Call add_parser() to add a subparser for each subcommand. Use the parser object returned by add_parser() to add the options to the subcommand. Once subcommand support is on, if the first argument is not a flag, i.e. starting with a dash '-', the parser's parse_args() will treat it as a subcommand. Otherwise, the parser parses for the defined arguments. The namespace's current_command() will contain the subcommand after parsing successfully. Unlike arguments, subparsers cannot be reset. add_subparsers $parser->add_subparsers( title => 'Subcommands', description => 'description about providing subcommands', ); add_subparsers must be called to initialize subcommand support. * title A title message to mark the beginning of subcommand usage in the usage message * description A general description appearing about the title add_parser $subparser = $parser->add_parser( 'list', aliases => [qw(ls)], help => 'short description', description => 'a long one', parents => [ $common_args ], # inherit common args from # $common_args ); * $command The first argument is the name of the new command. * help A short description of the subcommand. * description A long description of the subcommand. * aliases An array reference containing a list of command aliases. * parents An array reference containing a list of parsers whose specification will be copied by the new parser. get_parser $subparser = $parser->get_parser('ls'); Return the parser for parsing the $alias command if exsist. Copying Parsers A parser can copy argument specification or subcommand specifciation for existing parsers. A use case for this is that the program wants all subcommands to have a command set of arguments. copy_args $parser->copy_args($common_args_parser); Copy argument specification from the $parent parser copy_parsers $parser->copy_parsers($common_args_parser); Copy parser specification for subcommands from the $parent parser copy $parser->copy($common_args_parser); Copy both arguments and subparsers. Usage Messages and Related Methods format_usage $usage = $parser->format_usage; Return the formated usage message for the whole program in an array reference. print_usage $parser->print_usage; Print the usage mesage returned by format_usage(). format_command_usage $usage = $parser->format_command_usage($subcommand); Return the formated usage message for the command in an array reference. print_command_usage $parser->print_command_usage($subcommand); Print the usage message returned by format_command_usage(). If $command is not given, it will first try to use $self->namespace->help_command, which will be present for the help subcommand, and then $self->namespace->current_command. SEE ALSO Getopt::Long Python's argparse AUTHOR Mytram (original author) COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) Getopt-ArgParse-1.0.6/PaxHeader/t000755 777777 777777 00000000214 12521122003 015756 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589014 19 SCHILY.nlink=20 Getopt-ArgParse-1.0.6/t/000755 €`ÐЀ&‚q00000000000 12521122003 014620 5ustar00mtma000000 000000 Getopt-ArgParse-1.0.6/PaxHeader/TODO000644 777777 777777 00000000213 12433611111 016261 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561776 23 SCHILY.dev=16777220 23 SCHILY.ino=24691222 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/TODO000644 €`ÐЀ&‚q00000000146 12433611111 015053 0ustar00mtma000000 000000 PERL-ARGPARSE -*- mode: org; fill-column: 78 -*- * TODO ** Add block configuration to namespace Getopt-ArgParse-1.0.6/t/PaxHeader/argparse.t000644 777777 777777 00000000213 12434533663 020045 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561791 23 SCHILY.dev=16777220 23 SCHILY.ino=24743959 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/argparse.t000644 €`ÐЀ&‚q00000003747 12434533663 016651 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib 'lib'; use lib '../lib'; BEGIN { use_ok ( 'Getopt::ArgParse' ) }; require_ok('Getopt::ArgParse::Parser'); require_ok('Getopt::ArgParse::ActionStore'); require_ok('Getopt::ArgParse::ActionAppend'); require_ok('Getopt::ArgParse::ActionCount'); my $ns; my $parser = Getopt::ArgParse->new_parser(); ok($parser, 'new parser'); lives_ok( sub { $parser->add_argument() } ); $parser->add_argument( '-foo', ); $parser->add_argument( '--boo', '-b', type => 'Bool', required => 1, dest => 'has_boo', ); $parser->add_argument( '--array', type => 'Array', required => 1, ); throws_ok( sub { $parser->add_argument('-a', 'b'); }, qr/Incorrect number of arguments/, 'incorrect number of arguments', ); lives_ok( sub { $ns = $parser->parse_args(split(/ /, '-foo 10 20 30 --array a --array b --array c hello world')); }, ); ok(!$ns->current_command, 'current_command is not defined'); @argv = $parser->argv; ok(scalar(@argv) == 4, 'argv has got the unconsumed argv'); ok($argv[0] == 20, 'argv[0] is 20'); $parser->namespace(undef); $ns = $parser->parse_args(split(/ /, '-foo 10 20 30 -b --array a --array b --array c')); ok($ns->foo eq '10', 'default option'); ok($ns->has_boo, 'has boo store true'); my @values = $ns->array; diag(join(',', @values)); ok( scalar(@values) eq 3, 'append array' ); # positional args $p = Getopt::ArgParse->new_parser(); $p->add_argument( 'command', ); $ns = $p->parse_args(split(/ /, 'submit hello')); ok($ns->command eq 'submit', 'simple position'); throws_ok( sub { $p->add_argument( 'command2', type => 'Array2', nargs => 2, ); }, qr/Unknown type/, 'unknown type', ); $p->add_argument( 'command2', type => 'Array', nargs => 2, ); $ns = $p->parse_args(split(/ /, 'submit hello1 hello2')); $cmd2 = $ns->command2; ok(scalar(@$cmd2) == 2, 'nargs 2'); done_testing; 1; Getopt-ArgParse-1.0.6/t/PaxHeader/array.t000644 777777 777777 00000000213 12433611111 017337 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561791 23 SCHILY.dev=16777220 23 SCHILY.ino=24691234 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/array.t000644 €`ÐЀ&‚q00000004142 12433611111 016131 0ustar00mtma000000 000000 use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); # Miminal set up $p->add_argument( '--email', '-e', type => 'Array', ); $line = '-e abc@perl.org -e xyz@perl.org'; $ns = $p->parse_args(split(' ', $line)); @emails = $ns->email; diag(join ', ', @emails); ok(scalar @emails == 2, 'append - minimal setup'); $p->add_argument('--foo'); $line = '--foo 1'; $p->namespace(undef); $ns = $p->parse_args(split(' ', $line)); @emails = $ns->email; diag(join ', ', @emails); ok(scalar @emails == 0, 'append - minimal setup,not specified'); $p = Getopt::ArgParse::Parser->new(); $p->add_argument('--foo'); $p->add_argument( '--email', '-e', type => 'Array', default => 'mytram2@perl.org', required => 1, ); $line = '--foo 1'; $ns = $p->parse_args(split(' ', $line)); @emails = $ns->email; diag(join ', ', @emails); ok(scalar @emails == 1, 'append - required with default'); # append default but specified $line = '--foo 1 -e abc@perl.org'; $p->namespace(undef); $ns = $p->parse_args(split(' ', $line)); @emails = $ns->email; diag(join ', ', @emails); ok(scalar @emails == 1, 'append - specified - size'); ok($emails[0] eq 'abc@perl.org', 'append - specified - element'); $emails = $ns->email; ok(scalar(@$emails) == 1, 'append - ref - size'); ok($emails->[0] eq 'abc@perl.org', 'append - ref - element'); # positional options $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument('boo', nargs => 3, type => 'Array'); throws_ok( sub { $n = $p->parse_args(split(' ', '1 2')) }, qr/expected:3,actual:2/, 'not enough arguments', ); $p->add_argument('boo2'); lives_ok( sub { $n = $p->parse_args(split(' ', '1 2 3')) }, ); ok(!defined($n->boo2), 'boo2 not defined'); $p->add_argument('boo3', required => 1); throws_ok( sub { $n = $p->parse_args(split(' ', '1 2 3 4')) }, qr/boo3 is required/, 'required option boo3 not value', ); lives_ok( sub { $n = $p->parse_args(split(' ', '1 2 3 4 5')) }, ); ok($n->boo3 eq '5', 'boo3 is 5'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/choices.t000644 777777 777777 00000000213 12434533663 017656 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561791 23 SCHILY.dev=16777220 23 SCHILY.ino=24743960 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/choices.t000644 €`ÐЀ&‚q00000003405 12434533663 016451 0ustar00mtma000000 000000 use lib "lib"; use Test::More; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument( '--choice', choices => [ 'a', 'b', 'c' ], ); throws_ok( sub { $n = $p->parse_args(split(' ', '--choice hello')); }, qr/not in/, 'choice error: not in choices - arrayref' ); $p->add_argument( '--choice1', choices => sub { die "not in ['a', 'b', 'c']" unless $_[0] =~ /^(a|b|c)$/i; } ); throws_ok( sub { $n = $p->parse_args(split(' ', '--choice1 hello')); }, qr/not in/, 'choice error: not in choices - coderef' ); $n = $p->parse_args(split(' ', '--choice1 A --choice a')); ok($n->choice eq 'a', 'choice ok - fixed value a'); ok($n->choice1 eq 'A', 'choice ok - case insensative A'); $p = Getopt::ArgParse::Parser->new(); throws_ok ( sub { $p->add_argument( '--choice', choices => [ 'a', 'b', 'c' ], choices_i => [ 'A', 'B', 'C' ], ); }, qr/Not allow to specify/, 'not allow to specify choices and choices_i', ); throws_ok( sub { $p->add_argument( '--choice', choices_i => sub { die 'choices' }, ); }, qr/arrayref/, 'only allow arrayref', ); lives_ok( sub { $p->add_argument( '--choice', choices_i => [ 'hello', 'world' ], ); }); throws_ok( sub { $n = $p->parse_args('--choice', 'abc'); }, qr/not in choices/, 'not in allowed choices_i', ); $n = $p->parse_args('--choice', 'WORLD'); ok($n->choice eq 'WORLD', "WORLD is OK"); $n = $p->parse_args('--choice', 'HEllo'); ok($n->choice eq 'HEllo', "HEllo is OK too"); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/count.t000644 777777 777777 00000000213 12433611111 017351 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24691236 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/count.t000644 €`ÐЀ&‚q00000001672 12433611111 016150 0ustar00mtma000000 000000 use lib "lib"; use lib "../lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); $p->add_argument( '--count', '-c', type => 'Count', ); $p->add_argument( 'boo', type => 'Array', nargs => '2', ); $n = $p->parse_args(split(' ', '-c -c 100 -c 200')); # use Data::Dumper; # print STDERR Dumper($p->{-argv}); ok($n->count eq 3, 'count 3'); ok($n->boo->[0] == 100, 'positional arg: 100'); ok($n->boo->[1] == 200, 'positional arg: 200'); $n = $p->parse_args(split(' ', '-c -c -c')); ok($n->count == 6, 'count again now is 6'); $p->add_argument('--count', '-c', type => 'Count', default => 3, reset => 1); $n->set_attr('count', undef); $n = $p->parse_args(); diag($n->count); ok($n->count == 3, 'count default is 3'); $n->set_attr('count', undef); $n = $p->parse_args(split(' ', '-c -c -c')); ok($n->count == 3, 'count default is still 3'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/default.t000644 777777 777777 00000000213 12434533663 017665 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24743961 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/default.t000644 €`ÐЀ&‚q00000002041 12434533663 016453 0ustar00mtma000000 000000 use lib 'lib'; use Test::More; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument('--foo'); $p->add_argument('--required-option', required => 1, default => 10); $p->add_argument('--optional-option', default => [ 20 ]); $n = $p->parse_args(split(' ', '--foo 20')); ok($n->required_option eq 10, "required default 10"); ok($n->optional_option eq 20, "optional default 20"); ok($n->foo eq 20, "foo 20"); throws_ok( sub { $p->add_argument('--optional-option', default => [ 10, 20 ]); }, qr/Multiple default values/, 'multiple default values not allowed', ); # hash default throws_ok( sub { $p->add_argument('--optional-option', default => { a => 1 }); }, qr/HASH default only for/, 'non-hash type', ); lives_ok( sub { $p->add_argument('--optional-option', type => 'Pair', default => { a => 1 }, reset => 1); }, ); $p->namespace(undef); $n = $p->parse_args(split(' ', '--foo 20')); ok($n->optional_option->{a} == 1, 'hash = 1'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/help.t000644 777777 777777 00000000213 12433611111 017151 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24691238 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/help.t000644 €`ÐЀ&‚q00000001131 12433611111 015736 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib 'lib'; use Getopt::ArgParse; $p = Getopt::ArgParse->new_parser( prog => 'mysvn', epilog => 'copyright me', error_prefix => 'mysvn:error: ', ); $p->add_argument('--verbose', '-v', type => 'Bool'); $p->add_subparsers( title => 'subcommands', ); $sp = $p->add_parser( 'list', help => 'list the directories', ); $sp->add_argument( '--verbose', '-v', type => 'Count', help => 'verbosity', ); if (fork()) { $pid = wait(); ok($pid, "pid return"); done_testing; } else { $p->parse_args('--help'); } 1; Getopt-ArgParse-1.0.6/t/PaxHeader/help2.t000644 777777 777777 00000000213 12433611111 017233 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24691239 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/help2.t000644 €`ÐЀ&‚q00000001100 12433611111 016014 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib 'lib'; use Getopt::ArgParse; $p = Getopt::ArgParse->new_parser( prog => 'mysvn', error_prefix => 'mysvn:error: ', ); $p->add_argument('--verbose', '-v', type => 'Bool'); $p->add_subparsers( title => 'subcommands', ); $sp = $p->add_parser( 'list', help => 'list the directories', ); $sp->add_argument( '--verbose', '-v', type => 'Count', help => 'verbosity', ); if (fork()) { $pid = wait(); ok($pid, "pid return"); done_testing; } else { $p->parse_args('help', 'list'); } 1; Getopt-ArgParse-1.0.6/t/PaxHeader/help3.t000644 777777 777777 00000000213 12433611111 017234 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24691240 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/help3.t000644 €`ÐЀ&‚q00000001070 12433611111 016023 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib 'lib'; use Getopt::ArgParse; $p = Getopt::ArgParse->new_parser( prog => 'mysvn', error_prefix => 'mysvn:error: ', ); $p->add_argument('--verbose', '-v', type => 'Bool'); $p->add_subparsers( title => 'subcommands', ); $sp = $p->add_parser( 'list', help => 'list the directories', ); $sp->add_argument( '--verbose', '-v', type => 'Count', help => 'verbosity', ); if (fork()) { $pid = wait(); ok($pid, "pid return"); done_testing; } else { $p->parse_args('help'); } 1; Getopt-ArgParse-1.0.6/t/PaxHeader/merge.t000644 777777 777777 00000000213 12433611111 017320 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24691241 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/merge.t000644 €`ÐЀ&‚q00000002635 12433611111 016117 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib 'lib'; use lib '../lib'; use Getopt::ArgParse; $common_parser = Getopt::ArgParse->new_parser(); $common_parser->add_argument( '--dry-run', type => 'Bool', ); $parser = Getopt::ArgParse->new_parser(); $parser->add_arguments( [ '--foo' ], ); $parser->add_subparsers(); $sp = $parser->add_parser('list'); $sp->copy_args($common_parser); $sp = $parser->add_parser('copy'); $sp->copy_args($common_parser); $n = $parser->parse_args('list', '--dry-run'); ok($n->dry_run, 'dry-run'); $n = $parser->parse_args('copy', ''); ok($n->no_dry_run, 'no dry-run'); throws_ok( sub { $parser->parse_args('--dry-run'); }, qr/Unknown option: dry-run/, 'unknown option', ); # copy parsers $parser1 = Getopt::ArgParse->new_parser( prog => 'parser1', ); $parser1->copy_parsers($parser); throws_ok( sub { $parser1->parse_args('--foo 123'); }, qr/Unknown option: foo/, 'unknown option: foo', ); $n = $parser1->parse_args('list', '--dry-run'); ok($n->dry_run, 'parse1: dry-run'); $n = $parser1->parse_args('copy', ''); ok($n->no_dry_run, 'parse1: no dry-run'); # copy parsers $parser2 = Getopt::ArgParse->new_parser( prog => 'parser2', parents => [ $parser ], ); $n = $parser2->parse_args('list', '--dry-run'); ok($n->dry_run, 'parse2: dry-run'); $n = $parser2->parse_args('copy', ''); ok($n->no_dry_run, 'parse2: no dry-run'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/name.t000644 777777 777777 00000000213 12434533663 017161 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24743963 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/name.t000644 €`ÐЀ&‚q00000002215 12434533663 015752 0ustar00mtma000000 000000 use lib 'lib'; use Test::More tests => 10; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); lives_ok( sub { $p->add_argument('-f'); }, "add option -f", ); throws_ok( sub { $p->add_argument('--foo', '-f'); }, qr/already used for a different option/, "-f already used for a different option" ); throws_ok( sub { $p->add_argument('--', '-foo'); }, qr/Empty option name/, "non-empty name is required" ); lives_ok( sub { $p->add_argument('--boo', '-b', dest => 'boo_option'); }, "add multiple flag option" ); lives_ok( sub { $ns = $p->parse_args( split(' ', '-f 10 --boo 300') ); }, "parse args" ); ok($ns->f == 10, "use name to refer to option"); ok($ns->boo_option == 300, "use dest to refer to option"); $ns = $p->parse_args( split(' ', '-b 400') ); ok($ns->boo_option == 400, "use alternative flag"); $p->add_argument('--dash-option'); $ns = $p->parse_args( split(' ', '--dash-option 400') ); ok ($ns->dash_option, "dashes replaced with underscores in dest"); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/nargs.t000644 777777 777777 00000000213 12434533663 017353 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24743964 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/nargs.t000644 €`ÐЀ&‚q00000003145 12434533663 016147 0ustar00mtma000000 000000 use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument( 'boo', # nargs => 1, ); $n = $p->parse_args(split(' ', '100')); ok($n->boo == 100, 'boo is 100 nargs=>1'); $p->add_argument( 'boo1', type => 'Array', nargs => 2, ); $p->add_argument( 'boo2', nargs => '?', ); lives_ok( sub { $n = $p->parse_args(split(' ', 'abc 100 200')); } ); ok(!$n->boo2, 'boo2 is not taken nargs=>?'); lives_ok( sub { $n = $p->parse_args(split(' ', 'abc 100 200 300')); } ); ok($n->boo2 == 300, 'boo2 is 300 nargs=>?'); $p->add_argument( 'boo3', type => 'Array', nargs => '+', ); throws_ok( sub { $n = $p->parse_args(split(' ', 'abc 100 200 300')); }, qr/Too few arguments/, 'too few arguments for +', ); lives_ok( sub { $n = $p->parse_args(split(' ', 'abc 100 200 300 400 500')); }, ); $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument( 'boo', # nargs => 1, ); $p->add_argument( 'boo1', type => 'Array', nargs => '*', ); lives_ok( sub { $n = $p->parse_args(split(' ', 'abc')); }, ); lives_ok( sub { $n = $p->parse_args(split(' ', 'abc 100 200 300 400 500')); }, ); ok($n->boo1->[4] == 500, 'nargs=>* boo1->[4] is 500'); throws_ok ( sub { $p->add_argument('-f', nargs => 10) }, qr/only allow/, 'not allowed for optional options', ); $p->add_argument('f', nargs => 'abc'); throws_ok ( sub { $p->parse_args('abc') }, qr/Invalid nargs/, 'invalid nargs', ); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/pair.t000644 777777 777777 00000000213 12434533663 017174 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24743965 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/pair.t000644 €`ÐЀ&‚q00000002504 12434533663 015766 0ustar00mtma000000 000000 use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); $p->add_argument( '--pair', '-p', type => 'Pair', ); $p->add_argument( '--pairs', type => 'Pair', ); $n = $p->parse_args('--pair', 'hello=\'hello world\'', split(' ', '--pairs a=1 --pairs b=2')); $p = $n->pair; diag($p->{'hello'}); ok($p->{'hello'} eq '\'hello world\'', 'hello=world'); $p = $n->pairs; ok($p->{'a'} eq '1', 'a=1'); ok($p->{'b'} eq '2', 'b=2'); # positional $p = Getopt::ArgParse::Parser->new(); $p->add_argument('command'); $p->add_argument('params', type => 'Pair', nargs => '+'); lives_ok ( sub { $n = $p->parse_args('list', 'a=b', 'b=1', 'c=2'); } ); ok($n->command eq 'list', 'command=list'); ok($n->params->{a} eq 'b', 'a=b'); ok($n->params->{b} eq '1', 'b=1'); ok($n->params->{c} eq '2', 'c=2'); $p->namespace(undef); throws_ok( sub { $p->add_argument('params', type => 'Pair', nargs => '?', default => { a => 10 }); }, qr/Redefine option params without reset/, 'redefine option with reset', ); lives_ok( sub { $p->add_argument('params', type => 'Pair', nargs => '?', default => { a => 10 }, reset => 1); }, ); lives_ok ( sub { $n = $p->parse_args('list') } ); ok($n->params->{a} eq '10', 'a=10, from default'); done_testing; 1; Getopt-ArgParse-1.0.6/t/PaxHeader/perldoc.pl000644 777777 777777 00000000213 12433611111 020021 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561776 23 SCHILY.dev=16777220 23 SCHILY.ino=24691245 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/perldoc.pl000644 €`ÐЀ&‚q00000006546 12433611111 016625 0ustar00mtma000000 000000 use Getopt::ArgParse; use feature 'say'; $ap = Getopt::ArgParse->new_parser( prog => 'MyProgramName', description => 'This is a program', epilog => 'This appears at the botton of usage', ); # Parse an option: '--foo value' or '-f value' $ap->add_argument('--foo', '-f', required => 1); # Parse a boolean: '--bool' or '-b' using a different name from # the option $ap->add_argument('--bool', '-b', type => 'Bool', dest => 'boo'); # Parse a positonal option. # But in this case, better using subcommand. See below $ap->add_argument('command', required => 1); # $ns is also accessible via $ap->namespace my $ns = $ap->parse_args(split(' ', 'test -f 1 -b')); say $ns->command; # 'test' say $ns->foo; # 1 say $ns->boo; # 1 say $ns->no_boo; # false - 'no_' is added for boolean options # You can continue to add arguments and parse them again # $ap->namespace is accumulatively populated # Parse an Array type option and split the value into an array of values $ap->add_argument('--emails', type => 'Array', split => ','); $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org,c@perl.org')); # Because this is an array option, this allows you to specify the # option multiple times $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org --emails c@perl.org')); say join('|', $ns->emails); # a@perl.org|b@perl.org|c@perl.org # Parse an option as key,value pairs $ap->add_argument('--param', type => 'Pair', split => ','); $ns = $ap->parse_args(split(' ', '--param a=1,b=2,c=3')); say $ns->param->{a}; # 1 say $ns->param->{b}; # 2 say $ns->param->{c}; # 3 # You can use choice to restrict values $ap->add_argument('--env', choices => [ 'dev', 'prod' ]); # or use case-insensitive choices # Override the previous option $ap->add_argument('--env', choices_i => [ 'dev', 'prod' ], reset => 1); # or use a coderef # Override the previous option $ap->add_argument( '--env', choices => sub { die "--env invalid values" if $_[0] !~ /^(dev|prod)$/i; }, reset => 1, ); # subcommands $ap->add_subparsers(title => 'subcommands'); # Must be called to initialize subcommand parsing $list_parser = $ap->add_parser( 'list', help => 'List directory entries', description => 'A multiple paragraphs long description.', ); $list_parser->add_arguments( [ '--verbose', '-v', type => 'Count', help => 'Verbosity', ], [ '--depth', help => 'depth', ], ); $ns = $ap->parse_args(split(' ', 'list -v')); say $ns->current_command(); # current_command stores list, # Don't use this name for your own option $ns =$ap->parse_args(split(' ', 'help list')); # This will print the usage for the list command # help subcommand is automatically added for you say $ns->help_command(); # list # Copy parsing $common_args = Getopt::ArgParse->new_parser(); $common_args->add_arguments( [ '--dry-run', type => 'Bool', help => 'Dry run', ], ); $sp = $ap->add_parser( 'remove', aliases => [qw(rm)], # prog remove or prog rm parents => [ $command_args ], # prog rm --dry-run ); # Or copy explicitly $sp = $ap->add_parser( 'copy', aliases => [qw(cp)], # prog remove or prog rm ); $sp->copy_args($command_parser); # You can also copy_parsers() but in this case # $common_parser doesn't have subparsers 1; Getopt-ArgParse-1.0.6/t/PaxHeader/required.t000644 777777 777777 00000000213 12434533663 020061 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561792 23 SCHILY.dev=16777220 23 SCHILY.ino=24743966 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/required.t000644 €`ÐЀ&‚q00000005577 12434533663 016670 0ustar00mtma000000 000000 use lib 'lib'; use Test::More; # tests => 10; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new( print_usage_if_help => 0, # no ); ok($p, "new argparser"); $p->add_argument('--required-option', required => 1); $p->add_argument('--optional-option'); lives_ok( sub {$n = $p->parse_args(split(' ', '--required-option hello'));}, ); ok($n->required_option eq "hello", "required_option"); ok( !defined($n->optional_option), "optional_option is undef"); lives_ok( sub { $n = $p->parse_args( split(' ', '--optional-option hello') ); }, ); ok($n->required_option eq "hello", "required_option"); ok($n->optional_option eq 'hello', "optional_option is hello"); $p->namespace(Getopt::ArgParse::Namespace->new()); # Clear out required-option # multiple parsing preserves previous values $n = $p->namespace; $p->add_argument('--optional-option', reset => 1); throws_ok( sub { $n = $p->parse_args( split(' ', '--optional-option hello') ); }, qr/required/, "required option", ); lives_ok( sub { $n = $p->parse_args('--help') }, ); ok($n->help, 'help'); $p = Getopt::ArgParse::Parser->new( print_usage_if_help => 0, # no ); $p->add_subparsers(); $lp = $p->add_parser('list'); $lp->add_arguments( [ '--type', required => 1], [ 'branch', required => 1], ); lives_ok( sub { $n = $p->parse_args('list', '--help'); }, ); ok($n->help, 'list -help'); # postional options $p = Getopt::ArgParse::Parser->new(); $p->add_argument('-f'); $p->add_argument('boo'); # not required $n = $p->parse_args(split(' ', '-f 10')); ok (!$n->boo, 'boo is not required'); $p->add_argument('boo', required => 1, reset => 1); throws_ok ( sub { $n = $p->parse_args(split(' ', '-f 10')); }, qr /required/, 'required positional arg: boo' ); lives_ok( sub { $n = $p->parse_args(split(' ', '-f 10 100')); }, ); ok($n->boo == 100, 'boo is 100'); throws_ok( sub { $p->add_argument('boo', nargs => 2); }, qr/Redefine option boo without reset/, 'Redfine option boo' ); lives_ok( sub { $p->add_argument('boo', nargs => 2, reset => 1); }, ); lives_ok( sub { $n = $p->parse_args(split(' ', '-f 10')); }, ); throws_ok( sub { $n = $p->parse_args(split(' ', '-f 10 111')); }, qr/Too few arguments for boo/, 'not enough args for boo', ); $p->add_argument('boo', type => 'Array', nargs => 2, required => 1, reset => 1); # $n = $p->parse_args(split(' ', '-f 10')); $n->set_attr('boo', undef); # Now it will fail for it's required throws_ok( sub { $n = $p->parse_args(split(' ', '-f 10')); }, qr/required/, 'boo is required', ); throws_ok( sub { $n = $p->parse_args(split(' ', '-f 10 100')); }, qr/Too few arguments for boo/, 'not enough args for boo', ); lives_ok( sub { $n = $p->parse_args(split(' ', '-f 10 100 20')); }, ); ok($n->boo->[0] == 100, 'boo 0 - 100'); ok($n->boo->[1] == 20, 'boo 1 - 20'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/split.t000644 777777 777777 00000000213 12433611111 017354 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24691247 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/split.t000644 €`ÐЀ&‚q00000001534 12433611111 016150 0ustar00mtma000000 000000 use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument( '--single', type => 'Array', split => ',', ); $p->add_argument( '--e', type => 'Array', split => ',', ); $n = $p->parse_args(split(' ', '--single 1,2,3 --single 4,5,6 --e a,b,c')); @s = $n->single; ok (scalar @s eq 6, "split count"); ok (join(',', @s) eq '1,2,3,4,5,6', "split value: single"); @e = $n->e; ok (scalar @e eq 3, "split count"); ok (join(',', @e) eq 'a,b,c', "split value"); $p->add_argument( '--pairs', split => ',', type => 'Pair', ); $n = $p->parse_args(split(' ', '--pairs a=1,b=2,c=3')); $p = $n->pairs; ok($p->{'a'} eq '1', 'a=1'); ok($p->{'b'} eq '2', 'b=2'); ok($p->{'c'} eq '3', 'c=3'); done_testing; 1; Getopt-ArgParse-1.0.6/t/PaxHeader/store.t000644 777777 777777 00000000213 12433611111 017355 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24691248 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/store.t000644 €`ÐЀ&‚q00000001777 12433611111 016162 0ustar00mtma000000 000000 use lib "../lib"; use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; $p = Getopt::ArgParse::Parser->new(); ok($p, "new argparser"); $p->add_argument('--foo', type => 'Scalar'); $p->add_argument('--vv', type => 'Bool'); $p->add_argument('-q', type => 'Bool', default => 1); $line = '--vv'; $ns = $p->parse_args($line); ok ($ns->vv, 'v - true'); ok ($ns->q, 'q - true'); $ns = $p->parse_args(split(' ', '-q')); ok (!$ns->vv, 'vv - false'); ok (!$ns->q, 'q - false'); ok ($ns->no_vv, 'no_vv - true'); ok ($ns->no_q, 'no_q - true'); throws_ok( sub { $n = $p->parse_args(split(' ', '--foo 100 --foo 200')); }, qr/foo can only have one value/, 'foo can only have one value', ); lives_ok( sub { $n = $p->parse_args(split(' ', '--foo 200')); }, ); ok ($ns->foo eq 200, '200 ok'); # positional args $p = Getopt::ArgParse::Parser->new(); $p->add_argument('boo'); $n = $p->parse_args(split(' ', 100, 200)); ok($n->boo == 100, 'boo is 100'); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/subcommand.t000644 777777 777777 00000000213 12434533663 020371 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24743967 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/subcommand.t000644 €`ÐЀ&‚q00000005616 12434533663 017172 0ustar00mtma000000 000000 use Test::More; use Test::Exception; use lib '../lib'; use lib 'lib'; use Getopt::ArgParse; $p = Getopt::ArgParse->new_parser(); ok($p, 'new parser'); throws_ok( sub { $p->add_subparsers( 'parser', ); }, qr /Incorrect number of arguments/, 'incorrect number of args', ); throws_ok( sub { $p->add_subparsers( something => 'parser', something2 => 'parser'); }, qr /Unknown parameters: something/, 'unknown parameters', ); lives_ok( sub { $p->add_subparsers(); }, ); throws_ok( sub { $p->add_subparsers(); }, qr/Subparsers already added/, 'subparsers already added', ); $p = Getopt::ArgParse->new_parser(); $p->add_argument( '--foo', ); throws_ok( sub { $pp = $p->add_parser('list') }, qr /add_subparsers\(\) is not called/, 'add_subparsers is not called' ); $sp = $p->add_subparsers( title => 'Here are some subcommands', description => 'Use subcommands to do something', ); throws_ok( sub { $pp = $p->add_parser() }, qr /Subcommand is empty/, 'Subcommand is empty', ); throws_ok( sub { $pp = $p->add_parser(listx => 'add listx') }, qr/Incorrect number of arg/, 'Incorrect number of args', ); throws_ok( sub { $p->add_parser( 'listx', something => 'parser', something2 => 'parser'); }, qr /Unknown parameters: something/, 'Unknown parameters', ); $sp->add_parser( 'listx', aliases => [ qw(lx) ], ); throws_ok( sub { $pp = $p->add_parser('listx') }, qr /Subcommand listx already defined/, 'subcommand listx already defined', ); throws_ok( sub { $pp = $sp->add_parser( 'list', aliases => qw(ls) , help => 'This is the list subcommand', ); }, qr/Aliases is not an arrayref/, 'aliases is not an arrayref', ); throws_ok( sub { $pp = $sp->add_parser( 'list', aliases => [ qw(ls lx) ], help => 'This is the list subcommand', ); }, qr/Alias=lx already used/, 'alias already used' ); $list_p = $sp->add_parser( 'list', aliases => [ qw(ls) ], help => 'This is the list subcommand', ); $list_p->add_argument( '--foo', '-x', type => 'Bool', help => 'this is list foo', ); $list_p->add_argument( '--boo', '-b', type => 'Bool', help => 'this is list boo', ); # parse for the top command $n = $p->parse_args(split(' ', '--foo 100')); ok($n->foo == 100, 'foo is 100'); throws_ok( sub { $n->boo }, qr /unknown option: boo/, 'unknown option', ); throws_ok( sub { $n = $p->parse_args(split(' ', 'list2 --foo')); }, qr/list2 is not a .* command. See help/, 'list2 is not a command', ); lives_ok( sub { $n = $p->parse_args(split(' ', 'list --boo -foo')); }, ); ok($n->current_command eq 'list', 'current_command is list'); ok($n->foo, "list's foo is true"); ok($n->boo, "list's boo is true"); done_testing; Getopt-ArgParse-1.0.6/t/PaxHeader/usage.t000644 777777 777777 00000000213 12476301160 017334 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=30455061 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/t/usage.t000644 €`ÐЀ&‚q00000007765 12476301160 016144 0ustar00mtma000000 000000 use lib "lib"; use Test::More; # tests => 4; use Test::Exception; use Getopt::ArgParse::Parser; my $parser = Getopt::ArgParse::Parser->new( prog => 'usage.t', description => 'This is the suite that contains usage message test cases', ); ok($parser); $parser->add_argument('--foo', '-f'); $parser->add_argument('--boo', type => 'Bool'); $parser->add_argument('--nboo', type => 'Bool'); $parser->add_argument('--verbose', '-v', type => 'Bool'); throws_ok ( sub { $parser->add_argument('--verbose', type => 'Count'); }, qr/Redefine option verbose without reset/, 'redefine option' ); $parser->add_argument('--verbose', type => 'Count', reset => 1); $parser->add_argument('--email', required => 1); $parser->add_argument('--email2', '--e2', required => 1); throws_ok( sub { $parser->add_argument('boo', required => 1); }, qr/used by an optional/, 'dest=boo is used', ); $parser->add_argument('boo', required => 1, dest => 'boo_post'); $parser->add_argument('boo2', type => 'Pair', required => 1, default => { a => 1, 3 => 90 }); # subcommands $parser->add_subparsers(title => 'Some subcommands', description => 'there are some subcommands'); $sp = $parser->add_parser( 'list', aliases => [qw(ls)], help => 'this is the list subcommand message', description =><<'EOS', Lorem ipsum dolor sit amet, consectetur adipiscing elit. Vestibulum ac diam iaculis, consectetur nunc sit amet, vulputate lacus. Suspendisse vitae felis nisl. Sed posuere aliquet placerat. Nunc eget sollicitudin eros, quis porta nunc. Mauris laoreet lacinia aliquet. Cras porttitor erat ac elit semper blandit. Vestibulum porttitor nulla id nisl eleifend venenatis. In hac habitasse platea dictumst. Cras ut leo rhoncus, bibendum lectus at, hendrerit tortor. Etiam congue ligula magna, nec malesuada lorem semper ac. Sed luctus malesuada felis, in mollis lectus aliquam ut. Ut adipiscing massa id felis interdum semper sit amet in leo. Morbi imperdiet fringilla sodales. Donec at ipsum eu lorem lacinia pharetra eu non quam. Duis a porttitor nulla. In hac habitasse platea dictumst. Aenean hendrerit sit amet quam nec malesuada. Vivamus lobortis placerat diam, a lobortis ante sollicitudin vel. Cras ullamcorper enim urna, non dignissim velit iaculis id. Sed odio libero, hendrerit sed blandit eget, luctus ut velit. Suspendisse lobortis ullamcorper magna at tincidunt. In hac habitasse platea dictumst. Curabitur accumsan, massa vitae rutrum euismod, quam purus ultrices lectus, sed sodales metus sem sed nulla. Vestibulum tincidunt ligula eget enim pulvinar, non condimentum turpis dignissim. Maecenas sed nulla eu lorem dictum semper. Nulla fringilla egestas nibh vitae blandit. In vitae arcu accumsan turpis commodo varius. Pellentesque id massa ligula. Vestibulum pharetra, metus in semper rutrum, odio urna vulputate magna, nec tristique sem arcu sit amet dui. Suspendisse nec risus consequat, rhoncus tellus vitae, tincidunt augue. Suspendisse cursus felis nulla, non luctus lorem pharetra quis. Nunc pulvinar lectus enim, sit amet interdum felis ultrices vel. Vestibulum neque metus, condimentum eget convallis nec, euismod vitae nunc. Proin sagittis ullamcorper risus, vel rutrum turpis posuere eu. EOS ); $sp->add_argument( 'name', help => 'positional NAME', required => 1 ); $sp->add_argument( 'name2', help => 'positional NAME2', ); $sp->add_argument( '--foo', '-f', help => 'subcommand foo', ); $sp->add_argument( '--boo', '-b', help => 'subcommand boo', required => 1, ); $parser->print_usage(); print STDERR $_, "\n" for @{ $parser->format_command_usage('ls') }; done_testing; __END__ my $ns = $parser->parse_args( '-h', '-f', 100, '--verbose', 'left', '--verbose', '--email', 'a@b', 'c@b', 'a@b', 1, 2, '--verbose', 123, '--verbose', '--boo', 3, '-e2', 'e2@e2', 9999 ); $\ = "\n"; print $ns->foo; print $ns->nboo; print $ns->boo; print $ns->verbose; print "email: ", join(', ', $ns->email); print "argv: ", join(', ', @{$parser->{-argv}}); done_testing; 1; Getopt-ArgParse-1.0.6/lib/PaxHeader/Getopt000755 777777 777777 00000000213 12521122003 017522 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589018 18 SCHILY.nlink=4 Getopt-ArgParse-1.0.6/lib/Getopt/000755 €`ÐЀ&‚q00000000000 12521122003 016365 5ustar00mtma000000 000000 Getopt-ArgParse-1.0.6/lib/Getopt/PaxHeader/ArgParse000755 777777 777777 00000000213 12521122003 021226 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561795 23 SCHILY.dev=16777220 23 SCHILY.ino=34589019 18 SCHILY.nlink=7 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/000755 €`ÐЀ&‚q00000000000 12521122003 020071 5ustar00mtma000000 000000 Getopt-ArgParse-1.0.6/lib/Getopt/PaxHeader/ArgParse.pm000644 777777 777777 00000000261 12521121612 021646 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 38 LIBARCHIVE.creationtime=1425639484 23 SCHILY.dev=16777220 23 SCHILY.ino=30457166 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse.pm000644 €`ÐЀ&‚q00000041077 12521121612 020445 0ustar00mtma000000 000000 require 5.008001; package Getopt::ArgParse; { $Getopt::ArgParse::VERSION = '1.0.6'; }; # ABSTRACT: Getopt::ArgParse - Parsing args with a richer and more user-friendly API use strict; use warnings; use Carp; use Getopt::ArgParse::Parser; sub new_parser { shift; return Getopt::ArgParse::Parser->new(@_); } 1; # perldoc =pod =head1 NAME Getopt::ArgParse - Parsing command line arguments with a richer and more user-friendly API interface, similar to python's argpare but with perlish extras. In particular, the modules provides the following features: - generating usage messages - storing parsed arg values in an object, which can be also used to load configuration values from files and therefore the ability for applications to combine configurations in a single interface - A more user-friendly interface to specify arguments, such as argument types, argument values split, etc. - Subcommand parsing, such svn - Supporting both flag based named arguments and positional arguments =head1 VERSION version 1.0.6 =head1 SYNOPSIS use Getopt::ArgParse; $ap = Getopt::ArgParse->new_parser( prog => 'MyProgramName', description => 'This is a program', epilog => 'This appears at the bottom of usage', ); # Parse an option: '--foo value' or '-f value' $ap->add_arg('--foo', '-f', required => 1); # Parse a boolean: '--bool' or '-b' using a different name from # the option $ap->add_arg('--bool', '-b', type => 'Bool', dest => 'boo'); # Parse a positonal option. # But in this case, better using subcommand. See below $ap->add_arg('command', required => 1); # $ns is also accessible via $ap->namespace $ns = $ap->parse_args(split(' ', 'test -f 1 -b')); say $ns->command; # 'test' say $ns->foo; # false say $ns->boo; # false say $ns->no_boo; # true - 'no_' is added for boolean options # You can continue to add arguments and parse them again # $ap->namespace is accumulatively populated # Parse an Array type option and split the value into an array of values $ap->add_arg('--emails', type => 'Array', split => ','); $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org,c@perl.org')); # Because this is an array option, this also allows you to specify the # option multiple times and splitting $ns = $ap->parse_args(split(' ', '--emails a@perl.org,b@perl.org --emails c@perl.org')); # Below will print: a@perl.org|b@perl.org|c@perl.org|a@perl.org|b@perl.org|c@perl.org # Because Array types are appended say join('|', $ns->emails); # Parse an option as key,value pairs $ap->add_arg('--param', type => 'Pair', split => ','); $ns = $ap->parse_args(split(' ', '--param a=1,b=2,c=3')); say $ns->param->{a}; # 1 say $ns->param->{b}; # 2 say $ns->param->{c}; # 3 # You can use choice to restrict values $ap->add_arg('--env', choices => [ 'dev', 'prod' ],); # or use case-insensitive choices # Override the previous option with reset $ap->add_arg('--env', choices_i => [ 'dev', 'prod' ], reset => 1); # or use a coderef # Override the previous option $ap->add_args( '--env', choices => sub { die "--env invalid values" if $_[0] !~ /^(dev|prod)$/i; }, reset => 1, ); # subcommands $ap->add_subparsers(title => 'subcommands'); # Must be called to initialize subcommand parsing $list_parser = $ap->add_parser( 'list', help => 'List directory entries', description => 'A multiple paragraphs long description.', ); $list_parser->add_args( [ '--verbose', '-v', type => 'Count', help => 'Verbosity', ], [ '--depth', help => 'depth', ], ); $ns = $ap->parse_args(split(' ', 'list -v')); say $ns->current_command(); # current_command stores list, # Don't use this name for your own option $ns =$ap->parse_args(split(' ', 'help list')); # This will print the usage for the list command # help subcommand is automatically added for you say $ns->help_command(); # list # Copy parsing $common_args = Getopt::ArgParse->new_parser(); $common_args->add_args( [ '--dry-run', type => 'Bool', help => 'Dry run', ], ); $sp = $ap->add_parser( 'remove', aliases => [qw(rm)], # prog remove or prog rm parents => [ $command_args ], # prog rm --dry-run ); # Or copy explicitly $sp = $ap->add_parser( 'copy', aliases => [qw(cp)], # prog remove or prog rm ); $sp->copy_args($command_parser); # You can also copy_parsers() but in this case # $common_parser doesn't have subparsers =head1 DESCRIPTIOIN Getopt::ArgParse, Getopt::ArgParse::Parser and related classes together aim to provide user-friendly interfaces for writing command-line interfaces. A user should be able to use it without looking up the document most of the time. It allows applications to define argument specifications and it will parse them out of @AGRV by default or a command line if provided. It implements both named arguments, using Getopt::Long for parsing, and positional arguments. The class also generates help and usage messages. The parser has a namespace property, which is an object of ArgParser::Namespace. The parsed argument values are stored in this namespace property. Moreover, the values are stored accumulatively when parse_args() is called multiple times. Though inspired by Python's argparse and names and ideas are borrowed from it, there is a lot of difference from the Python one. =head2 Getopt::ArgParser::Parser This is the underlying parser that does the heavylifting. Getopt::ArgParse::Parser is a Moo class. =head3 Constructor my $parser = Getopt::ArgParse->new_parser( help => 'short description', description => 'long description', ); The former calls Getopt::ArgParser::Parser->new to create a parser object. The parser constructor accepts the following parameters. All parsers are created with a predefined Bool option --help|-h. The program can choose to reset it, though. =over 8 =item * prog The program's name. Default $0. =item * help A short description of the program. =item * description A long description of the program. =item * namespace An object of Getopt::ArgParse::Namespace. An empty namespace is created if not provided. The parsed values are stored in it, and they can be refered to by their argument names as the namespace's properties, e.g. $parser->namespace->boo. See also Getopt::ArgParse::Namespace =item * parser_configs The Getopt::Long configurations. See also Getopt::Long =item * parents Parent parsents, whose argument and subparser specifications the new parser will copy. See copy() below =item * error_prefix Customize the message prefixed to error messages thrown by Getop::ArgParse, default to 'Getopt::ArgParse: ' =item * print_usage_if_help Set this to false to not display usage messages even if --help is on or the subcommand help is called. The default behavior is to display usage messages if help is set. =back =head3 add_arg, add_argument, add_args, and add_arguments $parser->add_args( [ '--foo', required => 1, type => 'Array', split => ',' ], [ 'boo', required => 1, nargs => '+' ], ); The object method, arg_arg or the longer version add_argument, defines the specfication of an argument. It accepts the following parameters. add_args or add_arguments() is to add multiple multiple arguments. =over 8 =item * name or flags Either a name or a list of option strings, e.g. foo or -f, --foo. If dest is not specified, the name or the first option without leading dashes will be used as the name for retrieving values. If a name is given, this argument is a positional argument. Otherwise, it's an option argument. Hyphens can be used in names and flags, but they will be replaced with underscores '_' when used as option names. For example: $parser->add_argument( [ '--dry-run', type => 'Bool' ]); # command line: prog --dry-run $parser->namespace->dry_run; # The option's name is dry_run A name or option strings are following by named paramters. =item * dest The name of the attribute to be added to the namespace populated by parse_args(). =item * type => $type Specify the type of the argument. It can be one of the following values: =over 8 =item * Scalar The option takes a scalar value. =item * Array The option takes a list of values. The option can appear multiple times in the command line. Each value is appended to the list. It's stored in an arrayref in the namespace. =item * Pair The option takes a list of key-value pairs separated by the equal sign '='. It's stored in a hashref in the namespace. =item * Bool The option does not take an argument. It's set to true if the option is present or false otherwise. A 'no_bool' option is also available, which is the negation of bool(). For example: $parser->add_argument('--dry-run', type => 'Bool'); $ns = $parser->parse_args(split(' ', '--dry-run')); print $ns->dry_run; # true print $ns->no_dry_run; # false =item * Count The option does not take an argument and its value will be incremented by 1 every time it appears on the command line. =back =item * split split should work with types 'Array' and 'Pair' only. split specifies a string by which to split the argument string e.g. if split => ',', a,b,c will be split into [ 'a', 'b', 'c' ].When split works with type 'Pair', the parser will split the argument string and then parse each of them as pairs. =item * choices or choices_i choices specifies a list of the allowable values for the argument or a subroutine that validates input values. choices_i specifies a list of the allowable values for the argument, but case insenstive, and it doesn't allow to use a subroutine for validation. Either choices or chioces_i can be present or completely omitted, but not both at the same time. =item * default The value produced if the argument is absent from the command line. Only one value is allowed for scalar argument types: Scalar, Count, and Bool. =item * required Whether or not the command-line option may be omitted (optionals only). This has no effect on types 'Bool' and 'Count'. An named option is marked by the question mark ? in the generated usage, e.g. --help, -h ? show this help message and exit This parameter is ignored for Bool and Count types for they will already have default values. =item * help A brief description of what the argument does. =item * metavar A name for the argument in usage messages. =item * reset Set reset to override the existing definition of an option. This will clear the value in the namspace as well. =cut =item * nargs - Positional option only This only instructs how many arguments the parser consumes. The program still needs to specify the right type to achieve the desired result. =over 8 =item * n 1 if not specified =item * ? 1 or 0 =item * + 1 or more =item * * 0 or many. This will consume the rest of arguments. =back =back =head3 parse_args $namespace = $parser->parse_args(@command_line); This object method accepts a list of arguments or @ARGV if unspecified, parses them for values, and stores the values in the namespace object. A few things may be worth noting about parse_args(). First, parsing for Named Arguments is done by Getopt::Long Second, parsing for positional arguments takes place after that for named arguments. It will consume what's still left in the command line. Finally, the Namespace object is accumulatively poplulated. If parse_args() is called multiple times to parse a number of command lines, the same namespace object is accumulatively populated. For Scalar and Bool options, this means the previous value will be overwrittend. For Pair and Array options, values will be appended. And for a Count option, it will add on top of the previous value. In face, the program can choose to pass a already populated namespace when creating a parser object. This is to allow the program to pre-load values to a namespace from conf files before parsing the command line. And finally, it does NOT display usage messages if the argument list is empty. This may be contrary to many other implementations of argument parsing. =head3 argv @argv = $parser->argv; # called after parse_args Call this after parse_args() is invoked to get the unconsumed arguments. It's up to the application to decide what to do if there is a surplus of arguments. =head3 The Namespace Object The parsed values are stored in a namespace object. Any class with the following three methods: * A constructor new() * set_attr(name => value) * get_attr(name) can be used as the Namespace class. The default one is Getopt::ArgParse::Namespace. It uses autoload to provide a readonly accessor method using dest names to access parsed values. However, this is not required for user-defined namespace. So within the implementation, $namespace->get_attr($dest) should always be used. =head2 Subcommand Support Note only one level of subcommand parsing is supported. Subcommands cannot have subcommands. Call add_subparsers() first to initialize the current parser for subcommand support. A help subcommand is created as part of the initialization. The help subcommand has the following options: =over 4 required positional arguments: COMMAND ? Show the usage for this command optional named arguments: --help, -h ? show this help message and exit --all, -a ? Show the full usage =back Call add_parser() to add a subparser for each subcommand. Use the parser object returned by add_parser() to add the options to the subcommand. Once subcommand support is on, if the first argument is not a flag, i.e. starting with a dash '-', the parser's parse_args() will treat it as a subcommand. Otherwise, the parser parses for the defined arguments. The namespace's current_command() will contain the subcommand after parsing successfully. Unlike arguments, subparsers cannot be reset. =head3 add_subparsers $parser->add_subparsers( title => 'Subcommands', description => 'description about providing subcommands', ); add_subparsers must be called to initialize subcommand support. =over 8 =item * title A title message to mark the beginning of subcommand usage in the usage message =item * description A general description appearing about the title =back =head3 add_parser $subparser = $parser->add_parser( 'list', aliases => [qw(ls)], help => 'short description', description => 'a long one', parents => [ $common_args ], # inherit common args from # $common_args ); =over 8 =item * $command The first argument is the name of the new command. =item * help A short description of the subcommand. =item * description A long description of the subcommand. =item * aliases An array reference containing a list of command aliases. =item * parents An array reference containing a list of parsers whose specification will be copied by the new parser. =back =head2 get_parser $subparser = $parser->get_parser('ls'); Return the parser for parsing the $alias command if exsist. =head2 Copying Parsers A parser can copy argument specification or subcommand specifciation for existing parsers. A use case for this is that the program wants all subcommands to have a command set of arguments. =head3 copy_args $parser->copy_args($common_args_parser); Copy argument specification from the $parent parser =head3 copy_parsers $parser->copy_parsers($common_args_parser); Copy parser specification for subcommands from the $parent parser =head3 copy $parser->copy($common_args_parser); Copy both arguments and subparsers. =head2 Usage Messages and Related Methods =head3 format_usage $usage = $parser->format_usage; Return the formated usage message for the whole program in an array reference. =head3 print_usage $parser->print_usage; Print the usage mesage returned by format_usage(). =head3 format_command_usage $usage = $parser->format_command_usage($subcommand); Return the formated usage message for the command in an array reference. =head3 print_command_usage $parser->print_command_usage($subcommand); Print the usage message returned by format_command_usage(). If $command is not given, it will first try to use $self->namespace->help_command, which will be present for the help subcommand, and then $self->namespace->current_command. =head3 =head1 SEE ALSO Getopt::Long Python's argparse =head1 AUTHOR Mytram (original author) =head1 CONTRIBUTORS Robbin Bonthond (rbonthond@github) Adam Pfeiffer (apinco@github) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut __END__ Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/PaxHeader/ActionAppend.pm000644 777777 777777 00000000213 12434533654 024230 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24743948 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/ActionAppend.pm000644 €`ÐЀ&‚q00000001505 12434533654 023022 0ustar00mtma000000 000000 package Getopt::ArgParse::ActionAppend; use strict; use warnings; use Carp; use Getopt::ArgParse::Parser; sub apply { my $self = shift; my ($spec, $namespace, $values) = @_; my $v = $namespace->get_attr( $spec->{dest} ); if ($spec->{type} == Getopt::ArgParse::Parser::TYPE_PAIR) { $v = {} unless defined $v; for my $pair (@$values) { my ($key, $val) = %$pair; $v->{$key} = $val; } } else { $v = [] unless defined $v; push @$v, @$values; } $namespace->set_attr( $spec->{dest}, $v ); return ''; } 1; =head1 AUTHOR Mytram (original author) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/PaxHeader/ActionCount.pm000644 777777 777777 00000000213 12434533654 024111 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24743949 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/ActionCount.pm000644 €`ÐЀ&‚q00000001045 12434533654 022702 0ustar00mtma000000 000000 package Getopt::ArgParse::ActionCount; use strict; use warnings; use Carp; sub apply { my $self = shift; my ($spec, $namespace, $values) = @_; $values ||= []; my $v = $namespace->get_attr($spec->{dest}) || 0; $namespace->set_attr( $spec->{dest}, $v + scalar(@$values) ); return ''; } 1; =head1 AUTHOR Mytram (original author) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/PaxHeader/ActionStore.pm000644 777777 777777 00000000213 12434533654 024115 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24743950 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/ActionStore.pm000644 €`ÐЀ&‚q00000002540 12434533654 022707 0ustar00mtma000000 000000 package Getopt::ArgParse::ActionStore; use strict; use warnings; use Carp; use Getopt::ArgParse::Parser; sub apply { my $self = shift; my ($spec, $namespace, $values) = @_; $values ||= []; return sprintf( '%s can only have one value', $spec->{dest}, ) if @$values > 1; if ($spec->{type} == Getopt::ArgParse::Parser::TYPE_BOOL) { # If there is default true or false my $default = $spec->{default} || [ 0 ]; if (@$values) { # Negate the default if the arg appears on the command # line $namespace->set_attr($spec->{dest}, !$default->[0]); } else { $namespace->set_attr($spec->{dest}, $default->[0]); } # make no_arg available $namespace->set_attr( 'no_' . $spec->{dest}, !$namespace->get_attr($spec->{dest}) ); return; } # Don't set it to undef. We may operate on a namespace with this # attr already set. In that case we don't want to override it. return unless @$values; my $v = $values->[0]; $namespace->set_attr($spec->{dest}, $v); return ''; } 1; =head1 AUTHOR Mytram (original author) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/PaxHeader/Namespace.pm000644 777777 777777 00000000213 12434533654 023557 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=24743951 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/Namespace.pm000644 €`ÐЀ&‚q00000002401 12434533654 022345 0ustar00mtma000000 000000 package Getopt::ArgParse::Namespace; use Carp; use strict; use warnings; sub new { my $class = shift; my $real_class = ref $class || $class; my $self = {}; bless $self, $real_class; } sub set_attr { my $self = shift; my ($dest, $values) = @_; $self->{'-values'}{$dest} = $values; } sub get_attr { my $self = shift; my ($dest) = @_; confess "Must provide $dest" unless $dest; return $self->{'-values'}{$dest} if exists $self->{'-values'}{$dest}; return undef; } our $AUTOLOAD; sub AUTOLOAD { my $sub = $AUTOLOAD; (my $dest = $sub) =~ s/.*:://; my $self = shift; if ( exists $self->{'-values'}{$dest} ) { my $values = $self->{'-values'}{$dest}; if (ref($values) eq 'ARRAY') { return wantarray ? @$values : $values; } elsif (ref($values) eq 'HASH') { return wantarray ? %$values : $values; } else { return $values; } } else { croak "unknown option: $dest"; } } sub DESTROY { } 1; =head1 AUTHOR Mytram (original author) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/PaxHeader/Parser.pm000644 777777 777777 00000000213 12521120653 023103 xustar00mtma000000 000000 17 gid=638878321 18 uid=1624297477 20 ctime=1430561795 20 atime=1430561793 23 SCHILY.dev=16777220 23 SCHILY.ino=34586371 18 SCHILY.nlink=2 Getopt-ArgParse-1.0.6/lib/Getopt/ArgParse/Parser.pm000644 €`ÐЀ&‚q00000112162 12521120653 021677 0ustar00mtma000000 000000 package Getopt::ArgParse::Parser; use Moo; use Getopt::Long qw(GetOptionsFromArray); use Text::Wrap; use Scalar::Util qw(blessed); use File::Basename (); use Getopt::ArgParse::Namespace; use constant { TYPE_UNDEF => 0, TYPE_SCALAR => 1, TYPE_ARRAY => 2, TYPE_COUNT => 3, TYPE_PAIR => 4, # key=value pair TYPE_BOOL => 5, CONST_TRUE => 1, CONST_FALSE => 0, # Export these? ScalarArg => 'scalar', ArrayArg => 'Array', PairArg => 'Pair', CountArg => 'Count', BoolArg => 'Bool', # Internal ERROR_PREFIX => 'Getopt::ArgParse: ', PRINT_REQUIRED => 1, PRINT_OPTIONAL => 2, }; # Allow customization # default actions my %Action2ClassMap = ( '_store' => 'Getopt::ArgParse::ActionStore', '_append' => 'Getopt::ArgParse::ActionAppend', '_count' => 'Getopt::ArgParse::ActionCount', # Not supported - Maybe in the future # '_help' => 'Getopt::ArgParse::ActionHelp', # '_version' => 'Getopt::ArgParse::ActionVersion', ); my %Type2ConstMap = ( '' => TYPE_UNDEF(), 'Scalar' => TYPE_SCALAR(), 'Array' => TYPE_ARRAY(), 'Count' => TYPE_COUNT(), 'Pair' => TYPE_PAIR(), 'Bool' => TYPE_BOOL(), ); sub _croak { die join('', @_, "\n"); } # Program name. Default $0 has prog => ( is => 'rw', required => 1, default => sub { File::Basename::basename($0) }, ); # short one has help => ( is => 'rw', required => 1, default => sub { '' }, ); # long one has description => ( is => 'rw', required => 1, default => sub { '' }, ); has epilog => ( is => 'rw', required => 1, default => sub { '' }, ); has error_prefix => (is => 'rw', default => sub { ERROR_PREFIX() }, ); has aliases => (is => 'ro', default => sub { [] }); # for subcommand only # namespace() - Read/write # Contains the parsed results. has namespace => ( is => 'rw', isa => sub { return undef unless $_[0]; # allow undef my $class = blessed $_[0]; die 'namespace doesn\'t comform to the required interface' unless $class && $class->can('set_attr') && $class->can('get_attr'); }, ); # parent - Readonly has parents => ( is => 'ro', isa => sub { my $parents = shift; for my $parent (@$parents) { my $parent_class = blessed $parent; die 'parent is not a Getopt::ArgParse::Parser' unless $parent_class && $parent_class->isa(__PACKAGE__); } }, default => sub { [] }, ); # parser_configs - Read/write # The configurations that will be passed to Getopt::Long::Configure( # $self->parser_configs ) when parse_args is invoked. has parser_configs => ( is => 'rw', required => 1, default => sub { [] }, ); # Behavioural properties # # Print usage message if help is no, by default. Turn this off by # setting this to a false value has print_usage_if_help => (is => 'ro', default => 1); # internal properties has _option_position => ( is => 'rw', required => 1, default => sub { 0 } ); # The current subcommand the same as namespace->current_command has _command => ( is => 'rw'); # Sortby parameter. Used to determine if sorting by 'position' or by 'name' has sortby => ( is => 'rw', isa => sub { die "$_[0] is not valid: valid options are: name, position" unless ($_[0] eq 'position' or $_[0] eq 'name'); }, default => $_[0] || 'position' ); sub BUILD { my $self = shift; $self->{-option_specs} = {}; $self->{-position_specs} = {}; $self->add_argument( '--help', '-h', type => 'Bool', dest => 'help', help => 'show this help message and exit', reset => 1, ); # merge for my $parent (@{$self->parents}) { $self->copy($parent); } } # sub _check_parent { my $parent = shift; my $parent_class = blessed $parent; _croak 'Parent is not a Getopt::ArgParse::Parser' unless $parent_class && $parent_class->isa(__PACKAGE__); } sub copy { my $self = shift; my $parent = shift; _croak 'Parent is missing' unless $parent; _check_parent($parent); $self->copy_args($parent); $self->copy_parsers($parent); } sub copy_args { my $self = shift; my $parent = shift; _croak 'Parent is missing' unless $parent; _check_parent($parent); $self->add_arguments( @{ $parent->{-pristine_add_arguments} } ); } sub copy_parsers { my $self = shift; my $parent = shift; _croak 'Parent is missing' unless $parent; _check_parent($parent); if (exists $parent->{-subparsers}) { $self->add_subparsers( @{$parent->{-pristine_add_subparsers}->[0]} ); for my $args (@{$parent->{-pristine_add_parser}}) { my $command = $args->[0]; next if $command eq 'help'; $self->add_parser( @$args, parents => [ $parent->{-subparsers}{-parsers}{$command} ], ); } } } # # subcommands # sub add_subparsers { my $self = shift; push @{$self->{-pristine_add_subparsers}}, [ @_ ]; _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@_) % 2; my $args = { @_ }; my $title = (delete $args->{title} || 'subcommands') . ':'; my $description = delete $args->{description} || ''; _croak $self->error_prefix . sprintf( 'Unknown parameters: %s', join(',', keys %$args) ) if keys %$args; if (exists $self->{-subparsers}) { _croak $self->error_prefix . 'Subparsers already added'; } $self->{-subparsers}{-title} = $title; $self->{-subparsers}{-description} = $description; $self->{-subparsers}{-alias_map} = {}; my $hp = $self->add_parser( 'help', help => 'display help information about ' . $self->prog, ); $hp->add_arguments( [ '--all', '-a', help => 'Show the full usage', type => 'Bool', ], [ 'command', help => 'Show the usage for this command', dest => 'help_command', nargs => 1, ], ); return $self; } # $command, aliases => [], help => '' sub add_parser { my $self = shift; _croak $self->error_prefix . 'add_subparsers() is not called first' unless $self->{-subparsers}; my $command = shift; _croak $self->error_prefix . 'Subcommand is empty' unless $command; _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@_) % 2; if (exists $self->{-subparsers}{-parsers}{$command}) { _croak $self->error_prefix . "Subcommand $command already defined"; } my $args = { @_ }; my $parents = delete $args->{parents} || []; push @{ $self->{-pristine_add_parser} }, [ $command, %$args ]; _croak $self->error_prefix . 'Add_subparsers() is not called first' unless $self->{-subparsers}; my $help = delete $args->{help} || ''; my $description = delete $args->{description} || ''; my $aliases = delete $args->{aliases} || []; _croak $self->error_prefix . 'Aliases is not an arrayref' if ref($aliases) ne 'ARRAY'; _croak $self->error_prefix . sprintf( 'Unknown parameters: %s', join(',', keys %$args) ) if keys %$args; my $alias_map = {}; for my $alias ($command, @$aliases) { if (exists $self->{-subparsers}{-alias_map}{$alias}) { _croak $self->error_prefix . "Alias=$alias already used by command=" . $self->{-subparsers}{-alias_map}{$alias}; } } $self->{-subparsers}{-alias_map}{$_} = $command for ($command, @$aliases); my $prog = $command; # $prog .= ' (' . join(', ', @$aliases) . ')' if @$aliases; $self->{-subparsers}{-aliases}{$command} = $aliases; return $self->{-subparsers}{-parsers}{$command} = __PACKAGE__->new( prog => $prog, aliases => $aliases, # subcommand help => $help, parents => $parents, description => $description, error_prefix => $self->error_prefix, print_usage_if_help => $self->print_usage_if_help, ); } sub get_parser { $_[0]->_get_subcommand_parser(@_) } *add_arg = \&add_argument; *add_args = \&add_arguments; # add_arguments([arg_spec], [arg_spec1], ...) # Add multiple arguments. # Interface method sub add_arguments { my $self = shift; $self->add_argument(@$_) for @_; return $self; } # sub add_argument { my $self = shift; return unless @_; # mostly harmless # # FIXME: This is for merginng parent parents This is a dirty hack # and should be done properly by merging internal specs # and subcommand merging is missing # push @{ $self->{-pristine_add_arguments} }, [ @_ ]; my ($name, $flags, $rest) = $self->_parse_for_name_and_flags([ @_ ]); _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@$rest) % 2; _croak $self->error_prefix . 'Empty option name' unless $name; my $args = { @$rest }; my @flags = @{ $flags }; ################ # nargs - positional only ################ ################ # type ################ my $type_name = delete $args->{type} || 'Scalar'; my $type = $Type2ConstMap{$type_name} if exists $Type2ConstMap{$type_name}; _croak $self->error_prefix . "Unknown type=$type_name" unless defined $type; my $nargs = delete $args->{nargs}; if ( defined $nargs ) { _croak $self->error_prefix . 'Nargs only allowed for positional options' if @flags; if ( $type != TYPE_PAIR && $type != TYPE_ARRAY && $nargs ne '1' && $nargs ne '?' ) { $type = TYPE_ARRAY; } } if ($type == TYPE_COUNT) { $args->{action} = '_count' unless defined $args->{action}; $args->{default} = 0 unless defined $args->{default}; } elsif ($type == TYPE_ARRAY || $type == TYPE_PAIR) { $args->{action} = '_append' unless defined $args->{action}; } else { # pass } ################ # action ################ my $action_name = delete $args->{action} || '_store'; my $action = $Action2ClassMap{$action_name} if exists $Action2ClassMap{$action_name}; $action = $action_name unless $action; { local $SIG{__WARN__}; local $SIG{__DIE__}; eval "require $action"; _croak $self->error_prefix . "Cannot load $action for action=$action_name" if $@; }; ################ # split ################ my $split = delete $args->{split}; if (defined $split && !$split && $split =~ /^ +$/) { _croak $self->error_prefix . 'Cannot use whitespaces to split'; } if (defined $split && $type != TYPE_ARRAY && $type != TYPE_PAIR) { _croak $self->error_prefix . 'Split only for Array and Pair'; } ################ # default ################ my $default; if (exists $args->{default}) { my $val = delete $args->{default}; if (ref($val) eq 'ARRAY') { $default = $val; } elsif (ref($val) eq 'HASH') { _croak $self->error_prefix . 'HASH default only for type Pair' if $type != TYPE_PAIR; $default = $val; } else { $default = [ $val ]; } if ($type != TYPE_PAIR) { if ($type != TYPE_ARRAY && scalar(@$default) > 1) { _croak $self->error_prefix . 'Multiple default values for scalar type: $name'; } } } ################ # choices ################ my $choices = delete $args->{choices} || undef; if ( $choices && ref($choices) ne 'CODE' && ref($choices) ne 'ARRAY' ) { _croak $self->error_prefix . "Must provide choices in an arrayref or a coderef"; } my $choices_i = delete $args->{choices_i} || undef; if ($choices && $choices_i) { _croak $self->error_prefix . 'Not allow to specify choices and choices_i'; } if ( $choices_i && ref($choices_i) ne 'ARRAY' ) { _croak $self->error_prefix . "Must provide choices_i in an arrayref"; } ################ # required ################ my $required = delete $args->{required} || ''; if ($type == TYPE_BOOL || $type == TYPE_COUNT) { $required = ''; # TYPE_BOOL and TYPE_COUNT will already have default values } ################ # help ################ my $help = delete $args->{help} || ''; ################ # metavar ################ my $metavar = delete $args->{metavar} || uc($name); $metavar = '' if $type == TYPE_BOOL || $action_name eq '_count'; ################ # dest ################ my $dest = delete $args->{dest} || $name; $dest =~ s/-/_/g; # option-name becomes option_name if (@flags) { while (my ($d, $s) = each %{$self->{-option_specs}}) { if ($dest ne $d) { for my $f (@flags) { _croak $self->error_prefix . "Flag $f already used for a different option ($d)" if grep { $f eq $_ } @{$s->{flags}}; } } } if (exists $self->{-position_specs}{$dest}) { _croak $self->error_prefix . "Option dest=$dest already used by a positional argument"; } } else { if (exists $self->{-option_specs}{$dest}) { _croak $self->error_prefix . "Option dest=$dest already used by an optional argument"; } } # never modify existing ones so that the parent's structure will # not be modified my $spec = { name => $name, flags => \@flags, action => $action, nargs => $nargs, split => $split, required => $required || '', type => $type, default => $default, choices => $choices, choices_i => $choices_i, dest => $dest, metavar => $metavar, help => $help, position => $self->{-option_position}++, # sort order groups => [ '' ], }; my $specs; if (@flags) { $specs = $self->{-option_specs}; } else { $specs = $self->{-position_specs}; } # reset if (delete $args->{reset}) { $self->namespace->set_attr($spec->{dest}, undef) if $self->namespace; delete $specs->{$spec->{dest}}; } _croak $self->error_prefix . sprintf( 'Unknown spec: %s', join(',', keys %$args) ) if keys %$args; # type check if (exists $specs->{$spec->{dest}}) { _croak $self->error_prefix . sprintf( 'Redefine option %s without reset', $spec->{dest}, ); } # override $specs->{$spec->{dest}} = $spec; # specs changed, need to force to resort specs by groups delete $self->{-groups} if $self->{-groups}; # Return $self for chaining, $self->add_argument()->add_argument() # or use add_arguments return $self; } sub _parse_for_name_and_flags { my $self = shift; my $args = shift; my ($name, @flags); FLAG: while (my $flag = shift @$args) { if (substr($flag, 0, 1) eq '-') { push @flags, $flag; } else { unshift @$args, $flag; last FLAG; } } # It's a positional argument spec if there are no flags $name = @flags ? $flags[0] : shift(@$args); $name =~ s/^-+//g; return ( $name, \@flags, $args ); } # # parse_args([@_]) # # Parse @ARGV if called without passing arguments. It returns an # instance of ArgParse::Namespace upon success # # Interface sub parse_args { my $self = shift; my @argv = scalar(@_) ? @_ : @ARGV; $self->{-saved_argv} = \@ARGV; @ARGV = (); my @option_specs = sort { $a->{position} <=> $b->{position} } values %{$self->{-option_specs}}; my @position_specs = sort { $a->{position} <=> $b->{position} } values %{$self->{-position_specs}}; $self->{-argv} = \@argv; # We still want to continue even if @argv is empty to allow: # - namespace initialization # - default values asssigned # - post checks applied, e.g. required check $self->namespace(Getopt::ArgParse::Namespace->new) unless $self->namespace; my $parsed_subcmd; $self->namespace->set_attr(current_command => undef); # If the first argument is a subcommand, it will parse for the # subcommand if (exists $self->{-subparsers} && scalar(@argv) && defined($argv[0]) && substr($argv[0], 0, 1) ne '-') { # Subcommand must appear as the first argument # or it will parse as the top command my $cmd = shift @argv; my $subparser = $self->_get_subcommand_parser($cmd); _croak $self->error_prefix . sprintf("%s is not a %s command. See help", $cmd, $self->prog) unless $subparser; $parsed_subcmd = $self->_parse_subcommand($self->_command => $subparser); $self->namespace->set_attr(current_command => $self->_command); } if (!$parsed_subcmd) { $self->_parse_optional_args(\@option_specs) if @option_specs; $self->_parse_positional_args(\@position_specs) if @position_specs; if ($self->print_usage_if_help() && $self->namespace->get_attr('help')) { $self->print_usage(); exit(0); } } else { if ($self->print_usage_if_help() && $self->_command() eq 'help') { if ($self->namespace->get_attr('help_command')) { $self->print_command_usage(); exit(0); } else { $self->print_usage(); exit(0); } } } # Return value return $self->namespace; } sub _get_subcommand_parser { my $self = shift; my $alias = shift; return unless $alias; my $command = $self->{-subparsers}{-alias_map}{$alias} if exists $self->{-subparsers}{-alias_map}{$alias}; return unless $command; $self->_command($command); # The subcommand parser must exist if the alias is mapped return $self->{-subparsers}{-parsers}{$command}; } sub _parse_subcommand { my $self = shift; my ($cmd, $subparser) = @_; $subparser->namespace($self->namespace); $subparser->parse_args(@{$self->{-argv}}); $self->{-argv} = $subparser->{-argv}; return 1; } # # After each call of parse_args(), call this to retrieve any # unconsumed arguments # Interface call # sub argv { @{ $_[0]->{-argv} || [] }; } sub _parse_optional_args { my $self = shift; my $specs = shift; my $options = {}; my $dest2spec = {}; for my $spec ( @$specs ) { my @values; $dest2spec->{$spec->{dest}} = $self->_get_option_spec($spec); if ( $spec->{type} == TYPE_ARRAY || $spec->{type} == TYPE_COUNT || $spec->{type} == TYPE_PAIR || $spec->{type} == TYPE_SCALAR ) { my @values; $options->{ $dest2spec->{$spec->{dest}} } = \@values; } else { my $value; $options->{ $dest2spec->{$spec->{dest}} } = \$value; } } Getopt::Long::Configure( @{ $self->parser_configs }); my (@warns, $result); eval { local $SIG{__WARN__} = sub { push @warns, @_ }; local $SIG{__DIE__}; $result = GetOptionsFromArray( $self->{-argv}, %$options ); 1; }; # die on errors _croak $self->error_prefix, $@ if $@; _croak $self->error_prefix, @warns if @warns; _croak $self->error_prefix, 'Failed to parse for options' if !$result; Getopt::Long::Configure('default'); $self->_post_parse_processing($specs, $options, $dest2spec); $self->_apply_action($specs, $options, $dest2spec); $self->_post_apply_processing($specs, $options, $dest2spec); } sub _parse_positional_args { my $self = shift; my $specs = shift; # short-circuit it if it's for help return if $self->namespace->get_attr('help'); my $options = {}; my $dest2spec = {}; for my $spec (@$specs) { $dest2spec->{$spec->{dest}} = $spec->{dest}; my @values = (); # Always assigne values to an option $options->{$spec->{dest}} = \@values; } POSITION_SPEC: for my $spec (@$specs) { my $values = $options->{$spec->{dest}}; if ($spec->{type} == TYPE_BOOL) { _croak $self->error_prefix . 'Bool not allowed for positional arguments'; } my $number = 1; my $nargs = defined $spec->{nargs} ? $spec->{nargs} : 1; if (defined $spec->{nargs}) { if ($nargs eq '?') { $number = 1; } elsif ($nargs eq '+') { _croak $self->error_prefix . "Too few arguments: narg='+'" unless @{$self->{-argv}}; $number = scalar @{$self->{-argv}}; } elsif ($nargs eq '*') { # remainder $number = scalar @{$self->{-argv}}; } elsif ($nargs !~ /^\d+$/) { _croak $self->error_prefix . 'Invalid nargs:' . $nargs; } else { $number = $nargs; } } push @$values, splice(@{$self->{-argv}}, 0, $number) if @{$self->{-argv}}; # If no values, let it pass for required checking # If there are values, make sure there is the right number of # values if (scalar(@$values) && scalar(@$values) != $number) { _croak($self->error_prefix . sprintf( 'Too few arguments for %s: expected:%d,actual:%d', $spec->{dest}, $number, scalar(@$values), ) ); } } $self->_post_parse_processing($specs, $options, $dest2spec); $self->_apply_action($specs, $options, $dest2spec); $self->_post_apply_processing($specs, $options, $dest2spec); } # sub _post_parse_processing { my $self = shift; my ($option_specs, $options, $dest2spec) = @_; # for my $spec ( @$option_specs ) { my $values = $options->{ $dest2spec->{$spec->{dest}} }; if (defined($values)) { if (ref $values eq 'SCALAR') { if (defined($$values)) { $values = [ $$values ]; } else { $values = []; } } } else { $values = []; } $options->{ $dest2spec->{$spec->{dest}} } = $values; # default if (!defined($self->namespace->get_attr($spec->{dest})) && scalar(@$values) < 1 && defined($spec->{default}) ) { if ($spec->{type} == TYPE_COUNT) { $self->namespace->set_attr($spec->{dest}, @{$spec->{default}}); } elsif ($spec->{type} == TYPE_BOOL) { $self->namespace->set_attr($spec->{dest}, @{$spec->{default}}); } elsif ($spec->{type} == TYPE_PAIR) { $self->namespace->set_attr($spec->{dest}, $spec->{default}); } else { push @$values, @{$spec->{default}}; } } # split and expand # Pair are processed here as well if ( my $delimit = $spec->{split} ) { my @expanded; for my $v (@$values) { push @expanded, map { $spec->{type} == TYPE_PAIR ? { split('=', $_) } : $_ } split($delimit, $v); } $options->{ $dest2spec->{$spec->{dest} } } = \@expanded; } else { # Process PAIR only if ($spec->{type} == TYPE_PAIR) { $options->{ $dest2spec->{$spec->{dest} } } = [ map { { split('=', $_) } } @$values ]; } } # choices if ( $spec->{choices} ) { if (ref($spec->{choices}) eq 'CODE') { for my $v (@$values) { $spec->{choices}->($v); } } else { my %choices = map { defined($_) ? $_ : '_undef' => 1 } @{$spec->{choices}}; VALUE: for my $v (@$values) { my $k = defined($v) ? $v : '_undef'; next VALUE if exists $choices{$k}; _croak $self->error_prefix . sprintf( "Option %s value %s not in choices: [ %s ]", $spec->{dest}, $v, join( ', ', @{ $spec->{choices} } ), ); } } } if ( $spec->{choices_i} ) { my %choices = map { defined($_) ? uc($_) : '_undef' => 1 } @{$spec->{choices_i}}; VALUE: for my $v (@$values) { my $k = defined($v) ? uc($v) : '_undef'; next VALUE if exists $choices{$k}; _croak $self->error_prefix . sprintf( "Option %s value %s not in choices: [ %s ] (case insensitive)", $spec->{dest}, $v, join( ', ', @{ $spec->{choices_i} } ), ); } } } return ''; } sub _apply_action { my $self = shift; my ($specs, $options, $dest2spec) = @_; for my $spec (@$specs) { # Init # We want to preserve already set attributes if the namespace # is passed in. # # This is because one may want to load configs from a file # into a namespace and then use the same namespace for parsing # configs from command line. # $self->namespace->set_attr($spec->{dest}, undef) unless defined($self->namespace->get_attr($spec->{dest})); my $error = $spec->{action}->apply( $spec, $self->namespace, $options->{ $dest2spec->{$spec->{dest}} }, $spec->{name}, ); _croak $self->error_prefix . $error if $error; } return ''; } sub _post_apply_processing { my $self = shift; my ($specs, $options, $dest2spec) = @_; # # required is checked after applying actions # This is because required checking is bypassed if help is on # for my $spec (@$specs) { my $v = $self->namespace->get_attr($spec->{dest}); # required if ( $spec->{required} && not $self->namespace->get_attr('help') ) { my $has_v; if ($spec->{type} == TYPE_ARRAY) { $has_v = @$v; } elsif ($spec->{type} == TYPE_PAIR) { $has_v = scalar(keys %$v); } else { $has_v = defined $v; } _croak $self->error_prefix . sprintf("Option %s is required\n", $spec->{dest}) unless $has_v; } } } # interface sub print_usage { my $self = shift; my $usage = $self->format_usage(); print STDERR $_, "\n" for @$usage; } # interface sub print_command_usage { my $self = shift; my $command = shift || $self->namespace->get_attr('help_command') || $self->namespace->get_attr('current_command'); # running help command my $usage = $self->format_command_usage($command); if ($usage) { print STDERR $_, "\n" for @$usage; } else { print STDERR $self->error_prefix, sprintf('No help for %s. See help', $self->namespace->get_attr('help_command')), "\n"; } } # Interface sub format_usage { my $self = shift; $self->_sort_specs_by_groups() unless $self->{-groups}; my $old_wrap_columns = $Text::Wrap::columns; my @usage; my $aliases = $self->aliases; my $prog = $self->prog; $prog .= ' (' . join(', ', @$aliases) . ')' if @$aliases; if( $self->help ) { push @usage, wrap('', '', $prog. ': ' . $self->help); push @usage, ''; } my ($help, $option_string) = $self->_format_group_usage(); $Text::Wrap::columns = 80; my $header = sprintf( 'usage: %s %s', $self->prog, $option_string ); push @usage, wrap('', '', $header); if ($self->description) { my @lines = split("\n", $self->description); my @paragraphs; my $para = ''; for my $line (@lines) { if ($line =~ /^\s*$/) { push @paragraphs, $para; $para = ''; } else { $para .= ( $para ? ' ' : '' ) . $line; } } push @paragraphs, $para; for (@paragraphs) { push @usage, ''; push @usage, wrap('', '', $_); } } push @usage, @$help; if (exists $self->{-subparsers}) { push @usage, ''; push @usage, wrap('', '', $self->{-subparsers}{-title}); push @usage, wrap('', '', $self->{-subparsers}{-description}) if $self->{-subparsers}{-description}; my $max = 12; for my $command ( keys %{$self->{-subparsers}{-parsers}} ) { my $len = length($command); $max = $len if $len > $max; } for my $command ( sort keys %{$self->{-subparsers}{-parsers}} ) { my $parser = $self->{-subparsers}{-parsers}{$command}; my $tab_head = ' ' x ( $max + 2 ); my @desc = split("\n", wrap('', '', $parser->help)); my $desc = (shift @desc) || ''; $_ = $tab_head . $_ for @desc; push @usage, sprintf(" %-${max}s %s", $command, join("\n", $desc, @desc)); } } push @usage, '', wrap('', '', $self->epilog) if $self->epilog; $Text::Wrap::columns = $old_wrap_columns; # restore to original return \@usage; } sub format_command_usage { my $self = shift; my $alias = shift; my $subp = $self->_get_subcommand_parser($alias); return '' unless $subp; return $subp->format_usage(); } # FIXME: Maybe we should remove this grouping thing sub _sort_specs_by_groups { my $self = shift; my $specs = $self->{-option_specs}; for my $dest ( keys %{ $specs } ) { for my $group ( @{ $specs->{$dest}{groups} } ) { push @{ $self->{-groups}{$group}{-option} }, $specs->{$dest}; } } $specs = $self->{-position_specs}; for my $dest ( keys %{ $specs } ) { for my $group ( @{ $specs->{$dest}{groups} } ) { push @{ $self->{-groups}{$group}{-position} }, $specs->{$dest}; } } } # This funtion finds the help argument and moves it # to the front of the optional parameters sub _move_help_after_required { my @option_spec = @_; my ($help, $i); $i=0; foreach my $element (@option_spec) { if ($element->{'position'} == 0) { $help = splice @option_spec, $i, 1; last; } $i++; } $i=0; foreach my $element (@option_spec) { if (!$element->{required}) { splice @option_spec, $i, 0, $help; last; } $i++; } return @option_spec; } sub _format_group_usage { my $self = shift; my $group = ''; unless ($self->{-groups}) { $self->_sort_specs_by_groups(); } my $old_wrap_columns = $Text::Wrap::columns; $Text::Wrap::columns = 80; my @usage; my @option_specs; # When doing a sort by name, it puts all required parameters # first sorted by name, then all optional parameters sorted by name if ($self->sortby eq 'name') { @option_specs = sort { ($b->{required} cmp $a->{required} || $a->{name} cmp $b->{name}) } @{ $self->{-groups}{$group}{-option} || [] }; @option_specs = _move_help_after_required(@option_specs); } elsif($self->sortby eq 'position') { @option_specs = sort { ($b->{required} cmp $a->{required} || $b->{position} <=> $a->{position} ) } @{ $self->{-groups}{$group}{-option} || [] }; @option_specs = _move_help_after_required(@option_specs); } my @flag_items = map { ($_->{required} ? '' : '[') . join('|', @{$_->{flags}}) . ($_->{required} ? '' : ']') } @option_specs; my @position_specs = sort { $a->{position} <=> $b->{position} } @{ $self->{-groups}{$group}{-position} || [] }; my @position_items = map { ($_->{required} ? '' : '[') . $_->{metavar} . ($_->{required} ? '' : ']') } @position_specs; my @subcommand_items = ('', '[]') if exists $self->{-subparsers}; if ($group) { push @usage, wrap('', '', $group . ': ' . ($self->{-group_description}{$group} || '') ); } # named arguments are arguments preceded by a hyphen as optional # vs. positional are too confusing. for my $spec_name ( [ \@position_specs, 'positional' ], [ \@option_specs, 'named' ]) { my ($specs, $spec_name) = @$spec_name; for my $type_name ( [ PRINT_REQUIRED, 'required'], [ PRINT_OPTIONAL, 'optional'] ) { my ($type, $type_name) = @$type_name; my $output = $self->_format_usage_by_spec($specs, $type); if (@$output) { push @usage, ''; # Start a section: e.g. required positional arguments: push @usage, sprintf('%s %s arguments:', $type_name, $spec_name); push @usage, @$output; } } } $Text::Wrap::columns = $old_wrap_columns; # restore to original return ( \@usage, join(' ', @position_items, @flag_items, @subcommand_items) ) ; } sub _format_usage_by_spec { my $self = shift; my $specs = shift; my $print_type = shift; return unless $specs; my @usage; my $max = 10; my @item_help; SPEC: for my $spec ( @$specs ) { next SPEC if ($print_type == PRINT_OPTIONAL && $spec->{'required'}) || ($print_type == PRINT_REQUIRED && !$spec->{'required'}); my $item = $spec->{metavar}; if (@{$spec->{flags}}) { $item = sprintf( "%s %s", join(', ', @{$spec->{flags}}), $spec->{metavar}, ); } my $len = length($item); $max = $len if $len > $max; # generate default string my $default = ''; my $values = []; if (defined $spec->{default}) { if (ref $spec->{default} eq 'HASH') { while (my ($k, $v) = each %{$spec->{default}}) { push @$values, "$k=$v"; } } elsif (ref $spec->{default} eq 'ARRAY') { $values = $spec->{default}; } else { $values = [ $spec->{default} ]; } } if (@$values) { $default = 'Default: ' . join(', ', @$values); } # generate choice string my $choices; my $case = ''; if ($spec->{choices} && ref $spec->{choices} ne 'CODE') { $choices = $spec->{choices}; $case = 'case sensitive'; } elsif ($spec->{choices_i}) { $choices = $spec->{choices_i}; $case = 'case insensitive'; } else { $choices = undef; } my $choice_str = ''; if ($choices) { $choice_str = 'Choices: [' . join(', ', @$choices) . '], ' . $case . "\n"; } push @item_help, [ $item, ($spec->{required} ? ' ' : '?'), join("\n", ($spec->{help} || 'This is option ' . $spec->{dest}), $choice_str . $default), ]; } my $format = " %-${max}s %s %s"; $Text::Wrap::columns = 60; for my $ih (@item_help) { my $item_len = length($ih->[0]); # The prefixed whitespace in subsequent lines in the wrapped # help string my $sub_tab = " " x ($max + 4 + 4 + 2); my @help = split("\n", wrap('', '', $ih->[2])); my $help = (shift @help) || '' ; # head $_ = $sub_tab . $_ for @help; # tail push @usage, sprintf($format, $ih->[0], $ih->[1], join("\n", $help, @help)); } return \@usage; } # translate option spec to the one accepted by # Getopt::Long::GetOptions sub _get_option_spec { my $self = shift; my $spec = shift; my @flags = @{ $spec->{flags} }; $_ =~ s/^-+// for @flags; my $name = join('|', @flags); my $type = 's'; my $desttype = ''; my $optional_flag = '='; # not optional if ($spec->{type} == TYPE_SCALAR) { $desttype = '@'; } elsif ($spec->{type} == TYPE_ARRAY) { $desttype = '@'; } elsif ($spec->{type} == TYPE_PAIR) { $desttype = '@'; } elsif ($spec->{type} == TYPE_UNDEF) { $optional_flag = ':'; } elsif ($spec->{type} == TYPE_BOOL) { $type = ''; $optional_flag = ''; $desttype = ''; } elsif ($spec->{type} == TYPE_COUNT) { # pass $type = ''; $optional_flag = ''; $desttype = '+'; } else { # pass # should never be here _croak $self->error_prefix . 'Unknown type:' . ($spec->{type} || 'undef'); } my $repeat = ''; my $opt = join('', $name, $optional_flag, $type, $repeat, $desttype); return $opt; } 1; __END__ =head1 AUTHOR Mytram (original author) =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Mytram. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut