Commit | Line | Data |
5dac17c3 |
1 | |
2 | package MooseX::Getopt; |
3 | use Moose::Role; |
4 | |
5 | use Getopt::Long; |
6 | |
7 | use MooseX::Getopt::OptionTypes; |
8 | use MooseX::Getopt::Meta::Attribute; |
9 | |
10 | sub new_with_options { |
11 | my ($class, %params) = @_; |
12 | |
13 | my (%options, %constructor_options); |
14 | foreach my $attr ($class->meta->compute_all_applicable_attributes) { |
15 | my $name = $attr->name; |
16 | |
17 | if ($attr->isa('MooseX::Getopt::Meta::Attribute') && $attr->has_cmd_flag) { |
18 | $name = $attr->cmd_flag; |
19 | } |
20 | |
21 | my $init_arg = $attr->init_arg; |
22 | |
23 | # create a suitable default value |
24 | $constructor_options{$init_arg} = ''; |
25 | |
26 | if ($attr->has_type_constraint) { |
27 | my $type_name = $attr->type_constraint->name; |
28 | if (MooseX::Getopt::OptionTypes->has_option_type($type_name)) { |
29 | $name .= MooseX::Getopt::OptionTypes->get_option_type($type_name); |
30 | } |
31 | } |
32 | |
33 | $options{$name} = \($constructor_options{$init_arg}); |
34 | } |
35 | |
36 | GetOptions(%options); |
37 | |
38 | # filter out options which |
39 | # were not passed at all |
40 | %constructor_options = map { |
41 | $constructor_options{$_} ne '' |
42 | ? ($_ => $constructor_options{$_}) |
43 | : () |
44 | } keys %constructor_options; |
45 | |
46 | $class->new(%params, %constructor_options); |
47 | } |
48 | |
49 | 1; |
50 | |
51 | __END__ |
52 | |
53 | =pod |
54 | |
55 | =head1 NAME |
56 | |
57 | MooseX::Getopt - |
58 | |
59 | =head1 SYNOPSIS |
60 | |
61 | ## In your class |
62 | package My::App; |
63 | use Moose; |
64 | |
65 | with 'MooseX::Getopt'; |
66 | |
67 | has 'out' => (is => 'rw', isa => 'Str', required => 1); |
68 | has 'in' => (is => 'rw', isa => 'Str', required => 1); |
69 | |
70 | # ... rest of the class here |
71 | |
72 | ## in your script |
73 | #!/usr/bin/perl |
74 | |
75 | use My::App; |
76 | |
77 | my $app = My::App->new_with_options(); |
78 | # ... rest of the script here |
79 | |
80 | ## on the command line |
81 | % perl my_app_script.pl -in file.input -out file.dump |
82 | |
83 | =head1 DESCRIPTION |
84 | |
85 | =head1 METHODS |
86 | |
87 | =over 4 |
88 | |
89 | =item B<new_with_options (%params)> |
90 | |
91 | =item B<meta> |
92 | |
93 | =back |
94 | |
95 | =head1 BUGS |
96 | |
97 | All complex software has bugs lurking in it, and this module is no |
98 | exception. If you find a bug please either email me, or add the bug |
99 | to cpan-RT. |
100 | |
101 | =head1 AUTHOR |
102 | |
103 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
104 | |
105 | =head1 COPYRIGHT AND LICENSE |
106 | |
107 | Copyright 2007 by Infinity Interactive, Inc. |
108 | |
109 | L<http://www.iinteractive.com> |
110 | |
111 | This library is free software; you can redistribute it and/or modify |
112 | it under the same terms as Perl itself. |
113 | |
114 | =cut |