Getargs-Long-1.1003/0000755000076500000240000000000011037262003013242 5ustar coppitstaffGetargs-Long-1.1003/CHANGES0000644000076500000240000000437411037260760014255 0ustar coppitstaffVersion 1.1003: Tue Jul 15 2008 - Updated to the latest version of Module::Install - Removed auto-install for better compatibility with CPAN and others - Moved hosting to Google Code Version 1.1002 : Tues Nov 6 2007 - Dual-licensed the code under the GPL and Artistic licenses. (By the request of Brandon Forehand .) Raphael Manfredi agreed over email to changing the license on his code. Version 1.1001 : Mon Jun 6 2005 - Fixed incorrect comments in Long.pm and test cases Version 1.1000: Tue Dec 21 2004 - Fixed version numbers, which were incompatible with some modules. (Thanks to Tassilo von Parseval for the bug report) - Removed custom installation prompt. - Cleaned up documentation a bit. Version 1.0.1: Thu Sep 16 2004 - Added missing inc/ dependency - Switched to Test::More for better test reporting Version 1.0.0: Wed Sep 15 2004 - David Coppit is the new maintainer. - License changed to GPL - Changed Makefile.PL to use Module::Install - Version numbering changed - Added a check for the perl version number Tue Mar 20 11:37:54 MET 2001 Raphael Manfredi . Description: Version 0.1.3. Changed interface of all getargs() routines. This change is NOT backward compatible, but this is the privilege of still being at the alpha stage... Previous calls were made as: getargs(\@_, ...) and must now be written as: getargs (@_, ...) with an implicit reference being taken, via Perl prototyping. Added mention of similar module Params::Validate. His author contacted me to mention it, and apparently we independently invented the same thing, albeit with slight different goals and interfaces. Added warning about interface change during the run of Makefile.PL if a previous incompatible version is detected. Updated all getargs() calls to new interface in the regression test suite. Thu Mar 15 01:14:21 MET 2001 Raphael Manfredi . Description: Added warning when using perl 5.6.0. Don't use that version of Perl. Either use 5.005_03, or try 5.6.1. Fri Mar 2 19:00:00 MET 2001 Raphael Manfredi . Description: Forgot to include t/code.pl in distribution Getargs-Long-1.1003/inc/0000755000076500000240000000000011037262003014013 5ustar coppitstaffGetargs-Long-1.1003/inc/Module/0000755000076500000240000000000011037262003015240 5ustar coppitstaffGetargs-Long-1.1003/inc/Module/Install/0000755000076500000240000000000011037262003016646 5ustar coppitstaffGetargs-Long-1.1003/inc/Module/Install/Base.pm0000644000076500000240000000203511037262000020053 0ustar coppitstaff#line 1 package Module::Install::Base; $VERSION = '0.75'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 Getargs-Long-1.1003/inc/Module/Install/Can.pm0000644000076500000240000000337411037262000017711 0ustar coppitstaff#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.75'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 Getargs-Long-1.1003/inc/Module/Install/Fetch.pm0000644000076500000240000000463011037262000020235 0ustar coppitstaff#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.75'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Getargs-Long-1.1003/inc/Module/Install/Makefile.pm0000644000076500000240000001412111037262000020715 0ustar coppitstaff#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.75'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Make sure we have a new enough require ExtUtils::MakeMaker; $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION ); # Generate the my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { $args{dist} = $preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 371 Getargs-Long-1.1003/inc/Module/Install/Metadata.pm0000644000076500000240000002235011037262000020723 0ustar coppitstaff#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.75'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } sub requires { my $self = shift; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @{ $self->{values}->{requires} }, [ $module, $version ]; } $self->{values}{requires}; } sub build_requires { my $self = shift; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @{ $self->{values}->{build_requires} }, [ $module, $version ]; } $self->{values}{build_requires}; } sub configure_requires { my $self = shift; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @{ $self->{values}->{configure_requires} }, [ $module, $version ]; } $self->{values}->{configure_requires}; } sub recommends { my $self = shift; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @{ $self->{values}->{recommends} }, [ $module, $version ]; } $self->{values}->{recommends}; } sub bundles { my $self = shift; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @{ $self->{values}->{bundles} }, [ $module, $version ]; } $self->{values}->{bundles}; } # Resource handling sub resources { my $self = shift; while ( @_ ) { my $resource = shift or last; my $value = shift or next; push @{ $self->{values}->{resources} }, [ $resource, $value ]; } $self->{values}->{resources}; } sub repository { my $self = shift; $self->resources( repository => shift ); return 1; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and ! @_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{values}{dynamic_config} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die "Cannot determine name from $file\n"; } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { if ( $osi and $license_text =~ /All rights reserved/i ) { print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n"; } $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die "Cannot find script '$_'"; } } } 1; Getargs-Long-1.1003/inc/Module/Install/Win32.pm0000644000076500000240000000340211037262000020102 0ustar coppitstaff#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.75'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Getargs-Long-1.1003/inc/Module/Install/WriteAll.pm0000644000076500000240000000132111037262000020721 0ustar coppitstaff#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.75'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } } 1; Getargs-Long-1.1003/inc/Module/Install.pm0000644000076500000240000002054511037262000017207 0ustar coppitstaff#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } BEGIN { require 5.004; } use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.75'; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ( $self, $1 ); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open FH, "< $_[0]" or die "open($_[0]): $!"; my $str = do { local $/; }; close FH or die "close($_[0]): $!"; return $str; } sub _write { local *FH; open FH, "> $_[0]" or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } close FH or die "close($_[0]): $!"; } sub _version { my $s = shift || 0; $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } 1; # Copyright 2008 Adam Kennedy. Getargs-Long-1.1003/lib/0000755000076500000240000000000011037262003014010 5ustar coppitstaffGetargs-Long-1.1003/lib/Getargs/0000755000076500000240000000000011037262003015404 5ustar coppitstaffGetargs-Long-1.1003/lib/Getargs/Long.pm0000644000076500000240000010026411037261762016657 0ustar coppitstaff# -*- Mode: perl -*- use strict; use 5.005; package Getargs::Long; use vars qw($VERSION @ISA @EXPORT); $VERSION = sprintf "%d.%02d%02d", q/1.10.3/ =~ /(\d+)/g; BEGIN { die "This module is known to exercise a bug in 5.6.0. Please upgrade your perl.\n" if $] eq '5.006'; } use Log::Agent; use Data::Dumper; require Exporter; use vars qw(@EXPORT); @ISA = qw(Exporter); @EXPORT = qw(getargs cgetargs xgetargs cxgetargs); # # %ignore # # Cache whether argument names are to be handled case-insensitively or not, # on a package basis. Default is case-sensitive processing. # my %ignore = (); # # ->import # # Trap Exporter's one to handle 'ignorecase' here (or lack thereof). # Then use ->export_to_level() to tell Exporter to continue the export # as if its import method had been called directly via inheritance. # sub import { my $module = shift; my @syms = grep($_ ne 'ignorecase', @_); my $callpkg = caller; if (@syms == @_) { # There was no "ignorecase" seen delete $ignore{$callpkg}; logdbg 'info', "will process arguments case-sensitively in $callpkg"; } else { $ignore{$callpkg} = 1; logdbg 'info', "will process arguments case-insensitively in $callpkg"; } Getargs::Long->export_to_level(1, $module, @syms); } # # %subcache # # Cache validation routine, indexed by "package::routine". # my %subcache = (); # # getargs # # Parse arguments for subroutine, and validate them if typechecking requested. # Optional arguments with no default return undef. Mandatory arguments cannot # be undefined. # sub getargs (\@@) { _getargs(scalar(caller), 0, "", @_) } # # cgetargs # # Same as getargs, but cache data for next call. # # When called from within an eval, caching is not possible, so this routine # must not be called. # sub cgetargs (\@@) { my $sub = (caller(1))[3]; # Anomaly in caller(), will also get pkg name logcroak "can't call cgetargs from within an eval" if $sub =~ /^\(eval/; _getargs(scalar(caller), 0, $sub, @_) } # # xgetargs # # Like getargs(), but with extended specifications allowing to specify # defaults for non-mandatory arguments. # sub xgetargs (\@@) { _getargs(scalar(caller), 1, "", @_) } # # cxgetargs # # Like cgetargs(), but with extended specifications allowing to specify # defaults for non-mandatory arguments. Be careful: those defaults are # deep-cloned and "frozen", so to speak. # # When called from within an eval, caching is not possible, so this routine # must not be called. # sub cxgetargs (\@@) { my $sub = (caller(1))[3]; # Anomaly in caller(), will also get pkg name logcroak "can't call cxgetargs from within an eval" if $sub =~ /^\(eval/; _getargs(scalar(caller), 1, $sub, @_) } # # _getargs # # Factorized work for *getargs() routines # # Our signature is: # # _getargs( # # arguments added by our wrappers # $callpkg, $extended, $subname, # # argument list to parse # \@x, # # optional switches # { # -strict => 1, # unknown switches are fatal # -inplace => 1, # edit \@x inplace: remove parsed args # -ignorecase => 1, # override package's global # -extra => 0, # suppress return of extra arguments # }, # # argument definition list # # ); # # With: # $callpkg Calling package # $extended Are they using x*getargs()? # $subname Cache key, if we use it # # Returns the list of values in the same order given in the definition list # (the part), followed by the extra arguments we did not recognize, # with leading '-' removal and transformation to lowercase if ignorecase is on. # sub _getargs { my ($callpkg, $extended, $subname, $args) = splice(@_, 0, 4); logconfess "first argument must be a reference to the argument list" unless ref $args eq 'ARRAY'; # # Check cache if told to do so. # if ($subname ne '') { my $sref = $subcache{$subname}; if (defined $sref) { logdbg 'info', "calling cached subroutine $sref"; return &$sref($args); } else { logdbg 'info', "no cached subroutine yet for $subname"; } } # # Nothing in cache, or cache was disabled. # my $case_insensitive = $ignore{$callpkg} ? 1 : 0; logdbg 'info', "case_insensitive=$case_insensitive for package $callpkg"; # # If next argument is a HASH, then it's a set of extra switches that # may alter our behaviour. Parse them manually. # # Following are the defaults: # my $strict = 1; # Fatal error on unknown switches my $inplace = 0; # No inplace editing of arguments my $extra; # Don't return extra args by default if (ref $_[0] eq 'HASH') { my $swref = shift; my %set = ( -strict => \$strict, -ignorecase => \$case_insensitive, -inplace => \$inplace, -extra => \$extra, ); while (my ($sw, $val) = each %$swref) { my $vset = $set{lc($sw)}; logcroak "unknown switch $sw" unless ref $vset; $$vset = $val; } # # If they did not set -extra, compute suitable default: false # when -strict, true otherwise. # $extra = $strict ? 0 : 1 unless defined $extra; # # If strict, we ignore true settings for -inplace and -extra # if ($strict) { if ($inplace) { logcarp "ignoring -inplace when -strict"; $inplace = 0; } if ($extra) { logcarp "ignoring -extra when -strict"; $extra = 0; } } } # # If we have one argument, it may be '[list]' or 'x'. # In extended mode, we must have an even amount of arguments. # my @specs; # User specification list my $all_optional = 0; # True if all arguments are optional if (@_ == 1 && ref $_[0]) { logcroak "must use an array reference for optional args" unless ref $_[0] eq 'ARRAY'; @specs = @{$_[0]}; $all_optional = 1; } else { @specs = @_; logcroak "must supply an even amount of arguments in extend mode" if $extended && (@specs % 2); } # # Parse our argument list and compile it into @args # my %seen; my @args; # List of [name, type, is_optional, default] for (my $i = 0, my $step = $extended ? 2 : 1; $i < @specs; $i += $step) { my $arg = $specs[$i]; my ($name, $type, $optional, $dflt); if ($extended) { $name = $arg; my $spec = $specs[$i+1]; if (ref $spec) { # Given as an array ref -> optional, with possible default logcroak "specs for optional '$name' are $spec, expected ARRAY" unless ref $spec eq 'ARRAY'; ($type, $dflt) = @$spec; $optional = 1; } else { # simple scalar is type, argument is mandatory $type = $spec; $optional = 0; } } else { # Can be either "name" or "name=Type" ($name, $type) = $arg =~ /^-?(\w+)=(\S+)/; $name = $arg unless defined $name; $optional = $all_optional; } $name = lc($name) if $case_insensitive; $name =~ s/^-//; logcroak "argument name cannot be empty" if $name eq ''; logcroak "argument name must be scalar, not $name" if ref $name; logcroak "duplicate argument definition for '$name'" if $seen{$name}++; push(@args, [ $name, defined($type) ? $type : undef, $optional, defined($dflt) ? $dflt : undef ]); } # # If caching, generate the subroutine that will perform the checks. # # We use logxcroak to report errors to the caller of the caller # of *getargs, i.e. the caller of the routine for which we're checking # the arguments. # if ($subname ne '') { my $lc = $case_insensitive ? 'lc' : ''; my $sub = &q(<<'EOS'); :sub { : my $aref_orig = shift; : my @result; : my $cur; : my $isthere; : my $ctype; : local $Getargs::Long::dflt; : my $i = 0; EOS $sub .= &q(<[$j]; : $key =~ s/^-//; EOS $sub .= &q(<<'EOS') if $case_insensitive; : $key = lc($key); EOS $sub .= &q(<<'EOS'); : $idx{$key} = $j; : } : EOS } foreach my $arg (@args) { my ($name, $type, $optional, $dflt) = @$arg; my $has_default = defined $dflt; local $^W = 0; # Shut up Test::Harness $sub .= &q(< $idx; : } EOS $sub .= &q(<<'EOS'); : } EOS if ($optional) { if ($has_default) { $sub .= &q(<new([$dflt], []); $obj->Purity(1); $sub .= $obj->Dumpxs; $sub .= &q(<<'EOS'); : }; : $cur = \$Getargs::Long::dflt; : } EOS } } else { $sub .= &q(<isa('$type') : : \$ctype ne '$type'); EOS } } $sub .= &q(<<'EOS'); : push(@result, defined($cur) ? $$cur : undef); : EOS } # If we're strict, we must report unprocessed switches $sub .= &q(<<'EOS') if $strict; : : spot_unknown(\%args, 3) if scalar keys %args; : EOS # Add extra unprocessed switches to the result list $sub .= &q(<<'EOS') if $extra; : push(@result, @$aref); EOS $sub .= &q(<<'EOS'); : return @result; :} EOS logdbg 'debug', "anonymous subroutine: $sub"; my $code = eval $sub; if (chop($@)) { logerr "can't create subroutine for checking args of $subname: $@"; logwarn "ignoring caching directive for $subname"; } else { $subcache{$subname} = $code; logdbg 'info', "calling newly built subroutine $code"; return &$code($args); } } # # No caching made, perform validation by interpreting the structure # # There is some unfortunate code duplication between the following checks # and the above routine-construction logic. Some place are identical, # but the main argument processing loop is noticeably different, even # though the same logic is used. # logdbg 'info', "interpreting structure to validate arguments"; my @result; my $cur; my $ctype; my $i = 0; my %args; $args = [@$args] if $extra && !$inplace; # Work on a copy logxcroak 2, "expected an even number of arguments" if @$args % 2; if ($case_insensitive) { %args = map { ($i++ % 2) ? $_ : lc(/^-/ ? substr($_, 1) : $_) } @$args; } else { %args = map { ($i++ % 2) ? $_ : (/^-/ ? substr($_, 1) : $_) } @$args; } # Sanity check: no argument can be given twice spot_dups($args, $case_insensitive, 2) if 2 * scalar(keys %args) != @$args; # Index arguments if inplace editing or extra my %idx; if ($inplace || $extra) { for (my $j = 0; $j < @$args; $j += 2) { my $key = $args->[$j]; $key =~ s/^-//; $key = lc($key) if $case_insensitive; $idx{$key} = $j; } } # Process each argument foreach my $arg (@args) { my ($name, $type, $optional, $dflt) = @$arg; my $cur; my $isthere = 0; if (exists $args{$name}) { $isthere = 1; my $val = delete $args{$name}; $cur = \$val; # Splice argument out if requested if ($inplace || $extra) { my $idx = $idx{$name}; splice(@$args, $idx, 2); while (my ($k, $v) = each %idx) { $idx{$k} -= 2 if $v > $idx; } } } elsif ($optional) { $cur = \$dflt if defined $dflt; } else { logxcroak 2, "mandatory argument '$name' missing"; } push(@result, defined($cur) ? $$cur : undef); next if !defined $type || $type eq ''; if ($optional) { logxcroak 2, "argument '$name' cannot be undef" if $isthere && !defined $$cur; } else { logxcroak 2, "argument '$name' cannot be undef" unless defined $$cur; } # XXX Check that i is integer, s string and n natural if ($type =~ /^[isn]$/) { # Make sure it's a scalar logxcroak 2, "argument '$name' must be scalar (type '$type') but is $$cur" if (!$optional || $isthere) && ref $$cur; } else { my $ctype = $isthere ? ref $$cur : undef; logxcroak 2, "argument '$name' must be of type $type but is $ctype" if (!$optional || $isthere) && (UNIVERSAL::isa($$cur, 'UNIVERSAL') ? !$$cur->isa($type) : $ctype ne $type); } } # If we're strict, we must report unprocessed switches spot_unknown(\%args, 2) if $strict && scalar keys %args; # Add extra unprocessed switches to the result list push(@result, @$args) if $extra; return @result; } # # spot_dups # # Given a list of arguments in $aref, where we know there are duplicate "keys", # identify them and croak by listing the culprits. # sub spot_dups { my ($aref, $ignorecase, $level) = @_; my %seen; my @duplicates; for (my $i = 0; $i < @$aref; $i += 2) { my $key = $ignorecase ? lc($aref->[$i]) : $aref->[$i]; $key =~ s/^-//; push(@duplicates, "-$key") if $seen{$key}++; } logconfess "bug in Getargs::Long -- should have found duplicates" unless @duplicates; logxcroak ++$level, "multiple switches given for: " . join(", ", @duplicates); } # # spot_unknown # # Report keys held in supplied hashref as unknown switches. # sub spot_unknown { my ($href, $level) = @_; my @unprocessed = map { "-$_" } keys %$href; my $es = @unprocessed == 1 ? '' : 'es'; logxcroak ++$level, "unknown switch$es: " . join(", ", @unprocessed); } sub q { local $_ = shift; s/^://gm; return $_; } 1; __END__ =head1 NAME Getargs::Long - Named subroutine arguments, with optional type checking =head1 SYNOPSIS use Getargs::Long; # case sensitive use Getargs::Long qw(ignorecase); # case insensitive # Simple, args mandatory my ($val, $other) = getargs(@_, qw(val other)); # Simple, args optional (in [] means optional) my ($val, $other) = getargs(@_, [qw(val other)]); # Simple with typechecking, args mandatory my ($val, $other) = getargs(@_, qw(val=Class::X other=ARRAY)); # Simple with typechecking, args optional my ($val, $other) = getargs(@_, [qw(val=Class::X other=ARRAY)]); # Faster version, building dedicated argument parsing routine my ($val, $other) = cgetargs(@_, qw(val other)); # Other cases, use full specs: my ($x, $y, $z, $a, $b, $c) = xgetargs(@_, # Non-mandatory, defaults to undef unless specified otherwise 'x' => ['i'], # integer, no default 'y' => ['ARRAY', ['a', 'b']], # Has a default 'z' => [], # No typecheck, can be anything # Mandatory arguments 'a' => 'i', # integer (scalar) 'b' => 'TYPE', # TYPE or any heir of TYPE 'c' => undef, # unspecified type but mandatory ); # Extract remaining unparsed args in @extra my ($val, $other, @extra) = getargs(@_, { -strict => 0 }, qw(val other)); # Alter behaviour of the getargs() routines via switches in hashref my ($val, $other) = getargs(@_, { -strict => 1, # unknown switches are fatal -ignorecase => 1, # override package's global -inplace => 1, # edit @_ inplace: remove parsed args -extra => 0, # suppress return of extra arguments }, qw(val other) ); =head1 DESCRIPTION The C module allows usage of named parameters in function calls, along with optional argument type-checking. It provides an easy way to get at the parameters within the routine, and yields concise descriptions for the common cases of all-mandatory and all-optional parameter lists. The validation of arguments can be done by a structure-driven routine getargs() which is fine for infrequently called routines (but should be slower), or via a dedicated routine created and compiled on the fly the fist time it is needed, by using the cgetargs() family (expected to be faster). The C module is used to report errors, which leaves to the application the choice of the final logging method: to a file, to STDERR, or to syslog. =head1 EXAMPLES Before going through the interface specification, a little example will help illustrate both caller and callee sides. Let's write a routine that can be called as either: f(-x => 1, -y => 2, -z => 3); # -switch form f(x => 1, y => 2, z => 3); # concise form (- are optional) f(y => 1, x => 2); # order changed, z may be omitted Since we have an optional parameter I but mandatory I and I, we can't use the short form of getargs() and must therefore use xgetargs(): sub f { my ($x, $y ,$z) = xgetargs(@_, -x => 'i', # mandatory, integer -y => 'i', # mandatory, integer -z => ['i', 0], # optional integer, defaults to 0 ); # code use $x, $y, $z } That's quite simple and direct if you think of [] as "optional". Note that we pass xgetargs() a I to @_. If we had all arguments mandatory and wished to nonethless benefit from the named specification at call time to avoid having the caller remember the exact parameter ordering, we could write: sub f { my ($x, $y ,$z) = getargs(@_, qw(x=i y=i z=i)); # code of f } Without parameter type checking, that would be even more concise. Besides, if f() is frequently called, it might be more efficient to build a routine dynamically to parse the arguments rather than letting getargs() parse the same data structures again and again: sub f { my ($x, $y ,$z) = cgetargs(@_, qw(x y z)); # 'c' for cached/compiled # code of f } If you call f() with an improper argument, logcroak() will be called to issue an exception from the persepective of the caller, i.e. pointing to the place f() is called instead of within f() at the getargs() call, which would be rather useless. Here are some more examples: Example 1 -- All mandatory: sub f { my ($port, $server) = getargs(@_, qw(port=i server=HTTP::Server)); } f(-server => $server, port => 80); # or -port, since - is optional f(port => 80, server => $server); f(server => $server); # WRONG: missing mandatory -port f(server => 80, port => 80); # WRONG: -server not an HTTP::Server f(server => undef, port => 80); # WRONG: -server cannot be undef Example 2 -- All optional sub cmd { my ($a, $o) = getargs(@_, [qw(a o=s)]); } cmd(); # OK cmd(-a => undef); # OK -a accepts anything, even undef cmd(-a => 1, -o => ".."); # OK cmd(-a => 1, -o => undef); # WRONG: -o does not accept undef cmd(-x => 1); # WRONG: -x is not a known argument name Example 3 -- Mixed optional / mandatory sub f { my ($x, $z) = xgetargs(@_, -x => 'i', # -x mandatory integer -z => ['n', -20.4], # -z optional, defaults to -20.4 ); } f(x => 1, z => {}); # WRONG: z is not a numerical value f(z => 1, x => -2); # OK f(-z => 1); # WRONG: mandatory x is missing f(-z => undef); # WRONG: z cannot be undef Example 4 -- Parsing options sub f { my ($x, $z) = xgetargs(@_, { -strict => 0, -ignorecase => 1 }, -x => 'i', # -x mandatory integer -z => ['n', -20.4], # -z optional, defaults to -20.4 ); } f(x => 1, foo => {}); # OK, -foo ignored since not strict f(-X => 1); # OK, -X actually specifies -x with ignorecase =head1 INTERFACE All the routines take a mandatory first argument, called I, which is the array containing the named arguments for the routine (i.e. a succession of I => I tuples). This array is implicitely passed as reference, and will usually be given as C<@_>. All the routines take an optional I argument which comes in the second place. It is an hash reference containing named options that alter the behaviour of the routine. More details given in the L section. All the routines return a list of the arguments in the order they are specified, each I in the list being either the argument value, if present, or C if missing (and not mandatory). =head2 Simple Cases Simple cases are handled by getargs(): named arguments should either be I or I, and there is no provision for specifying a default value for optional parameters. The getargs() routine and its cousin cgetargs() have two different interfaces, depending on whether the arguments are all mandatory or all optional. We'll only specify for getargs(), but the signature of cgetargs() is identical. =over 4 =item getargs I, I, I, I, ... We'll be ignoring the I argument from our discussion. See the L section for details. All the routine formal arguments specified by I, I, etc... are mandatory. If I is only a name, then it specifies a mandatory formal argument of that name, which can be of any type, even undef. If the name is followed by C<=type> then C specifies the argument type: usually a reference type, unless 'i', 'n' or 's' is used for integer, natural and string scalars. Currently, types 'i', 'n' and 's' all mean the same thing: that the argument must be a scalar. A future implementation will probably ensure 'i' and 'n' hold integers and natural numbers respectively, 's' being the placeholder for anything else that is defined. For instance: foo expects mandatory "foo" of "-foo" argument (undef ok) foo=s idem, and argument cannot be undef or reference foo=i value of argument -foo must be an integer foo=My::Package foo is a blessed object, inheriting from My::Package foo=ARRAY foo is an ARRAY reference The rule for determing whether C means C is a reference C or C is an object whose class is an heir of C depends on the argument value at runtime: if it is an unblessed ref, strict reference equality is expected. If it is a blessed ref, type conformance is based on inheritance, as you would expect. Example: sub f { my ($port, $server) = getargs(@_, qw(port=i server=HTTP::Server)); } Some calls: f(-server => $server, port => 80); # or -port, since - is optional f(port => 80, server => $server); f(server => $server); # WRONG: missing mandatory -port f(server => 80, port => 80); # WRONG: -server not an HTTP::Server f(server => undef, port => 80); # WRONG: -server cannot be undef By default, named argument processing is case-sensitive but there is an option to ignore case. =item getargs I, I, I This form specifies that all the formal arguments specified in the I are optional. Think of the '[' and ']' (which you'll probably use to supply the reference as a manifest constant) as syntactic markers for optional things. In the traditional Unix command line description, something like: cmd [-a] [-o file] typically denotes that options C<-a> and C<-o> are optional, and that C<-o> takes one argument, a file name. To specify the same things for routine arguments using getargs(): sub cmd { my ($a, $o) = getargs(@_, [qw(a o=s)]); } Here however, the C<-a> argument can be anything: we're not specifying switches, we're specifying I arguments. Big difference. Some calls: cmd(); # OK cmd(-a => undef); # OK -a accepts anything, even undef cmd(-a => 1, -o => ".."); # OK cmd(-a => 1, -o => undef); # WRONG: -o does not accept undef cmd(-x => 1); # WRONG: -x is not a known argument name It is important to note that there can only be tuples when using named arguments, which means that the routine is called with an I number of arguments. If you forget a C<,> separator between arguments, getargs() will complain about an I number of arguments (provided the resulting code still parses as valid Perl, naturally, or you'll never get a chance to reach the execution of getargs() anyway). =item cgetargs I The cgetargs() routine behaves exactly as the getargs() routine: it takes the same arguments, returns the same list. The only difference is that the first time it is called, it builds a routine to process the arguments, and then calls it. On subsequent calls to cgetargs() for the same routine, the cached argument parsing routine is re-used to analyze the arguments. For frequently called routines, this might be a win, even though Perl still needs to construct the argument list to cgetargs() and call it. =back =head2 Complex Cases The xgetargs() routine and its cousin cxgetargs() (for the caching version) allow for a more verbose description of named parameters which allows specifying arguments that are mandatory or optional, and also give default values to optional arguments. =over 4 =item xgetargs I, I, I => I, ... We'll be ignoring the I argument from our discussion. See L for details. There can be as many I => I tuples as necessary to describe all the formal arguments of the routine. The I refers to the argument name, and I specifies both the mandatory nature and the expected type. You may use I or I<-name> to specify an argument called I, and the caller will also be able to spell it as he wishes. The I is encoded as follows: "i" mandatory integer (scalar) "s" mandatory string (scalar) "TYPE" mandatory ref of type TYPE, or heir of type TYPE undef unspecified type, but mandatory argument ["i"] optional integer ["s"] optional string ["TYPE"] optional ref of type TYPE, or heir of type TYPE For optional parameter, an optional second value may be inserted in the list to specify a default value. For instance, the tupple: 'y' => ['HASH', { a => 1, b => 2 }] specifies an optional named argument I, which is expected to be a HASH reference, and whose default value is the hash given. You may specify an expression as default value instead of giving a manifest constant, but B: the cxgetargs() routine will take a snapshot of your expression when building its analyzing routine. It's of no consequence when using a manifest constant, but when using an expression, it will be evaluated B and the result of that evaluation will be taken as the manifest constant to use subsequently (and this does B mean the B reference will be returned, only the same topological structure as the one we evaluated during caching). Example: sub f { my ($x, $z) = cxgetargs(@_, -x => 'i', # -x mandatory integer -z => ['n', -20.4], # -z optional, defaults to -20.4 ); } f(x => 1, z => {}); # WRONG: z is not a numerical value f(z => 1, x => -2); # OK f(-z => 1); # WRONG: mandatory x is missing f(-z => undef); # WRONG: z cannot be undef Remember that we are dealing with named parameters for a routine call, not with option parsing. Therefore, we are always expecting an I number of arguments, and those arguments are tuples I => I. =back =head2 Options All the getargs() and xgetargs() routines take an optional hash reference as second argument. Keys in this hash define options that apply locally to the call. In the case of caching routines, e.g. cxgetargs(), the options are only considered the first time, when the analyzing routine is built, and are ignored on subsequent calls. Therefore, it is wise to use manifest constants when specifying options, or use the non-caching function family instead if your options need to be dynamically computed (please, don't do that). Options given there must be spelled out with the leading C<-> and are case sensitive. To enable an option, give a true value. For instance: sub f { my ($x, $z) = cxgetargs(@_, { -strict => 0, -ignorecase => 1 }, -x => 'i', # -x mandatory integer -z => ['n', -20.4], # -z optional, defaults to -20.4 ); } supplies two options, turning C<-ignorecase> on and C<-strict> off. The available options are, in alphabetical order: =over 4 =item -extra Whether to report extra unknown arguments at the end of the argument list. Example: my ($x, $y, @extra) = getargs(@_, { -extra => 1, -strict => 0 }, qw(x y)); Your setting is forced to false when C<-strict> is true. The default value is the negation of the boolean C<-strict> setting, which means the above can be rewritten as: my ($x, $y, @extra) = getargs(@_, { -strict => 0 }, qw(x y)); which will implicitely set -extra to be true. This is usually what you want when not strict, i.e. get at the other parameters. Assuming we were writing the above for a function f(), calling: f(-x => 1, -y => 2, -other => 5); would set: @extra = (-other => 5); An alternative when you are not strict is to make use of the C<-inplace> option to edit @_ inplace. =item -ignorecase Turn case-insensitive named parameters. False by default. Actually, if not explicitely specified, the default setting depends on the way C was imported within the package scope. If you said: use Getargs::Long; then the default is indeed to be case-sensitive. However, if you said: use Getargs::Long qw(ignorecase); then the default for the package scope is to be case-insensitive. You may still specify the C<-ignorecase> option to force case sensitivity on a per-routine basis, although I would never do such a thing and stick to a uniform case sensitivity on a package basis. =item -inplace Whether to edit the routine's argument list inplace, removing processed arguments as they are found and leaving unprocessed ones. False by default. Your setting is forced to false when C<-strict> is true, naturally, since an unknown argument is an error. =item -strict Whether unknown named parameters are fatal. True by default. When C<-strict> is true, the C<-inplace> and C<-extra> options you may specify are ignored and forced to false. =back =head1 BUGS Currently, types 'i', 'n' and 's' all mean the same thing, but that will change. Don't take the current implementation's deficiency as an excuse for lamely specifying your scalar types. You must be careful in this implementation to list options and variables in the very same order. Some day, I will probably add another routine to take arguments the way C does to cope with this ordering problem (but it forces to spell out variables twice -- once for declaration, and once for specifying a pointer to it). =head1 RELATED MODULE See L for another take at parameter validation. It is a completely independant module, developped by Dave Rolsky, which may also interest you. Its interface and purpose are different though. =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR The original code (written before September 15, 2004) was written by Raphael Manfredi ERaphael_Manfredi@pobox.comE. Maintenance of this module is now being done by David Coppit Edavid@coppit.orgE. =head1 SEE ALSO L, L =cut Getargs-Long-1.1003/Makefile.PL0000755000076500000240000000056211037261534015232 0ustar coppitstaff#!/usr/bin/perl use strict; use inc::Module::Install; die "This module is known to exercise a bug in 5.6.0. Please upgrade your perl.\n" if $] eq '5.006'; all_from ('lib/Getargs/Long.pm'); requires ( 'Log::Agent' => '0.105', ); test_requires ( 'Test::More' => 0, ); WriteAll(); Getargs-Long-1.1003/MANIFEST0000644000076500000240000000062211037261636014406 0ustar coppitstaffCHANGES MANIFEST Makefile.PL README # The module files lib/Getargs/Long.pm # Tests t/cache.t t/case.t t/getargs.t t/nocache.t t/code.pl # Module::Install extensions inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm META.yml Getargs-Long-1.1003/META.yml0000644000076500000240000000077511037262000014521 0ustar coppitstaff--- abstract: 'Named subroutine arguments, with optional type checking' author: - 'The original code (written before September 15, 2004) was written by ' build_requires: Test::More: 0 distribution_type: module generated_by: 'Module::Install version 0.75' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 module_name: Getargs::Long name: Getargs-Long no_index: directory: - inc - t requires: Log::Agent: 0.105 perl: 5.005 version: 1.1003 Getargs-Long-1.1003/README0000644000076500000240000000511311037260164014130 0ustar coppitstaffGetargs::Long - Named subroutine arguments, with optional type checking The "Getargs::Long" module allows usage of named parameters in function calls, along with optional argument type-checking. It provides an easy way to get at the parameters within the routine, and yields concise descriptions for the common cases of all-mandatory and all-optional parameter lists. *** This is alpha software -- use at your own risk *** MODULE DEPENDENCIES To use this module, you will need to install: - Log::Agent - version::Limit You should be prompted to install this module automatically when you run "perl Makefile.PL". INSTALLATION To install this package, change to the directory where you unarchived this distribution and type the following: perl Makefile.PL make make test make install You can install this package into a non-default location by appending one of the following to the "perl Makefile.PL" command: - "PREFIX=/installation/path" (for installation into a custom location), - "INSTALLDIRS=site" (for installation into site-specific Perl directories) - "INSTALLDIRS=perl" (for installation into standard Perl directories). If you make the installation into your own directory, then remember that you must tell perl where to search for modules before trying to 'use' them. For example: use lib '/home/userid/lib'; use Getargs::Long; INSTALLATION PROBLEMS If "make test" fails, run make test TEST_VERBOSE=1 and see which test(s) are failing. Please email the results to the address below, or submit a bug report on the project website as described in the section REPORTING BUGS below. For other bugs, see the section REPORTING BUGS below. DOCUMENTATION Just "perldoc Getargs::Long". After installation on Unix systems, you can also do "man Getargs::Long". HOMEPAGE Visit http://coppit.org/code/ for the latest version. KNOWN BUGS This module is known to exercise a bug in perl 5.6.0. Don't use that version of perl: use 5.005_03, or try 5.6.1. The interface of this module changed between 0.1.2 and 0.1.3, and is NOT backward compatible. REPORTING BUGS Send email to David Coppit . COPYRIGHT Copyright (c) Mar 2 2001-Mar 20 2001 Raphael Manfredi. Copyright (c) Mar 20 2001-2004 David Coppit. All rights reserved, save those granted by the license. LICENSE Copyright (c) 1995 Your Name. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5 itself. AUTHOR David Coppit (current maintainer) Raphael Manfredi (original author) Getargs-Long-1.1003/t/0000755000076500000240000000000011037262003013505 5ustar coppitstaffGetargs-Long-1.1003/t/cache.t0000755000076500000240000000360610474632745014767 0ustar coppitstaff#!/usr/bin/perl use Getargs::Long qw(ignorecase); use Test::More tests => 19; require 't/code.pl'; ## same test case as t/nocache.t, only with c*() routines. package BAR; sub make { bless {}, shift } package FOO; @ISA = qw(BAR); package main; my $FOO = FOO->make; my $BAR = BAR->make; sub try { my ($x, $y, $z, $t, $o, @other) = cxgetargs(@_, { -strict => 0, -extra => 0, -inplace => 1, }, 'x' => ['i', 1], -y => ['ARRAY', ['a', 'b']], 'z' => [], 't' => ['FOO', $FOO], -o => 'i', ); return ([$x, $y, $z, $t, $o], \@other, [@_]); } sub tryw { my ($x, $y, $l, $z, $t) = cxgetargs(@_, 'x' => ['i'], # integer, non-mandatory 'y' => ['ARRAY', ['a', 'b']], # Type, non-mandatory, default 'l' => [], # anything, non-mandatory 'z' => undef, # anything, mandatory 't' => 'BAR' # Type, mandatory ); return ($x, $y, $z, $t); } my @a; my ($x, $y, $z, $t); my @other; my @args; @a = try(-o => -2, -t => $FOO, -Other => 2, ONE => 3); ($x, $y, $z, $t, $o) = @{$a[0]}; ok($x); is(ref $y, 'ARRAY'); is($y->[0],'a'); ok(!defined $z); is(ref $t,'FOO'); is($o,-2); @other = @{$a[1]}; is(scalar @other,0); @args = @{$a[2]}; is(@args,4); is("@args","-Other 2 ONE 3"); eval { try(-t => $FOO) }; like($@,qr/\bargument 'o' missing\b/); @a = try(-o => 1, -z => 'z', y => [], x => 5); ($x, $y, $z, $t, $o) = @{$a[0]}; is($x,5); is($z,'z'); is(ref $y,'ARRAY'); is(scalar @$y,0); eval { try(-o => undef, -z => 'z', y => [], x => 5) }; like($@, qr/'o' cannot be undef\b/); eval { tryw(-Z => 'BIG Z', y => [], x => 5) }; like($@,qr/\bargument 't' missing\b/); ($x, $y, $z, $t) = tryw(-Z => 'BIG Z', y => [], x => 5, -t => $FOO); is(ref $t,'FOO'); eval { tryw(-T => 1, -Z => 'BIG Z', y => [], x => 5) }; like($@,qr/'t' must be of type BAR but/); eval { tryw(-T => $BAR, -Z => 'BIG Z', y => [], x => 5, -ExtraArg => 'extra-VALUE') }; like($@,qr/\bswitch: -extraarg\b/); Getargs-Long-1.1003/t/case.t0000755000076500000240000000130410474632745014630 0ustar coppitstaff#!./perl use Test::More tests => 9; require 't/code.pl'; package SENSITIVE; use Getargs::Long; sub f { my ($x, $X) = getargs(@_, { -strict => 0 }, qw(x X)); return ($x, $X); } package INSENSITIVE; use Getargs::Long qw(ignorecase); sub f { my ($x, $Y) = getargs(@_, { -strict => 0 }, qw(x Y)); return ($x, $Y); } package OPTION; use Getargs::Long; sub f { my ($x, $Y) = getargs(@_, { -strict => 0, -ignorecase => 1 }, qw(x Y)); return ($x, $Y); } package main; my @a; @a = SENSITIVE::f(-x => 1, -X => 2); is(@a,2); is($a[0],1); is($a[1],2); @a = INSENSITIVE::f(-x => 1, -y => 2); is(@a,2); is($a[0],1); is($a[1],2); @a = OPTION::f(-x => 1, -y => 2); is(@a,2); is($a[0],1); is($a[1],2); Getargs-Long-1.1003/t/code.pl0000755000076500000240000000134010474632753014776 0ustar coppitstaff# # $Id: code.pl,v 1.1.1.1 2004/09/22 17:32:58 coppit Exp $ # # Copyright (c) 2000-2001, Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: code.pl,v $ # Revision 1.1.1.1 2004/09/22 17:32:58 coppit # initial import # # Revision 0.1.1.1 2001/03/02 17:59:48 ram # patch1: added. # # Revision 0.1 2001/03/01 14:46:55 manfredi # Initial revision. # # $EndLog$ # sub contains { my ($file, $pattern) = @_; local *FILE; local $_; open(FILE, $file) || die "can't open $file: $!\n"; my $found = 0; while () { if (/$pattern/) { $found = 1; last; } } close FILE; return $found; } 1; Getargs-Long-1.1003/t/getargs.t0000755000076500000240000000214310474632745015353 0ustar coppitstaff#!./perl use Getargs::Long; use Test::More tests => 12; require 't/code.pl'; package BAR; sub make { bless {}, shift } package FOO; @ISA = qw(BAR); package main; my $FOO = FOO->make; my $BAR = BAR->make; sub try { my ($x, $y, $z, $t) = getargs(@_, qw(x=i y=ARRAY z t=FOO)); return ($x, $y, $z, $t); } sub tryw { my ($x, $y, $z, $t) = getargs(@_, [qw(x=i y=ARRAY z t=FOO)]); return ($x, $y, $z, $t); } my ($x, $y, $z, $t); eval { try(-x => -2, -t => $FOO, -Other => 1, -y => [], -z => undef) }; like($@,qr/switch: -Other\b/); eval { try(-x => -2, -t => $FOO, -Y => [], -z => undef) }; like($@,qr/\bargument 'y' missing\b/); ($x, $y, $z, $t) = try(-x => -2, -t => $FOO, -y => [qw(A C)], -z => undef); is($x,-2); is(ref $y eq 'ARRAY' && $y->[1] eq 'C',1); ok(!defined $z); is(ref $t,'FOO'); eval { tryw(-x => -2, -t => $FOO, -Other => 1, -y => [], -z => undef) }; like($@,qr/switch: -Other\b/); eval { tryw(-x => -2, -t => $FOO, -Y => [], -z => undef) }; like($@,qr/switch: -Y\b/); ($x, $y, $z, $t) = tryw(-t => $FOO, -z => []); ok(!defined $x); ok(!defined $y); is(ref $z,'ARRAY'); is(ref $t,ref $FOO); Getargs-Long-1.1003/t/nocache.t0000755000076500000240000000372510474632745015326 0ustar coppitstaff#!./perl use Getargs::Long qw(ignorecase); use Test::More tests => 23; require 't/code.pl'; ## same test case as t/cache.t, only without using c*() routines. package BAR; sub make { bless {}, shift } package FOO; @ISA = qw(BAR); package main; my $FOO = FOO->make; my $BAR = BAR->make; sub try { my ($x, $y, $z, $t, $o, @other) = xgetargs(@_, { -strict => 0, -extra => 0, -inplace => 1, }, 'x' => ['i', 1], -y => ['ARRAY', ['a', 'b']], 'z' => [], 't' => ['FOO', $FOO], -o => 'i', ); return ([$x, $y, $z, $t, $o], \@other, [@_]); } sub tryw { my ($x, $y, $l, $z, $t) = xgetargs(@_, 'x' => ['i'], # integer, non-mandatory 'y' => ['ARRAY', ['a', 'b']], # Type, non-mandatory, default 'l' => [], # anything, non-mandatory 'z' => undef, # anything, mandatory 't' => 'BAR' # Type, mandatory ); return ($x, $y, $z, $t); } my @a; my ($x, $y, $z, $t); my @other; my @args; @a = try(-o => -2, -t => $FOO, -Other => 2, ONE => 3); ($x, $y, $z, $t, $o) = @{$a[0]}; ok($x); is(ref $y,'ARRAY'); is($y->[0],'a'); ok(!defined $z); is(ref $t,'FOO'); is($o,-2); @other = @{$a[1]}; is(scalar @other,0); @args = @{$a[2]}; is(scalar @args,4); is("@args","-Other 2 ONE 3"); eval { try(-t => $FOO) }; like($@,qr/\bargument 'o' missing\b/); @a = try(-o => 1, -z => 'z', y => [], x => 5); ($x, $y, $z, $t, $o) = @{$a[0]}; is($x,5); is($z,'z'); is(ref $y,'ARRAY'); is(scalar @$y,0); is(ref $y,'ARRAY'); is(scalar @$y,0); is(ref $y,'ARRAY'); is(scalar @$y,0); eval { try(-o => undef, -z => 'z', y => [], x => 5) }; like($@,qr/'o' cannot be undef\b/); eval { tryw(-Z => 'BIG Z', y => [], x => 5) }; like($@,qr/\bargument 't' missing\b/); ($x, $y, $z, $t) = tryw(-Z => 'BIG Z', y => [], x => 5, -t => $FOO); is(ref $t,'FOO'); eval { tryw(-T => 1, -Z => 'BIG Z', y => [], x => 5) }; like($@,qr/'t' must be of type BAR but/); eval { tryw(-T => $BAR, -Z => 'BIG Z', y => [], x => 5, -ExtraArg => 'extra-VALUE') }; like($@,qr/\bswitch: -extraarg\b/);