From: Stevan Little Date: Wed, 7 Mar 2007 05:01:08 +0000 (+0000) Subject: Adding MooseX::Getopt first draft X-Git-Tag: 0_01^0 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5dac17c3fb3f25ba558e70565462826017f0c91c;p=gitmo%2FMooseX-Getopt.git Adding MooseX::Getopt first draft --- 5dac17c3fb3f25ba558e70565462826017f0c91c diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..1a5fa23 --- /dev/null +++ b/Build.PL @@ -0,0 +1,26 @@ +use Module::Build; + +use strict; + +my $build = Module::Build->new( + module_name => 'MooseX::Getopt', + license => 'perl', + requires => { + 'Moose' => '0.17', + 'Getopt::Long' => '0', + }, + optional => { + }, + build_requires => { + 'Test::More' => '0.62', + 'Test::Exception' => '0.21', + }, + create_makefile_pl => 'traditional', + recursive_test_files => 1, + add_to_cleanup => [ + 'META.yml', '*.bak', '*.gz', 'Makefile.PL', + ], +); + +$build->create_build_script; + diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..b421b5d --- /dev/null +++ b/ChangeLog @@ -0,0 +1,4 @@ +Revision history for Perl extension MooseX-Getopt + +0.01 + - module created \ No newline at end of file diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..e69de29 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..3de3ebc --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,19 @@ +^_build +^Build$ +^blib +~$ +\.bak$ +^MANIFEST\.SKIP$ +CVS +\.svn +\.DS_Store +cover_db +\..*\.sw.?$ +^Makefile$ +^pm_to_blib$ +^MakeMaker-\d +^blibdirs$ +\.old$ +^#.*#$ +^\.# +^TODO$ \ No newline at end of file diff --git a/README b/README new file mode 100644 index 0000000..0b60b0f --- /dev/null +++ b/README @@ -0,0 +1,30 @@ +MooseX::Getopt version 0.01 +=========================== + +See the individual module documentation for more information + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + Moose + Getopt::Long + +COPYRIGHT AND LICENCE + +Copyright (C) 2007 Infinity Interactive, Inc. + +http://www.iinteractive.com + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm new file mode 100644 index 0000000..fc64f06 --- /dev/null +++ b/lib/MooseX/Getopt.pm @@ -0,0 +1,114 @@ + +package MooseX::Getopt; +use Moose::Role; + +use Getopt::Long; + +use MooseX::Getopt::OptionTypes; +use MooseX::Getopt::Meta::Attribute; + +sub new_with_options { + my ($class, %params) = @_; + + my (%options, %constructor_options); + foreach my $attr ($class->meta->compute_all_applicable_attributes) { + my $name = $attr->name; + + if ($attr->isa('MooseX::Getopt::Meta::Attribute') && $attr->has_cmd_flag) { + $name = $attr->cmd_flag; + } + + my $init_arg = $attr->init_arg; + + # create a suitable default value + $constructor_options{$init_arg} = ''; + + if ($attr->has_type_constraint) { + my $type_name = $attr->type_constraint->name; + if (MooseX::Getopt::OptionTypes->has_option_type($type_name)) { + $name .= MooseX::Getopt::OptionTypes->get_option_type($type_name); + } + } + + $options{$name} = \($constructor_options{$init_arg}); + } + + GetOptions(%options); + + # filter out options which + # were not passed at all + %constructor_options = map { + $constructor_options{$_} ne '' + ? ($_ => $constructor_options{$_}) + : () + } keys %constructor_options; + + $class->new(%params, %constructor_options); +} + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::Getopt - + +=head1 SYNOPSIS + + ## In your class + package My::App; + use Moose; + + with 'MooseX::Getopt'; + + has 'out' => (is => 'rw', isa => 'Str', required => 1); + has 'in' => (is => 'rw', isa => 'Str', required => 1); + + # ... rest of the class here + + ## in your script + #!/usr/bin/perl + + use My::App; + + my $app = My::App->new_with_options(); + # ... rest of the script here + + ## on the command line + % perl my_app_script.pl -in file.input -out file.dump + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/MooseX/Getopt/Meta/Attribute.pm b/lib/MooseX/Getopt/Meta/Attribute.pm new file mode 100644 index 0000000..5f35fec --- /dev/null +++ b/lib/MooseX/Getopt/Meta/Attribute.pm @@ -0,0 +1,59 @@ + +package MooseX::Getopt::Meta::Attribute; +use Moose; + +extends 'Moose::Meta::Attribute'; + +has 'cmd_flag' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_cmd_flag', +); + +1; + +__END__ + + +=pod + +=head1 NAME + +MooseX::Getopt::Meta::Attribute - + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/MooseX/Getopt/OptionTypes.pm b/lib/MooseX/Getopt/OptionTypes.pm new file mode 100644 index 0000000..0acaa76 --- /dev/null +++ b/lib/MooseX/Getopt/OptionTypes.pm @@ -0,0 +1,62 @@ + +package MooseX::Getopt::OptionTypes; +# this maps option types to Moose types + +my %option_types = ( + 'Bool' => '!', + 'Str' => '=s', + 'Int' => '=i', + 'Float' => '=f', + 'ArrayRef' => '=s@', +); + +sub has_option_type { exists $option_types{$_[1]} } +sub get_option_type { $option_types{$_[1]} } + +1; + +__END__ + + +=pod + +=head1 NAME + +MooseX::Getopt::OptionTypes - + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/000_load.t b/t/000_load.t new file mode 100644 index 0000000..a06573d --- /dev/null +++ b/t/000_load.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('MooseX::Getopt'); +} diff --git a/t/001_basic.t b/t/001_basic.t new file mode 100644 index 0000000..2be04b1 --- /dev/null +++ b/t/001_basic.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; + +BEGIN { + use_ok('MooseX::Getopt'); +} + +{ + package App; + use Moose; + + with 'MooseX::Getopt'; + + has 'data' => ( + metaclass => 'MooseX::Getopt::Meta::Attribute', + is => 'ro', + isa => 'Str', + default => 'file.dat', + cmd_flag => 'f', + ); + + has 'length' => ( + is => 'ro', + isa => 'Int', + default => 24 + ); + + has 'verbose' => ( + is => 'ro', + isa => 'Bool', + ); + +} + +{ + local @ARGV = (); + + my $app = App->new_with_options; + isa_ok($app, 'App'); + + ok(!$app->verbose, '... verbosity is off as expected'); + is($app->length, 24, '... length is 24 as expected'); + is($app->data, 'file.dat', '... data is file.dat as expected'); +} + +{ + local @ARGV = ('-verbose', '-length', 50); + + my $app = App->new_with_options; + isa_ok($app, 'App'); + + ok($app->verbose, '... verbosity is turned on as expected'); + is($app->length, 50, '... length is 50 as expected'); + is($app->data, 'file.dat', '... data is file.dat as expected'); +} + +{ + local @ARGV = ('-verbose', '-f', 'foo.txt'); + + my $app = App->new_with_options; + isa_ok($app, 'App'); + + ok($app->verbose, '... verbosity is turned on as expected'); + is($app->length, 24, '... length is 24 as expected'); + is($app->data, 'foo.txt', '... data is foo.txt as expected'); +} + +{ + local @ARGV = ('-noverbose'); + + my $app = App->new_with_options; + isa_ok($app, 'App'); + + ok(!$app->verbose, '... verbosity is turned off as expected'); + is($app->length, 24, '... length is 24 as expected'); + is($app->data, 'file.dat', '... file is file.dat as expected'); +} + + + diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..7569358 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; + +all_pod_coverage_ok();