Commit 8c5dcf801c1c709475db1a493de178aac2b94da9 - libgetopt-lucid-perl

+8

-0

Changes less more

0	0	Revision history for Perl module Getopt::Lucid
	1
	2	1.00 2011-12-10 23:32:42 EST5EDT
	3
	4	- new() takes optional hashref of parameters
	5	- Remove global $STRICT and replace with 'strict' object parameter
	6	- Remove 'required' modifier for parameters and provide a new
	7	'validate' method for late checking of prerequisites
	8	- Fix missing $VERSION
1	9
2	10	0.19 2010-11-05 17:07:26 EST5EDT
3	11

+1

-1

LICENSE less more

0		This software is Copyright (c) 2010 by David Golden.
	0	This software is Copyright (c) 2011 by David Golden.
1	1
2	2	This is free software, licensed under:
3	3

+4

-0

MANIFEST less more

4	4	META.yml
5	5	Makefile.PL
6	6	README
	7	README.PATCHING
7	8	Todo
8	9	dist.ini
9	10	examples/cpanget
10	11	lib/Getopt/Lucid.pm
11	12	lib/Getopt/Lucid/Exception.pm
	13	perlcritic.rc
12	14	t/00-compile.t
13	15	t/00-new.t
14	16	t/01-exceptions.t

22	24	t/09-negation.t
23	25	t/10-default-validation.t
24	26	t/ErrorMessages.pm
	27	xt/author/critic.t
25	28	xt/release/distmeta.t
26	29	xt/release/pod-coverage.t
27	30	xt/release/pod-syntax.t
28	31	xt/release/portability.t
	32	xt/release/test-version.t

+17

-11

META.json less more

3	3	"David Golden <dagolden@cpan.org>"
4	4	],
5	5	"dynamic_config" : 0,
6		"generated_by" : "Dist::Zilla version 4.102341, CPAN::Meta::Converter version 2.102400",
	6	"generated_by" : "Dist::Zilla version 4.300003, CPAN::Meta::Converter version 2.112580",
7	7	"license" : [
8	8	"apache_2_0"
9	9	],

26	26	"prereqs" : {
27	27	"configure" : {
28	28	"requires" : {
29		"ExtUtils::MakeMaker" : "6.31"
	29	"ExtUtils::MakeMaker" : "6.30"
30	30	}
31	31	},
32	32	"runtime" : {

36	36	"Exporter" : 0,
37	37	"Storable" : "2.16",
38	38	"perl" : "5.006",
39		"vars" : 0
	39	"strict" : 0,
	40	"warnings" : 0
40	41	}
41	42	},
42	43	"test" : {

45	46	"Exception::Class::TryCatch" : "1.10",
46	47	"File::Find" : 0,
47	48	"File::Temp" : 0,
48		"Test::More" : "0.62"
	49	"Test::More" : "0.62",
	50	"vars" : 0
49	51	}
50	52	}
51	53	},
52	54	"provides" : {
53	55	"Getopt::Lucid" : {
54	56	"file" : "lib/Getopt/Lucid.pm",
55		"version" : "0.19"
	57	"version" : "1.00"
56	58	},
57	59	"Getopt::Lucid::Exception" : {
58	60	"file" : "lib/Getopt/Lucid/Exception.pm",
59		"version" : "0.19"
	61	"version" : "1.00"
60	62	},
61	63	"Getopt::Lucid::Spec" : {
62	64	"file" : "lib/Getopt/Lucid.pm",
63		"version" : "0.19"
	65	"version" : "1.00"
64	66	}
65	67	},
66	68	"release_status" : "stable",
67	69	"resources" : {
68		"homepage" : "http://github.com/dagolden/getopt-lucid/tree",
	70	"bugtracker" : {
	71	"mailto" : "bug-getopt-lucid at rt.cpan.org",
	72	"web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Lucid"
	73	},
	74	"homepage" : "https://github.com/dagolden/getopt-lucid",
69	75	"repository" : {
70	76	"type" : "git",
71		"url" : "git://github.com/dagolden/getopt-lucid.git",
72		"web" : "http://github.com/dagolden/getopt-lucid/tree"
	77	"url" : "https://github.com/dagolden/getopt-lucid.git",
	78	"web" : "https://github.com/dagolden/getopt-lucid"
73	79	}
74	80	},
75		"version" : "0.19"
	81	"version" : "1.00"
76	82	}
77	83

+12

-9

META.yml less more

7	7	File::Find: 0
8	8	File::Temp: 0
9	9	Test::More: 0.62
	10	vars: 0
10	11	configure_requires:
11		ExtUtils::MakeMaker: 6.31
	12	ExtUtils::MakeMaker: 6.30
12	13	dynamic_config: 0
13		generated_by: 'Dist::Zilla version 4.102341, CPAN::Meta::Converter version 2.102400'
	14	generated_by: 'Dist::Zilla version 4.300003, CPAN::Meta::Converter version 2.112580'
14	15	license: apache
15	16	meta-spec:
16	17	url: http://module-build.sourceforge.net/META-spec-v1.4.html

27	28	provides:
28	29	Getopt::Lucid:
29	30	file: lib/Getopt/Lucid.pm
30		version: 0.19
	31	version: 1.00
31	32	Getopt::Lucid::Exception:
32	33	file: lib/Getopt/Lucid/Exception.pm
33		version: 0.19
	34	version: 1.00
34	35	Getopt::Lucid::Spec:
35	36	file: lib/Getopt/Lucid.pm
36		version: 0.19
	37	version: 1.00
37	38	requires:
38	39	Carp: 0
39	40	Exception::Class: 1.23
40	41	Exporter: 0
41	42	Storable: 2.16
42	43	perl: 5.006
43		vars: 0
	44	strict: 0
	45	warnings: 0
44	46	resources:
45		homepage: http://github.com/dagolden/getopt-lucid/tree
46		repository: git://github.com/dagolden/getopt-lucid.git
47		version: 0.19
	47	bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Lucid
	48	homepage: https://github.com/dagolden/getopt-lucid
	49	repository: https://github.com/dagolden/getopt-lucid.git
	50	version: 1.00

+27

-25

Makefile.PL less more

1	1	use strict;
2	2	use warnings;
3	3
4		BEGIN { require 5.006; }
	4	use 5.006;
5	5
6		use ExtUtils::MakeMaker 6.31;
	6	use ExtUtils::MakeMaker 6.30;
7	7
8	8
9	9
10	10	my %WriteMakefileArgs = (
11		'ABSTRACT' => 'Clear, readable syntax for command line processing',
12		'AUTHOR' => 'David Golden <dagolden@cpan.org>',
13		'BUILD_REQUIRES' => {
14		'Data::Dumper' => '0',
15		'Exception::Class::TryCatch' => '1.10',
16		'File::Find' => '0',
17		'File::Temp' => '0',
18		'Test::More' => '0.62'
	11	"ABSTRACT" => "Clear, readable syntax for command line processing",
	12	"AUTHOR" => "David Golden <dagolden\@cpan.org>",
	13	"BUILD_REQUIRES" => {
	14	"Data::Dumper" => 0,
	15	"Exception::Class::TryCatch" => "1.10",
	16	"File::Find" => 0,
	17	"File::Temp" => 0,
	18	"Test::More" => "0.62",
	19	"vars" => 0
19	20	},
20		'CONFIGURE_REQUIRES' => {
21		'ExtUtils::MakeMaker' => '6.31'
	21	"CONFIGURE_REQUIRES" => {
	22	"ExtUtils::MakeMaker" => "6.30"
22	23	},
23		'DISTNAME' => 'Getopt-Lucid',
24		'EXE_FILES' => [],
25		'LICENSE' => 'apache',
26		'NAME' => 'Getopt::Lucid',
27		'PREREQ_PM' => {
28		'Carp' => '0',
29		'Exception::Class' => '1.23',
30		'Exporter' => '0',
31		'Storable' => '2.16',
32		'vars' => '0'
	24	"DISTNAME" => "Getopt-Lucid",
	25	"EXE_FILES" => [],
	26	"LICENSE" => "apache",
	27	"NAME" => "Getopt::Lucid",
	28	"PREREQ_PM" => {
	29	"Carp" => 0,
	30	"Exception::Class" => "1.23",
	31	"Exporter" => 0,
	32	"Storable" => "2.16",
	33	"strict" => 0,
	34	"warnings" => 0
33	35	},
34		'VERSION' => '0.19',
35		'test' => {
36		'TESTS' => 't/*.t'
	36	"VERSION" => "1.00",
	37	"test" => {
	38	"TESTS" => "t/*.t"
37	39	}
38	40	);
39	41

+90

-16

README less more

1	1	Getopt::Lucid - Clear, readable syntax for command line processing
2	2
3	3	VERSION
4		version 0.19
	4	version 1.00
5	5
6	6	SYNOPSIS
7	7	use Getopt::Lucid qw( :all );

17	17	Switch("help\|h")
18	18	);
19	19
20		$opt = Getopt::Lucid->getopt( \@specs );
	20	$opt = Getopt::Lucid->getopt( \@specs )->validate;
21	21
22	22	$verbosity = $opt->get_verbose;
23	23	@libs = $opt->get_lib;

28	28	# advanced option specifications
29	29
30	30	@adv_spec = (
31		Param("input")->required, # required
	31	Param("input"),
32	32	Param("mode")->default("tcp"), # defaults
33	33	Param("host")->needs("port"), # dependencies
34	34	Param("port")->valid(qr/\d+/), # regex validation
35	35	Param("config")->valid(sub { -r }),# custom validation
36	36	Param("help")->anycase, # case insensitivity
37	37	);
	38	$opt = Getopt::Lucid->getopt( \@adv_spec );
	39	$opt->validate( 'requires' => ['input'] );
38	40
39	41	# example with a config file
40	42
	43	$opt = Getopt::Lucid->getopt( \@adv_spec );
41	44	use Config::Std;
42	45	if ( -r $opt->get_config ) {
43	46	read_config( $opt->get_config() => my %config_hash );

105	108	In practice, this means that the specification need not use dashes, but
106	109	if used on the command line, they will be treated appropriately.
107	110
108		Alternatively, Getopt::Lucid can operate in "strict" mode by setting
109		$Getopt::Lucid::STRICT to a true value. In strict mode, option names and
	111	Alternatively, Getopt::Lucid can operate in "strict" mode by setting the
	112	C<strict> parameter to a true value. In strict mode, option names and
110	113	aliases may still be specified in any of the three styles, but they will
111	114	only be parsed from the command line if they are used in exactly the
112	115	same style. E.g., given the name and alias "--help\|-h", only "--help"

228	231	);
229	232
230	233	Validation
	234	Validation happens in two stages. First, individual parameters may have
	235	validation criteria added to them. Second, the parsed options object may
	236	be validated by checking that all requirements or prerequires are met.
	237
	238	Parameter validation
231	239	The Param, List, and Keypair option types may be provided an optional
232	240	validation specification. Values provided on the command line will be
233	241	validated according to the specification or an exception will be thrown.

246	254	If no default is explictly provided, validation is only applied if the
247	255	option appears on the command line. (In other words, the built-in
248	256	defaults are always considered valid if the option does not appear.) If
249		this is not desired, the "required()" modifier should be used to force
250		users to provide an explicit value.
	257	this is not desired, the "required" option to the "validate" method
	258	should be used to force users to provide an explicit value.
251	259
252	260	# Must be provided and is thus always validated
253		Param("width")->valid(qr/\d+/)->required
254
255		# Can be left blank, but is validated if provided
256		Param("height")->valid(qr/\d+/)
	261	@spec = ( Param("width")->valid(qr/\d+/) );
	262	$opt = Getopt::Lucid->getopt(\@spec);
	263	$opt->validate( {requires => ['width']} );
257	264
258	265	For validation subroutines, the value found on the command line is
259	266	passed as the first element of @_, and $_ is also set equal to the first

269	276
270	277	# deprecated
271	278	Param("height", qr/\d+/)
	279
	280	Options object validation
	281	The "validate" method should be called on the result of "getopt". This
	282	will check that all parameter prerequisites defined by "needs" have been
	283	met. It also takes a hashref of arguments. The optional "requires"
	284	argument gives an arrayref of parameters that must exist.
	285
	286	The reason that object validation is done separate from "getopt" is to
	287	allow for better control over different options that might be required
	288	or to allow some dependencies (i.e. from "needs") to be met via a
	289	configuration file.
	290
	291	@spec = (
	292	Param("action")->needs(qw/user password/),
	293	Param("user"),
	294	Param("password"),
	295	);
	296	$opt = Getopt::Lucid->getopt(\@spec);
	297	$opt->merge_defaults( read_config() ); # provides 'user' & 'password'
	298	$opt->validate({requires => ['action']});
272	299
273	300	Parsing the Command Line
274	301	Technically, Getopt::Lucid scans an array for command line options, not

338	365	accessor calls. E.g.
339	366
340	367	@spec = (
341		Param("--input-file\|-i")->required(),
	368	Param("--input-file\|-i")
342	369	);
343	370
344	371	$opt = Getopt::Long->getopt( \@spec );

470	497	METHODS
471	498	new()
472	499	$opt = Getopt::Lucid->new( \@option_spec );
	500	$opt = Getopt::Lucid->new( \@option_spec, \%parameters );
473	501	$opt = Getopt::Lucid->new( \@option_spec, \@option_array );
	502	$opt = Getopt::Lucid->new( \@option_spec, \@option_array, \%parameters );
474	503
475	504	Creates a new Getopt::Lucid object. An array reference to an option spec
476	505	is required as an argument. (See "USAGE" for a description of the object
477	506	spec). By default, objects will be set to read @ARGV for command line
478	507	options. An optional second argument with a reference to an array will
479		use that array for option processing instead. For typical cases, users
480		will likely prefer to call "getopt" instead, which creates a new object
481		and parses the command line with a single function call.
	508	use that array for option processing instead. The final argument may be
	509	a hashref of parameters. The only valid parameter currently is:
	510
	511	* strict -- enables strict mode when true
	512
	513	For typical cases, users will likely prefer to call "getopt" instead,
	514	which creates a new object and parses the command line with a single
	515	function call.
	516
	517	validate()
	518	$opt->validate();
	519	$opt->validate( \%arguments );
	520
	521	Takes an optional argument hashref, validates that all requirements and
	522	prerequisites are met or throws an error. Valid argument keys are:
	523
	524	* "requires" -- an arrayref of options that must exist in the options
	525	object.
	526
	527	This method returns the object for convenient chaining:
	528
	529	$opt = Getopt::Lucid->getopt(\@spec)->validate;
482	530
483	531	append_defaults()
484	532	%options = append_defaults( %config_hash );

563	611	options. This undoes the effect of a "merge_defaults" or "add_defaults"
564	612	call.
565	613
	614	API CHANGES
	615	In 1.00, the following API changes have been made:
	616
	617	* "new()" now takes an optional hashref of parameters as the last
	618	argument
	619
	620	* The global $STRICT variable has been replaced with a per-object
	621	parameter "strict"
	622
	623	* The "required" modifier has been removed and a new "validate" method
	624	has been added to facilitate late/custom checks of required options
	625
566	626	SEE ALSO
567	627	* Config::Tiny
568	628

582	642	When submitting a bug or request, please include a test-file or a patch
583	643	to an existing test-file that illustrates the bug or desired feature.
584	644
	645	SUPPORT
	646	Bugs / Feature Requests
	647	Please report any bugs or feature requests through the issue tracker at
	648	<http://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Lucid>. You
	649	will be notified automatically of any progress on your issue.
	650
	651	Source Code
	652	This is open source software. The code repository is available for
	653	public review and contribution under the terms of the license.
	654
	655	<https://github.com/dagolden/getopt-lucid>
	656
	657	git clone https://github.com/dagolden/getopt-lucid.git
	658
585	659	AUTHOR
586	660	David Golden <dagolden@cpan.org>
587	661
588	662	COPYRIGHT AND LICENSE
589		This software is Copyright (c) 2010 by David Golden.
	663	This software is Copyright (c) 2011 by David Golden.
590	664
591	665	This is free software, licensed under:
592	666

+42

-0

README.PATCHING less more

	0	README.PATCHING
	1
	2	Thank you for considering contributing to this distribution. This file
	3	contains instructions that will help you work with the source code.
	4
	5	The distribution is managed with Dist::Zilla. This means than many of the
	6	usual files you might expect are not in the repository, but are generated
	7	at release time (e.g. Makefile.PL).
	8
	9	However, you can run tests directly using the 'prove' tool:
	10
	11	$ prove -l
	12	$ prove -lv t/some_test_file.t
	13
	14	For most distributions, 'prove' is entirely sufficent for you to test any
	15	patches you have.
	16
	17	Likewise, much of the documentation Pod is generated at release time.
	18	Depending on the distribution, some documentation may be written in a Pod
	19	dialect called WikiDoc. (See Pod::WikiDoc on CPAN.) If you would like to
	20	submit a documentation edit, please limit yourself to the documentation you
	21	see.
	22
	23	If you see typos or documentation issues in the generated docs, please
	24	email or open a bug ticket instead of patching.
	25
	26	Dist::Zilla is a very powerful authoring tool, but requires a number of
	27	author-specific plugins. If you would like to use it for contributing,
	28	install it from CPAN, then run one of the following commands, depending on
	29	your CPAN client:
	30
	31	$ cpan `dzil authordeps`
	32	$ dzil authordeps \| cpanm
	33
	34	Once installed, here are some dzil commands you might try:
	35
	36	$ dzil build
	37	$ dzil test
	38	$ dzil xtest
	39
	40	You can learn more about Dist::Zilla at http://dzil.org/
	41

+0

-1

Todo less more

35	35	# Bugfixes/technical/other
36	36	#--------------------------------------------------------------------------#
37	37
38		- make STRICT an object parameter, not a global
39	38	- test how negation is handled under $STRICT
40	39	- write cookbook
41	40	- refactor ugly code (module and tests)

+3

-1

dist.ini less more

3	3	copyright_holder = David Golden
4	4
5	5	[@DAGOLDEN]
6		git_remote = github
	6	:version = 0.018
7	7
	8	[Test::Perl::Critic]
	9

+0

-9

examples/cpanget less more

0	0	#!/usr/bin/env perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1	use strict;
11	2	use warnings;
12	3

+3

-14

lib/Getopt/Lucid/Exception.pm less more

0		#
1		# This file is part of Getopt-Lucid
2		#
3		# This software is Copyright (c) 2010 by David Golden.
4		#
5		# This is free software, licensed under:
6		#
7		# The Apache License, Version 2.0, January 2004
8		#
9	0	use 5.006;
10	1	use strict;
11	2	use warnings;
12	3	package Getopt::Lucid::Exception;
13		BEGIN {
14		$Getopt::Lucid::Exception::VERSION = '0.19';
15		}
16	4	# ABSTRACT: Exception classes for Getopt::Lucid
	5	our $VERSION = '1.00'; # VERSION
17	6
18	7	use Exception::Class 1.23 (
19	8	"Getopt::Lucid::Exception" => {

58	47
59	48	=head1 VERSION
60	49
61		version 0.19
	50	version 1.00
62	51
63	52	=head1 AUTHOR
64	53

66	55
67	56	=head1 COPYRIGHT AND LICENSE
68	57
69		This software is Copyright (c) 2010 by David Golden.
	58	This software is Copyright (c) 2011 by David Golden.
70	59
71	60	This is free software, licensed under:
72	61

+156

-56

lib/Getopt/Lucid.pm less more

0		#
1		# This file is part of Getopt-Lucid
2		#
3		# This software is Copyright (c) 2010 by David Golden.
4		#
5		# This is free software, licensed under:
6		#
7		# The Apache License, Version 2.0, January 2004
8		#
9	0	use 5.006;
10	1	use strict;
11	2	use warnings;
12	3	package Getopt::Lucid;
13	4	# ABSTRACT: Clear, readable syntax for command line processing
	5	our $VERSION = '1.00'; # VERSION
14	6
15	7	our @EXPORT_OK = qw(Switch Counter Param List Keypair);
16	8	our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

31	23	my $SHORT_BUNDLE = qr/-[$VALID_STARTCHAR]{2,}/;
32	24	my $NEGATIVE = qr/(?:--)?no-/;
33	25
34		my @valid_keys = qw( name type required default nocase valid needs canon );
	26	my @valid_keys = qw( name type default nocase valid needs canon );
35	27	my @valid_types = qw( switch counter parameter list keypair);
36
37		use vars qw( $STRICT );
38		$STRICT = 0;
39
40	28
41	29	sub Switch {
42	30	return bless { name => shift, type => 'switch' },

62	50	return bless $self, "Getopt::Lucid::Spec";
63	51	}
64	52
65		package # hide from PAUSE
	53	package
66	54	Getopt::Lucid::Spec;
67		our $VERSION = $Getopt::Lucid::VERSION;
	55	$Getopt::Lucid::Spec::VERSION = $Getopt::Lucid::VERSION;
68	56
69	57	# alternate way to specify validation
70	58	sub valid {

75	63	return $self;
76	64	}
77	65
78		sub required { my $self = shift; $self->{required} = 1; return $self };
79
80	66	sub default {
81	67	my $self = shift;
82	68	my $type = $self->{type};

110	96	# new()
111	97	#--------------------------------------------------------------------------#
112	98
	99	my @params = qw/strict target/;
	100
113	101	sub new {
114	102	my ($class, $spec, $target) = @_;
	103	my $args = ref($_[-1]) eq 'HASH' ? pop(@_) : {};
	104	$args->{target} = ref($target) eq 'ARRAY' ? $target : \@ARGV;
	105	my $self = {};
	106	$self->{$_} = $args->{$_} for @params;
	107	$self->{raw_spec} = $spec;
	108	bless ($self, ref($class) ? ref($class) : $class);
115	109	throw_usage("Getopt::Lucid->new() requires an option specification array reference")
116		unless ref($spec) eq 'ARRAY';
117		my $self = bless ({}, ref($class) ? ref($class) : $class);
118		_parse_spec($self, $spec);
	110	unless ref($self->{raw_spec}) eq 'ARRAY';
	111	_parse_spec($self);
119	112	_set_defaults($self);
120	113	$self->{options} = {};
121	114	$self->{parsed} = [];
122	115	$self->{seen}{$_} = 0 for keys %{$self->{spec}};
123		$self->{target} = $target \|\| \@ARGV;
124	116	return $self;
125	117	}
126	118

192	184	if ( $self eq 'Getopt::Lucid' ) {
193	185	throw_usage("Getopt::Lucid->getopt() requires an option specification array reference")
194	186	unless ref($spec) eq 'ARRAY';
195		$self = new($self,$spec,$target)
	187	$self = new(@_)
196	188	}
197	189	my (@passthrough);
198	190	while (@{$self->{target}}) {

220	212	push @passthrough, $orig;
221	213	}
222	214	}
223		_check_required($self);
224		_check_prereqs($self);
225	215	_recalculate_options($self);
226	216	@{$self->{target}} = (@passthrough, @{$self->{target}});
227	217	return $self;
228	218	}
229	219
230	220	BEGIN { *getopts = \&getopt }; # handy alias
	221
	222	#--------------------------------------------------------------------------#
	223	# validate
	224	#--------------------------------------------------------------------------#
	225
	226	sub validate {
	227	my ($self, $arg) = @_;
	228	throw_usage("Getopt::Lucid->validate() takes an optional hashref argument")
	229	unless $arg && ref($arg) eq 'HASH';
	230
	231	for my $p ( @{$arg->{requires}} ) {
	232	throw_argv("Required option '$self->{spec}{$p}{canon}' not found")
	233	if ( ! $self->{seen}{$p} );
	234	}
	235	_check_prereqs($self);
	236
	237	return $self;
	238	}
231	239
232	240	#--------------------------------------------------------------------------#
233	241	# merge_defaults()

368	376	}
369	377
370	378	#--------------------------------------------------------------------------#
371		# _check_required()
372		#--------------------------------------------------------------------------#
373
374		sub _check_required {
375		my ($self) = @_;
376		for ( keys %{$self->{spec}} ) {
377		throw_argv("Required option '$self->{spec}{$_}{canon}' not found")
378		if ( $self->{spec}{$_}{required} && ! $self->{seen}{$_} );
379		}
380		}
381
382		#--------------------------------------------------------------------------#
383	379	# _counter()
384	380	#--------------------------------------------------------------------------#
385	381

397	393	sub _find_arg {
398	394	my ($self, $arg) = @_;
399	395
400		$arg =~ s/^-*// unless $STRICT;
	396	$arg =~ s/^-*// unless $self->{strict};
401	397	return $self->{alias_hr}{$arg} if exists $self->{alias_hr}{$arg};
402	398
403	399	for ( keys %{$self->{alias_nocase}} ) {

477	473	#--------------------------------------------------------------------------#
478	474
479	475	sub _parse_spec {
480		my ($self,$spec) = @_;
	476	my ($self) = @_;
	477	my $spec = $self->{raw_spec};
481	478	for my $opt ( @$spec ) {
482	479	my $name = $opt->{name};
483	480	my @names = split( /\\|/, $name );
484	481	$opt->{canon} = $names[0];
485	482	_validate_spec($self,\@names,$opt);
486		@names = map { s/^-*//; $_ } @names unless $STRICT; ## no critic
	483	@names = map { s/^-*//; $_ } @names unless $self->{strict}; ## no critic
487	484	for (@names) {
488	485	$self->{alias_hr}{$_} = $names[0];
489	486	$self->{alias_nocase}{$_} = $names[0] if $opt->{nocase};

669	666	my ($self,$names,$details) = @_;
670	667	for my $name ( @$names ) {
671	668	my $alt_name = $name;
672		$alt_name =~ s/^-*// unless $STRICT;
	669	$alt_name =~ s/^-*// unless $self->{strict};
673	670	throw_spec(
674	671	"'$name' is not a valid option name/alias"
675	672	) unless $name =~ /^$VALID_NAME$/;

775	772
776	773	=head1 VERSION
777	774
778		version 0.19
	775	version 1.00
779	776
780	777	=head1 SYNOPSIS
781	778

792	789	Switch("help\|h")
793	790	);
794	791
795		$opt = Getopt::Lucid->getopt( \@specs );
	792	$opt = Getopt::Lucid->getopt( \@specs )->validate;
796	793
797	794	$verbosity = $opt->get_verbose;
798	795	@libs = $opt->get_lib;

803	800	# advanced option specifications
804	801
805	802	@adv_spec = (
806		Param("input")->required, # required
	803	Param("input"),
807	804	Param("mode")->default("tcp"), # defaults
808	805	Param("host")->needs("port"), # dependencies
809	806	Param("port")->valid(qr/\d+/), # regex validation
810	807	Param("config")->valid(sub { -r }),# custom validation
811	808	Param("help")->anycase, # case insensitivity
812	809	);
	810	$opt = Getopt::Lucid->getopt( \@adv_spec );
	811	$opt->validate( 'requires' => ['input'] );
813	812
814	813	# example with a config file
815	814
	815	$opt = Getopt::Lucid->getopt( \@adv_spec );
816	816	use Config::Std;
817	817	if ( -r $opt->get_config ) {
818	818	read_config( $opt->get_config() => my %config_hash );

910	910	used on the command line, they will be treated appropriately.
911	911
912	912	Alternatively, Getopt::Lucid can operate in "strict" mode by setting
913		C<<< $Getopt::Lucid::STRICT >>> to a true value. In strict mode, option names
	913	the CE<lt>strictE<gt> parameter to a true value. In strict mode, option names
914	914	and aliases may still be specified in any of the three styles, but they
915	915	will only be parsed from the command line if they are used in exactly
916	916	the same style. E.g., given the name and alias "--helpE<verbar>-h", only "--help"

1043	1043
1044	1044	=head2 Validation
1045	1045
	1046	Validation happens in two stages. First, individual parameters may have
	1047	validation criteria added to them. Second, the parsed options object may be
	1048	validated by checking that all requirements or prerequires are met.
	1049
	1050	=head3 Parameter validation
	1051
1046	1052	The Param, List, and Keypair option types may be provided an optional
1047	1053	validation specification. Values provided on the command line will be
1048	1054	validated according to the specification or an exception will be thrown.

1060	1066	If no default is explictly provided, validation is only applied if the option
1061	1067	appears on the command line. (In other words, the built-in defaults are always
1062	1068	considered valid if the option does not appear.) If this is not desired, the
1063		C<<< required() >>> modifier should be used to force users to provide an explicit
1064		value.
	1069	C<<< required >>> option to the C<<< validate >>> method should be used to force users to
	1070	provide an explicit value.
1065	1071
1066	1072	# Must be provided and is thus always validated
1067		Param("width")->valid(qr/\d+/)->required
1068
1069		# Can be left blank, but is validated if provided
1070		Param("height")->valid(qr/\d+/)
	1073	@spec = ( Param("width")->valid(qr/\d+/) );
	1074	$opt = Getopt::Lucid->getopt(\@spec);
	1075	$opt->validate( {requires => ['width']} );
1071	1076
1072	1077	For validation subroutines, the value found on the command line is passed as
1073	1078	the first element of C<<< @_ >>>, and C<<< $_ >>> is also set equal to the first element.

1083	1088
1084	1089	# deprecated
1085	1090	Param("height", qr/\d+/)
	1091
	1092	=head3 Options object validation
	1093
	1094	The C<<< validate >>> method should be called on the result of C<<< getopt >>>. This will
	1095	check that all parameter prerequisites defined by C<<< needs >>> have been met. It
	1096	also takes a hashref of arguments. The optional C<<< requires >>> argument gives an
	1097	arrayref of parameters that must exist.
	1098
	1099	The reason that object validation is done separate from C<<< getopt >>> is to allow
	1100	for better control over different options that might be required or to allow
	1101	some dependencies (i.e. from C<<< needs >>>) to be met via a configuration file.
	1102
	1103	@spec = (
	1104	Param("action")->needs(qw/user password/),
	1105	Param("user"),
	1106	Param("password"),
	1107	);
	1108	$opt = Getopt::Lucid->getopt(\@spec);
	1109	$opt->merge_defaults( read_config() ); # provides 'user' & 'password'
	1110	$opt->validate({requires => ['action']});
1086	1111
1087	1112	=head2 Parsing the Command Line
1088	1113

1152	1177	calls. E.g.
1153	1178
1154	1179	@spec = (
1155		Param("--input-file\|-i")->required(),
	1180	Param("--input-file\|-i")
1156	1181	);
1157	1182
1158	1183	$opt = Getopt::Long->getopt( \@spec );

1322	1347	=head2 new()
1323	1348
1324	1349	$opt = Getopt::Lucid->new( \@option_spec );
	1350	$opt = Getopt::Lucid->new( \@option_spec, \%parameters );
1325	1351	$opt = Getopt::Lucid->new( \@option_spec, \@option_array );
	1352	$opt = Getopt::Lucid->new( \@option_spec, \@option_array, \%parameters );
1326	1353
1327	1354	Creates a new Getopt::Lucid object. An array reference to an option spec is
1328	1355	required as an argument. (See L</USAGE> for a description of the object spec).
1329	1356	By default, objects will be set to read @ARGV for command line options. An
1330	1357	optional second argument with a reference to an array will use that array for
1331		option processing instead. For typical cases, users will likely prefer
1332		to call C<<< getopt >>> instead, which creates a new object and parses the command
1333		line with a single function call.
	1358	option processing instead. The final argument may be a hashref of parameters.
	1359	The only valid parameter currently is:
	1360
	1361	=over
	1362
	1363	=item *
	1364
	1365	strict -- enables strict mode when true
	1366
	1367	=back
	1368
	1369	For typical cases, users will likely prefer to call C<<< getopt >>> instead, which
	1370	creates a new object and parses the command line with a single function call.
	1371
	1372	=head2 validate()
	1373
	1374	$opt->validate();
	1375	$opt->validate( \%arguments );
	1376
	1377	Takes an optional argument hashref, validates that all requirements and
	1378	prerequisites are met or throws an error. Valid argument keys are:
	1379
	1380	=over
	1381
	1382	=item *
	1383
	1384	C<<< requires >>> -- an arrayref of options that must exist in the options
	1385	object.
	1386
	1387	=back
	1388
	1389	This method returns the object for convenient chaining:
	1390
	1391	$opt = Getopt::Lucid->getopt(\@spec)->validate;
1334	1392
1335	1393	=head2 append_defaults()
1336	1394

1418	1476	restored defaults, and returns a hash with the resulting options. This
1419	1477	undoes the effect of a C<<< merge_defaults >>> or C<<< add_defaults >>> call.
1420	1478
	1479	=head1 API CHANGES
	1480
	1481	In 1.00, the following API changes have been made:
	1482
	1483	=over
	1484
	1485	=item *
	1486
	1487	C<<< new() >>> now takes an optional hashref of parameters as the last
	1488	argument
	1489
	1490	=item *
	1491
	1492	The global C<<< $STRICT >>> variable has been replaced with a per-object
	1493	parameter C<<< strict >>>
	1494
	1495	=item *
	1496
	1497	The C<<< required >>> modifier has been removed and a new C<<< validate >>> method
	1498	has been added to facilitate lateE<sol>custom checks of required options
	1499
	1500	=back
	1501
1421	1502	=head1 SEE ALSO
1422	1503
1423	1504	=over

1453	1534	When submitting a bug or request, please include a test-file or a patch to an
1454	1535	existing test-file that illustrates the bug or desired feature.
1455	1536
	1537	=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
	1538
	1539	=head1 SUPPORT
	1540
	1541	=head2 Bugs / Feature Requests
	1542
	1543	Please report any bugs or feature requests through the issue tracker
	1544	at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Lucid>.
	1545	You will be notified automatically of any progress on your issue.
	1546
	1547	=head2 Source Code
	1548
	1549	This is open source software. The code repository is available for
	1550	public review and contribution under the terms of the license.
	1551
	1552	L<https://github.com/dagolden/getopt-lucid>
	1553
	1554	git clone https://github.com/dagolden/getopt-lucid.git
	1555
1456	1556	=head1 AUTHOR
1457	1557
1458	1558	David Golden <dagolden@cpan.org>
1459	1559
1460	1560	=head1 COPYRIGHT AND LICENSE
1461	1561
1462		This software is Copyright (c) 2010 by David Golden.
	1562	This software is Copyright (c) 2011 by David Golden.
1463	1563
1464	1564	This is free software, licensed under:
1465	1565

+21

-0

perlcritic.rc less more

	0	severity = 5
	1	verbose = 8
	2
	3	[Variables::ProhibitPunctuationVars]
	4	allow = $@ $!
	5
	6	# Turn these off
	7	[-BuiltinFunctions::ProhibitStringyEval]
	8	[-ControlStructures::ProhibitPostfixControls]
	9	[-ControlStructures::ProhibitUnlessBlocks]
	10	[-Documentation::RequirePodSections]
	11	[-InputOutput::ProhibitInteractiveTest]
	12	[-Miscellanea::RequireRcsKeywords]
	13	[-References::ProhibitDoubleSigils]
	14	[-RegularExpressions::RequireExtendedFormatting]
	15	[-InputOutput::ProhibitTwoArgOpen]
	16	[-TestingAndDebugging::ProhibitNoStrict]
	17
	18	# Turn this on
	19	[Lax::ProhibitStringyEval::ExceptForRequire]
	20

+15

-10

t/00-compile.t less more

0	0	#!perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1
11	2	use strict;
12	3	use warnings;
13	4
14	5	use Test::More;
	6
	7
	8
15	9	use File::Find;
16	10	use File::Temp qw{ tempdir };
17	11

29	23	'lib',
30	24	);
31	25
32		my @scripts = glob "bin/*";
	26	my @scripts;
	27	if ( -d 'bin' ) {
	28	find(
	29	sub {
	30	return unless -f;
	31	my $found = $File::Find::name;
	32	# nothing to skip
	33	push @scripts, $found;
	34	},
	35	'bin',
	36	);
	37	}
33	38
34	39	my $plan = scalar(@modules) + scalar(@scripts);
35	40	$plan ? (plan tests => $plan) : (plan skip_all => "no tests to run");

+1

-1

t/01-exceptions.t less more

0		# Getopt::Lucid::Exception
	0	# Getopt::Lucid::Exception
1	1	use strict;
2	2	use Test::More 0.62;
3	3	#--------------------------------------------------------------------------#

+10

-3

t/02-getopt.t less more

435	435	label => "required options",
436	436	spec => [
437	437	Counter("--verbose\|-v"),
438		Param("--input\|-i")->required,
	438	Param("--input\|-i")
439	439	],
440	440	cases => [
441	441	{
442	442	argv => [ qw( -v ) ],
443	443	exception => "Getopt::Lucid::Exception::ARGV",
444	444	error_msg => _required("--input"),
	445	required => ['input'],
445	446	desc => "missing required option"
446	447	},
447	448	{
448	449	argv => [ qw( --input 42 -vv ) ],
	450	required => ['input'],
449	451	result => { "verbose" => 2, "input" => 42 },
450	452	desc => "required option present"
451	453	},
452	454	{
453	455	argv => [ qw( --input info -v ) ],
	456	required => ['input'],
454	457	result => { "verbose" => 1, "input" => 'info' },
455	458	desc => "required option param similar to option name"
456	459	},

647	650	push @good_specs, {
648	651	label => "validate w/ string alternation regex",
649	652	spec => [
650		Param( "mode\|m", qr/test\|live/ )->required
	653	Param( "mode\|m", qr/test\|live/ ),
651	654	],
652	655	cases => [
653	656	{
654	657	argv => [ qw( --mode test ) ],
	658	required => ['mode'],
655	659	result => {
656	660	"mode" => 'test',
657	661	},

659	663	},
660	664	{
661	665	argv => [ qw( --mode foo ) ],
	666	required => ['mode'],
662	667	exception => "Getopt::Lucid::Exception::ARGV",
663	668	error_msg => _param_invalid("mode","foo"),
664	669	desc => "param mode not validating"

982	987	my $gl = Getopt::Lucid->new($trial->{spec});
983	988	@ARGV = @{$case->{argv}};
984	989	my %opts;
985		try eval { %opts = $gl->getopt->options };
	990	my $valid_args = $case->{required} ? {requires => $case->{required}}
	991	: {};
	992	try eval { %opts = $gl->getopt->validate($valid_args)->options };
986	993	catch my $err;
987	994	if (defined $case->{exception}) { # expected
988	995	ok( $err && $err->isa( $case->{exception} ),

+11

-11

t/03-getopt-notargv.t less more

21	21	my ($num_tests, @good_specs);
22	22
23	23	BEGIN {
24
25		push @good_specs, {
	24
	25	push @good_specs, {
26	26	label => "parse another array than \@ARGV",
27	27	spec => [
28	28	Switch("--verbose"),

30	30	Switch("-r"),
31	31	],
32	32	cases => [
33		{
	33	{
34	34	argv => [ qw( --verbose -r -- --test ) ],
35	35	result => { "verbose" => 1, "test" => 0, "r" => 1 },
36	36	after => [ qw( --test ) ],
37	37	desc => "stop after two"
38		},
39		{
	38	},
	39	{
40	40	argv => [ qw( -- -r --test ) ],
41	41	result => { "verbose" => 0, "test" => 0, "r" => 0 },
42	42	after => [ qw(-r --test ) ],
43	43	desc => "stop right away"
44		},
	44	},
45	45	]
46	46	};
47	47
48	48
49		} #BEGIN
	49	} #BEGIN
50	50
51	51	for my $t (@good_specs) {
52	52	$num_tests += 1 + 2 * @{$t->{cases}};

64	64	try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) };
65	65	catch my $err;
66	66	is( $err, undef, "$trial->{label}: spec should validate" );
67		SKIP: {
	67	SKIP: {
68	68	if ($err) {
69	69	my $num_tests = 2 * @{$trial->{cases}};
70	70	skip "because $trial->{label} spec did not validate", $num_tests;

76	76	try eval { %opts = $gl->getopt->options };
77	77	catch my $err;
78	78	if (defined $case->{exception}) { # expected
79		ok( $err && $err->isa( $case->{exception} ),
	79	ok( $err && $err->isa( $case->{exception} ),
80	80	"$trial->{label}: $case->{desc} should throw exception" )
81	81	or diag why( got => ref($err), expected => $case->{exception});
82		is( $err, $case->{error_msg},
	82	is( $err, $case->{error_msg},
83	83	"$trial->{label}: $case->{desc} error message correct");
84	84	} elsif ($err) { # unexpected
85	85	fail( "$trial->{label}: $case->{desc} threw an exception")
86	86	or diag "Exception is '$err'";
87	87	pass("$trial->{label}: skipping \@ARGV check");
88	88	} else { # no exception
89		is_deeply( \%opts, $case->{result},
	89	is_deeply( \%opts, $case->{result},
90	90	"$trial->{label}: $case->{desc}" ) or
91	91	diag why( got => \%opts, expected => $case->{result});
92	92	my $argv_after = $case->{after} \|\| [];

+2

-2

t/04-names.t less more

18	18	# Test cases
19	19	#--------------------------------------------------------------------------#
20	20
21		my $spec = [
	21	my $spec = [
22	22	Switch("--ver-bose"),
23	23	Switch("--test"),
24	24	Switch("-r"),

30	30	try eval { $gl = Getopt::Lucid->new($spec) };
31	31	catch my $err;
32	32	is( $err, undef, "spec should validate" );
33		SKIP: {
	33	SKIP: {
34	34	skip( "because spec did not validate", 1) if $err;
35	35	my @expect = sort qw(ver-bose test r);
36	36	my @got = sort $gl->names();

+17

-17

t/05-accessors.t less more

22	22	Switch("-t"),
23	23	Counter("--verb_osity"),
24	24	Param("--file-name"),
25		List("-I"),
	25	List("-I"),
26	26	Keypair("-d"),
27	27	];
28	28
29		my $case = {
30		argv => [ qw( --verb_osity -t --file-name=passwd
	29	my $case = {
	30	argv => [ qw( --verb_osity -t --file-name=passwd
31	31	-I /etc -I /lib -d os=linux ) ],
32		result => {
33		t => 1,
34		verb_osity => 1,
35		"file-name" => "passwd",
	32	result => {
	33	t => 1,
	34	verb_osity => 1,
	35	"file-name" => "passwd",
36	36	I => [qw(/etc /lib)],
37	37	d => { os => "linux" },
38	38	},
39	39	desc => "getopt accessors"
40	40	};
41	41
42		my $replace = {
43		t => 2,
44		verb_osity => 3,
45		"file-name" => "group",
	42	my $replace = {
	43	t => 2,
	44	verb_osity => 3,
	45	"file-name" => "group",
46	46	I => [qw(/var /tmp)],
47	47	d => { os => "win32" },
48	48	};

54	54	try eval { $gl = Getopt::Lucid->new($spec, \@cmd_line) };
55	55	catch my $err;
56	56	is( $err, undef, "spec should validate" );
57		SKIP: {
	57	SKIP: {
58	58	if ($err) {
59	59	skip "because spec did not validate", $num_tests - 1;
60	60	}

73	73	my $result = $case->{result}{$key};
74	74	(my $clean_key = $key ) =~ s/-/_/g;
75	75	if ( ref($result) eq 'ARRAY' ) {
76		is_deeply( [eval "\$gl->get_$clean_key"], $result,
	76	is_deeply( [eval "\$gl->get_$clean_key"], $result,
77	77	"accessor for '$key' correct");
78	78	&{"Getopt::Lucid::set_$clean_key"}($gl,@{$replace->{$key}});
79		is_deeply( [eval "\$gl->get_$clean_key"], $replace->{$key},
	79	is_deeply( [eval "\$gl->get_$clean_key"], $replace->{$key},
80	80	"mutator for '$key' correct");
81	81	} elsif ( ref($result) eq 'HASH' ) {
82		is_deeply( {eval "\$gl->get_$clean_key"}, $result,
	82	is_deeply( {eval "\$gl->get_$clean_key"}, $result,
83	83	"accessor for '$key' correct");
84	84	&{"Getopt::Lucid::set_$clean_key"}($gl,%{$replace->{$key}});
85		is_deeply( {eval "\$gl->get_$clean_key"}, $replace->{$key},
	85	is_deeply( {eval "\$gl->get_$clean_key"}, $replace->{$key},
86	86	"mutator for '$key' correct");
87	87	} else {
88	88	is( (eval "\$gl->get_$clean_key") , $result,
89	89	"accessor for '$key' correct");
90	90	&{"Getopt::Lucid::set_$clean_key"}($gl,$replace->{$key});
91		is( eval "\$gl->get_$clean_key", $replace->{$key},
	91	is( eval "\$gl->get_$clean_key", $replace->{$key},
92	92	"mutator for '$key' correct");
93	93	}
94	94	}

+6

-6

t/06-default-handling.t less more

64	64
65	65	# package variables for easier looping by name later
66	66
67		use vars qw(
	67	use vars qw(
68	68	$merge_default $merge_result
69	69	$append_default $append_result
70	70	$replace_default $replace_result

178	178	: undef;
179	179	}
180	180	is_deeply( {$gl->defaults}, \%basic_default,
181		"basic default options returned correctly") or
	181	"basic default options returned correctly") or
182	182	diag why( got => {$gl->options}, expected => \%basic_default);
183	183	is_deeply( {$gl->options}, $expect,
184		"options with default from spec processed correctly") or
	184	"options with default from spec processed correctly") or
185	185	diag why( got => {$gl->options}, expected => $expect);
186	186
187	187	# Test things working correctly

196	196	? "hash version"
197	197	: "hashref version";
198	198	is_deeply( {$gl->defaults}, $$default,
199		"$call updated defaults correctly ($msg)") or
	199	"$call updated defaults correctly ($msg)") or
200	200	diag why( got => {$gl->defaults}, expected => $$default);
201	201	is_deeply( {$gl->options}, $$result,
202		"$call refreshed options correctly ($msg)") or
	202	"$call refreshed options correctly ($msg)") or
203	203	diag why( got => {$gl->options}, expected => $$result);
204	204	$gl->reset_defaults();
205	205	is_deeply( {$gl->options}, $expect,
206		"options reset to spec correctly ($msg)") or
	206	"options reset to spec correctly ($msg)") or
207	207	diag why( got => {$gl->options}, expected => $expect);
208	208	}
209	209	}

+38

-35

t/07-magic-names.t less more

22	22	my ($num_tests, @good_specs);
23	23
24	24	BEGIN {
25
26		push @good_specs, {
	25
	26	push @good_specs, {
27	27	label => "magic bare names in spec",
28	28	spec => [
29	29	Counter("ver-bose\|v"),

32	32	Param("f"),
33	33	],
34	34	cases => [
35		{
	35	{
36	36	argv => [ qw( --ver-bose v -rtvf=test --r test -- test ) ],
37		result => {
38		"ver-bose" => 3,
39		"test" => 2,
40		"r" => 2,
	37	result => {
	38	"ver-bose" => 3,
	39	"test" => 2,
	40	"r" => 2,
41	41	"f" => "test",
42	42	},
43	43	after => [qw( test )],
44	44	desc => "all three types in command line"
45		},
46		{
	45	},
	46	{
47	47	argv => [ qw( --ver-bose v -rtvf fest --r test -- test ) ],
48		result => {
49		"ver-bose" => 3,
50		"test" => 2,
51		"r" => 2,
	48	result => {
	49	"ver-bose" => 3,
	50	"test" => 2,
	51	"r" => 2,
52	52	"f" => "fest",
53	53	},
54	54	after => [qw( test )],
55	55	desc => "all three types in command line"
56		},
57		{
	56	},
	57	{
58	58	argv => [ qw( -test ) ],
59	59	exception => "Getopt::Lucid::Exception::ARGV",
60	60	error_msg => _invalid_argument("-e"),
61		desc => "single dash with word"
62		},
63		{
	61	desc => "single dash with word"
	62	},
	63	{
64	64	argv => [ qw( f test ) ],
65	65	exception => "Getopt::Lucid::Exception::ARGV",
66	66	error_msg => _param_ambiguous("f", "test"),
67		desc => "ambiguous param -- bareword"
68		},
69		{
	67	desc => "ambiguous param -- bareword"
	68	},
	69	{
70	70	argv => [ qw( f --test ) ],
71	71	exception => "Getopt::Lucid::Exception::ARGV",
72	72	error_msg => _param_ambiguous("f", "--test"),
73		desc => "ambiguous param -- long form"
74		},
	73	desc => "ambiguous param -- long form"
	74	},
75	75	]
76	76	};
77	77
78		push @good_specs, {
	78	push @good_specs, {
79	79	label => "avoid ambiguity (RT 33462)",
80	80	spec => [
81		Param("config\|c")->required(),
	81	Param("config\|c"),
82	82	Switch("help\|h")->anycase(),
83	83	],
84	84	cases => [
85		{
	85	{
86	86	argv => [ qw( -c /home/newuat5/nas/Abilit/newuat6/test_home/Data/tdg/testdatengenerator.conf ) ],
87		result => {
88		"config" => "/home/newuat5/nas/Abilit/newuat6/test_home/Data/tdg/testdatengenerator.conf",
	87	required => ['config'],
	88	result => {
	89	"config" => "/home/newuat5/nas/Abilit/newuat6/test_home/Data/tdg/testdatengenerator.conf",
89	90	"help" => 0,
90	91	},
91	92	after => [],
92	93	desc => "single dash option"
93		},
	94	},
94	95	]
95	96	};
96	97
97	98
98		} #BEGIN
	99	} #BEGIN
99	100
100	101	for my $t (@good_specs) {
101	102	$num_tests += 1 + 2 * @{$t->{cases}};

113	114	try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) };
114	115	catch my $err;
115	116	is( $err, undef, "$trial->{label}: spec should validate" );
116		SKIP: {
	117	SKIP: {
117	118	if ($err) {
118	119	my $num_tests = 2 * @{$trial->{cases}};
119	120	skip "because $trial->{label} spec did not validate", $num_tests;

122	123	my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line);
123	124	@cmd_line = @{$case->{argv}};
124	125	my %opts;
125		try eval { %opts = $gl->getopt->options };
	126	my $valid_args = $case->{required} ? {requires => $case->{required}}
	127	: {};
	128	try eval { %opts = $gl->getopt->validate($valid_args)->options };
126	129	catch my $err;
127	130	if (defined $case->{exception}) { # expected
128		ok( $err && $err->isa( $case->{exception} ),
	131	ok( $err && $err->isa( $case->{exception} ),
129	132	"$trial->{label}: $case->{desc} should throw exception" )
130	133	or diag why( got => ref($err), expected => $case->{exception});
131		is( $err, $case->{error_msg},
	134	is( $err, $case->{error_msg},
132	135	"$trial->{label}: $case->{desc} error message correct");
133	136	} elsif ($err) { # unexpected
134	137	fail( "$trial->{label}: $case->{desc} threw an exception")
135	138	or diag "Exception is '$err'";
136	139	pass("$trial->{label}: skipping \@ARGV check");
137	140	} else { # no exception
138		is_deeply( \%opts, $case->{result},
	141	is_deeply( \%opts, $case->{result},
139	142	"$trial->{label}: $case->{desc}" ) or
140	143	diag why( got => \%opts, expected => $case->{result});
141	144	my $argv_after = $case->{after} \|\| [];

+39

-41

t/08-strict-names.t less more

8	8	use Getopt::Lucid ':all';
9	9	use Getopt::Lucid::Exception;
10	10	use t::ErrorMessages;
11
12		$Getopt::Lucid::STRICT = 1;
13	11
14	12	sub why {
15	13	my %vars = @_;

24	22	my ($num_tests, @good_specs);
25	23
26	24	BEGIN {
27
28		push @good_specs, {
	25
	26	push @good_specs, {
29	27	label => "mixed format names in spec",
30	28	spec => [
31	29	Counter("ver-bose\|-v"),

34	32	Param("f"),
35	33	],
36	34	cases => [
37		{
	35	{
38	36	argv => [ qw( ver-bose -v -rtv f=test -r --test -- test ) ],
39		result => {
40		"ver-bose" => 3,
41		"test" => 2,
42		"r" => 2,
	37	result => {
	38	"ver-bose" => 3,
	39	"test" => 2,
	40	"r" => 2,
43	41	"f" => "test",
44	42	},
45	43	after => [qw( test )],
46	44	desc => "all three types in command line"
47		},
48		{
	45	},
	46	{
49	47	argv => [ qw( ver-bose -v -rtv f test -r --test -- test ) ],
50		result => {
51		"ver-bose" => 3,
52		"test" => 2,
53		"r" => 2,
	48	result => {
	49	"ver-bose" => 3,
	50	"test" => 2,
	51	"r" => 2,
54	52	"f" => "test",
55	53	},
56	54	after => [qw( test )],
57	55	desc => "bare param with bare like long-form in spec"
58		},
59		{
	56	},
	57	{
60	58	argv => [ qw( ver-bose -v -rtv f=test -r test ) ],
61		result => {
62		"ver-bose" => 3,
63		"test" => 1,
64		"r" => 2,
	59	result => {
	60	"ver-bose" => 3,
	61	"test" => 1,
	62	"r" => 2,
65	63	"f" => "test",
66	64	},
67	65	after => [qw( test )],
68	66	desc => "bareword like long-form in spec passed through"
69		},
70		{
	67	},
	68	{
71	69	argv => [ qw( -test ) ],
72	70	exception => "Getopt::Lucid::Exception::ARGV",
73	71	error_msg => _invalid_argument("-e"),
74		desc => "single dash with word"
75		},
76		{
	72	desc => "single dash with word"
	73	},
	74	{
77	75	argv => [ qw( --ver-bose ) ],
78	76	exception => "Getopt::Lucid::Exception::ARGV",
79	77	error_msg => _invalid_argument("--ver-bose"),
80		desc => "long form like bareword in spec"
81		},
82		{
	78	desc => "long form like bareword in spec"
	79	},
	80	{
83	81	argv => [ qw( --r ) ],
84	82	exception => "Getopt::Lucid::Exception::ARGV",
85	83	error_msg => _invalid_argument("--r"),
86		desc => "long form like short in spec"
87		},
88		{
	84	desc => "long form like short in spec"
	85	},
	86	{
89	87	argv => [ qw( -f=--test ) ],
90	88	exception => "Getopt::Lucid::Exception::ARGV",
91	89	error_msg => _invalid_argument("-f"),
92		desc => "shoft form like bare in spec"
93		},
	90	desc => "shoft form like bare in spec"
	91	},
94	92	]
95	93	};
96	94
97	95
98		} #BEGIN
	96	} #BEGIN
99	97
100	98	for my $t (@good_specs) {
101	99	$num_tests += 1 + 2 * @{$t->{cases}};

110	108	my ($trial, @cmd_line);
111	109
112	110	while ( $trial = shift @good_specs ) {
113		try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) };
	111	try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1}) };
114	112	catch my $err;
115	113	is( $err, undef, "$trial->{label}: spec should validate" );
116		SKIP: {
	114	SKIP: {
117	115	if ($err) {
118	116	my $num_tests = 2 * @{$trial->{cases}};
119	117	skip "because $trial->{label} spec did not validate", $num_tests;
120	118	}
121	119	for my $case ( @{$trial->{cases}} ) {
122		my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line);
	120	my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1});
123	121	@cmd_line = @{$case->{argv}};
124	122	my %opts;
125	123	try eval { %opts = $gl->getopt->options };
126	124	catch my $err;
127	125	if (defined $case->{exception}) { # expected
128		ok( $err && $err->isa( $case->{exception} ),
	126	ok( $err && $err->isa( $case->{exception} ),
129	127	"$trial->{label}: $case->{desc} should throw exception" )
130	128	or diag why( got => ref($err), expected => $case->{exception});
131		is( $err, $case->{error_msg},
	129	is( $err, $case->{error_msg},
132	130	"$trial->{label}: $case->{desc} error message correct");
133	131	} elsif ($err) { # unexpected
134	132	fail( "$trial->{label}: $case->{desc} threw an exception")
135	133	or diag "Exception is '$err'";
136	134	pass("$trial->{label}: skipping \@ARGV check");
137	135	} else { # no exception
138		is_deeply( \%opts, $case->{result},
	136	is_deeply( \%opts, $case->{result},
139	137	"$trial->{label}: $case->{desc}" ) or
140	138	diag why( got => \%opts, expected => $case->{result});
141	139	my $argv_after = $case->{after} \|\| [];

+6

-2

t/09-negation.t less more

131	131	push @good_specs, {
132	132	label => "required/prereq",
133	133	spec => [
134		Switch("test")->required,
	134	Switch("test"),
135	135	Param("input")->needs("output"),
136	136	Param("output"),
137	137	],

139	139	{
140	140	argv => [ qw( --test --no-test ) ],
141	141	exception => "Getopt::Lucid::Exception::ARGV",
	142	required => ['test'],
142	143	error_msg => _required("test"),
143	144	desc => "missing requirement after negation"
144	145	},

146	147	argv => [ qw( --test --input in.txt
147	148	--output out.txt --no-output ) ],
148	149	exception => "Getopt::Lucid::Exception::ARGV",
	150	required => ['test'],
149	151	error_msg => _prereq_missing("input","output",),
150	152	desc => "missing prereq after negation"
151	153	},

179	181	my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line);
180	182	@cmd_line = @{$case->{argv}};
181	183	my %opts;
182		try eval { %opts = $gl->getopt->options };
	184	my $valid_args = $case->{required} ? {requires => $case->{required}}
	185	: {};
	186	try eval { %opts = $gl->getopt->validate($valid_args)->options };
183	187	catch my $err;
184	188	if (defined $case->{exception}) { # expected
185	189	ok( $err && $err->isa( $case->{exception} ),

+37

-46

t/ErrorMessages.pm less more

0		#
1		# This file is part of Getopt-Lucid
2		#
3		# This software is Copyright (c) 2010 by David Golden.
4		#
5		# This is free software, licensed under:
6		#
7		# The Apache License, Version 2.0, January 2004
8		#
9		package t::ErrorMessages;
10		@ISA = ("Exporter");
11		use strict;
12		use Exporter ();
13
14		sub _invalid_argument {sprintf("Invalid argument: %s",@_)}
15		sub _required {sprintf("Required option '%s' not found",@_)}
16		sub _switch_twice {sprintf("Switch used twice: %s",@_)}
17		sub _switch_value {sprintf("Switch can't take a value: %s=%s",@_)}
18		sub _counter_value {sprintf("Counter option can't take a value: %s=%s",@_)}
19		sub _param_ambiguous {sprintf("Ambiguous value for %s could be option: %s",@_)}
20		sub _param_invalid {sprintf("Invalid parameter %s = %s",@_)}
21		sub _param_neg_value {sprintf("Negated parameter option can't take a value: %s=%s",@_)}
22		sub _list_invalid {sprintf("Invalid list option %s = %s",@_)}
23		sub _keypair_invalid {sprintf("Invalid keypair '%s': %s => %s",@_)}
24		sub _list_ambiguous {sprintf("Ambiguous value for %s could be option: %s",@_)}
25		sub _keypair {sprintf("Badly formed keypair for '%s'",@_)}
26		sub _default_list {sprintf("Default for list '%s' must be array reference",@_)}
27		sub _default_keypair {sprintf("Default for keypair '%s' must be hash reference",@_)}
28		sub _default_invalid {sprintf("Default '%s' = '%s' fails to validate",@_)}
29		sub _name_invalid {sprintf("'%s' is not a valid option name/alias",@_)}
30		sub _name_not_unique {sprintf("'%s' is not unique",@_)}
31		sub _name_conflicts {sprintf("'%s' conflicts with other options",@_)}
32		sub _key_invalid {sprintf("'%s' is not a valid option specification key",@_)}
33		sub _type_invalid {sprintf("'%s' is not a valid option type",@_)}
34		sub _prereq_missing {sprintf("Option '%s' requires option '%s'",@_)}
35		sub _unknown_prereq {sprintf("Prerequisite '%s' for '%s' is not recognized",@_)}
36		sub _invalid_list {sprintf("Option '%s' in %s must be scalar or array reference",@_)}
37		sub _invalid_keypair {sprintf("Option '%s' in %s must be scalar or hash reference",@_)}
38		sub _invalid_splat_defaults {sprintf("Argument to %s must be a hash or hash reference",@_)}
39
40		# keep this last;
41		for (keys %t::ErrorMessages::) {
42		push @t::ErrorMessages::EXPORT, $_ if $_ =~ "^_";
43		}
44
45		1;
	0	package t::ErrorMessages;
	1	@ISA = ("Exporter");
	2	use strict;
	3	use Exporter ();
	4
	5	sub _invalid_argument {sprintf("Invalid argument: %s",@_)}
	6	sub _required {sprintf("Required option '%s' not found",@_)}
	7	sub _switch_twice {sprintf("Switch used twice: %s",@_)}
	8	sub _switch_value {sprintf("Switch can't take a value: %s=%s",@_)}
	9	sub _counter_value {sprintf("Counter option can't take a value: %s=%s",@_)}
	10	sub _param_ambiguous {sprintf("Ambiguous value for %s could be option: %s",@_)}
	11	sub _param_invalid {sprintf("Invalid parameter %s = %s",@_)}
	12	sub _param_neg_value {sprintf("Negated parameter option can't take a value: %s=%s",@_)}
	13	sub _list_invalid {sprintf("Invalid list option %s = %s",@_)}
	14	sub _keypair_invalid {sprintf("Invalid keypair '%s': %s => %s",@_)}
	15	sub _list_ambiguous {sprintf("Ambiguous value for %s could be option: %s",@_)}
	16	sub _keypair {sprintf("Badly formed keypair for '%s'",@_)}
	17	sub _default_list {sprintf("Default for list '%s' must be array reference",@_)}
	18	sub _default_keypair {sprintf("Default for keypair '%s' must be hash reference",@_)}
	19	sub _default_invalid {sprintf("Default '%s' = '%s' fails to validate",@_)}
	20	sub _name_invalid {sprintf("'%s' is not a valid option name/alias",@_)}
	21	sub _name_not_unique {sprintf("'%s' is not unique",@_)}
	22	sub _name_conflicts {sprintf("'%s' conflicts with other options",@_)}
	23	sub _key_invalid {sprintf("'%s' is not a valid option specification key",@_)}
	24	sub _type_invalid {sprintf("'%s' is not a valid option type",@_)}
	25	sub _prereq_missing {sprintf("Option '%s' requires option '%s'",@_)}
	26	sub _unknown_prereq {sprintf("Prerequisite '%s' for '%s' is not recognized",@_)}
	27	sub _invalid_list {sprintf("Option '%s' in %s must be scalar or array reference",@_)}
	28	sub _invalid_keypair {sprintf("Option '%s' in %s must be scalar or hash reference",@_)}
	29	sub _invalid_splat_defaults {sprintf("Argument to %s must be a hash or hash reference",@_)}
	30
	31	# keep this last;
	32	for (keys %t::ErrorMessages::) {
	33	push @t::ErrorMessages::EXPORT, $_ if $_ =~ "^_";
	34	}
	35
	36	1;

+12

-0

xt/author/critic.t less more

	0	#!perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More;
	6	use English qw(-no_match_vars);
	7
	8	eval "use Test::Perl::Critic";
	9	plan skip_all => 'Test::Perl::Critic required to criticise code' if $@;
	10	Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc";
	11	all_critic_ok();

+0

-9

xt/release/distmeta.t less more

0	0	#!perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1
11	2	use Test::More;
12	3

+0

-9

xt/release/pod-coverage.t less more

0	0	#!perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1
11	2	use Test::More;
12	3

+0

-9

xt/release/pod-syntax.t less more

0	0	#!perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1	use Test::More;
11	2
12	3	eval "use Test::Pod 1.41";

+0

-9

xt/release/portability.t less more

0	0	#!perl
1		#
2		# This file is part of Getopt-Lucid
3		#
4		# This software is Copyright (c) 2010 by David Golden.
5		#
6		# This is free software, licensed under:
7		#
8		# The Apache License, Version 2.0, January 2004
9		#
10	1
11	2	use Test::More;
12	3

+12

-0

xt/release/test-version.t less more

	0	#!/usr/bin/perl
	1	use 5.006;
	2	use strict;
	3	use warnings;
	4	use Test::More;
	5
	6	eval "use Test::Version 0.04";
	7	plan skip_all => "Test::Version 0.04 required for testing versions"
	8	if $@;
	9
	10	version_all_ok();
	11	done_testing;