File Coverage

blib/lib/Commandable/Finder/SubAttributes.pm
Criterion Covered Total %
statement 21 70 30.0
branch 0 16 0.0
condition 0 4 0.0
subroutine 7 14 50.0
pod 5 5 100.0
total 33 109 30.2


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
5              
6             package Commandable::Finder::SubAttributes 0.10;
7              
8 3     3   224838 use v5.14;
  3         20  
9 3     3   16 use warnings;
  3         6  
  3         84  
10 3     3   15 use base qw( Commandable::Finder );
  3         5  
  3         1324  
11              
12 3     3   28 use Carp;
  3         7  
  3         168  
13              
14 3     3   866 use Commandable::Command;
  3         7  
  3         130  
15              
16 3     3   18 use constant HAVE_ATTRIBUTE_STORAGE => eval { require Attribute::Storage };
  3         7  
  3         7  
  3         2816  
17              
18             =head1 NAME
19              
20             C - find commands stored as subs with attributes
21              
22             =head1 SYNOPSIS
23              
24             use Commandable::Finder::SubAttributes;
25              
26             my $finder = Commandable::Finder::SubAttributes->new(
27             package => "MyApp::Commands",
28             );
29              
30             my $help_command = $finder->find_command( "help" );
31              
32             foreach my $command ( $finder->find_commands ) {
33             ...
34             }
35              
36             =head1 DESCRIPTION
37              
38             This implementation of L looks for functions that define
39             commands, where each command is provided by an individual sub in a given
40             package.
41              
42             =head1 ATTRIBUTES
43              
44             use Commandable::Finder::SubAttributes ':attrs';
45              
46             sub command_example
47             :Command_description("An example of a command")
48             {
49             ...
50             }
51              
52             Properties about each command are stored as attributes on the named function,
53             using L.
54              
55             The following attributes are available on the calling package when imported
56             with the C<:attrs> symbol:
57              
58             =head2 Command_description
59              
60             :Command_description("description text")
61              
62             Gives a plain string description text for the command.
63              
64             =head2 Command_arg
65              
66             :Command_arg("argname", "description")
67              
68             Gives a named argument for the command and its description.
69              
70             If the name is suffixed by a C, this argument is optional. (The C itself
71             will be removed from the name).
72              
73             If the name is suffixed by C<...>, this argument is slurpy. (The C<...> itself
74             will be removed from the name).
75              
76             =head2 Command_opt
77              
78             :Command_opt("optname", "description")
79              
80             :Command_opt("optname", "description", "default")
81              
82             Gives a named option for the command and its description.
83              
84             If the name contains C<|> characters it provides multiple name aliases for the
85             same option.
86              
87             If the name field ends in a C<=> character, a value is expected for the
88             option. It can either be parsed from the next input token, or after an C<=>
89             sign of the same token:
90              
91             --optname VALUE
92             --optname=VALUE
93              
94             If the name field ends in a C<@> character, a value is expected for the option
95             and can be specified multiple times. All the values will be collected into an
96             ARRAY reference.
97              
98             If the name field ends in a C<+> character, the option can be specified
99             multiple times and the total count will be used as the value.
100              
101             If the name field ends in a C character, the option is negatable. An option
102             name of C<--no-OPTNAME> is recognised and will reset the value to C. By
103             setting a default of some true value (e.g. C<1>) you can detect if this has
104             happened.
105              
106             An optional third argument may be present to specify a default value, if not
107             provided by the invocation.
108              
109             =cut
110              
111             sub import
112             {
113 2     2   23 my $pkg = shift;
114 2         7 my $caller = caller;
115              
116 2         84 foreach ( @_ ) {
117 0 0         if( $_ eq ":attrs" ) {
118 0 0         HAVE_ATTRIBUTE_STORAGE or
119             croak "Cannot import :attrs as Attribute::Storage is not available";
120              
121 0           require Commandable::Finder::SubAttributes::Attrs;
122 0           Commandable::Finder::SubAttributes::Attrs->import_into( $caller );
123 0           next;
124             }
125              
126 0           croak "Unrecognised import symbol $_";
127             }
128             }
129              
130             =head1 CONSTRUCTOR
131              
132             =cut
133              
134             =head2 new
135              
136             $finder = Commandable::Finder::SubAttributes->new( %args )
137              
138             Constructs a new instance of C.
139              
140             Takes the following named arguments:
141              
142             =over 4
143              
144             =item package => STR
145              
146             The name of the package to look in for command subs.
147              
148             =item name_prefix => STR
149              
150             Optional. Gives the name prefix to use to filter for subs that actually
151             provide a command, and to strip off to find the name of the command. Default
152             C.
153              
154             =item underscore_to_hyphen => BOOL
155              
156             Optional. If true, sub names that contain underscores will be converted into
157             hyphens. This is often useful in CLI systems, allowing commands to be typed
158             with hyphenated names (e.g. "get-thing") while the Perl sub that implements it
159             is named with an underscores (e.g. "command_get_thing"). Defaults true, but
160             can be disabled by passing a defined-but-false value such as C<0> or C<''>.
161              
162             =back
163              
164             Any additional arguments are passed to the C method to be used as
165             configuration options.
166              
167             =cut
168              
169             sub new
170             {
171 0     0 1   my $class = shift;
172 0           my %args = @_;
173              
174 0 0         HAVE_ATTRIBUTE_STORAGE or
175             croak "Cannot create a $class as Attribute::Storage is not available";
176              
177 0 0         my $package = ( delete $args{package} ) or croak "Require 'package'";
178              
179 0   0       my $name_prefix = ( delete $args{name_prefix} ) // "command_";
180 0   0       my $conv_under = ( delete $args{underscore_to_hyphen} ) // 1;
181              
182 0           my $self = bless {
183             package => $package,
184             name_prefix => $name_prefix,
185             conv_under => $conv_under,
186             }, $class;
187              
188 0 0         $self->configure( %args ) if %args;
189              
190 0           return $self;
191             }
192              
193             =head2 new_for_caller
194              
195             =head2 new_for_main
196              
197             $finder = Commandable::Finder::SubAttributes->new_for_caller( %args )
198             $finder = Commandable::Finder::SubAttributes->new_for_main( %args )
199              
200             Convenient wrapper constructors that pass either the caller's package name or
201             C
as the package name. Combined with the C method
202             these are particularly convenient for wrapper scripts:
203              
204             #!/usr/bin/perl
205              
206             use v5.14;
207             use warnings;
208              
209             use Commandable::Finder::SubAttributes ':attrs';
210              
211             exit Commandable::Finder::SubAttributes->new_for_main
212             ->find_and_invoke_ARGV;
213              
214             # command subs go here...
215              
216             =cut
217              
218             sub new_for_caller
219             {
220 0     0 1   my $class = shift;
221 0           return $class->new( package => scalar caller, @_ );
222             }
223              
224             sub new_for_main
225             {
226 0     0 1   my $class = shift;
227 0           return $class->new( package => "main", @_ );
228             }
229              
230             sub _wrap_code
231             {
232 0     0     my $self = shift;
233 0           my ( $code ) = @_;
234              
235 0           return $code;
236             }
237              
238             sub _commands
239             {
240 0     0     my $self = shift;
241              
242 0           my $prefix = qr/$self->{name_prefix}/;
243              
244             my %subs = Attribute::Storage::find_subs_with_attr(
245 0           $self->{package}, "Command_description",
246             matching => qr/^$prefix/,
247             );
248              
249 0           my %commands;
250              
251 0           foreach my $subname ( keys %subs ) {
252 0           my $code = $subs{$subname};
253              
254 0           my $name = $subname =~ s/^$prefix//r;
255 0 0         $name =~ s/_/-/g if $self->{conv_under};
256              
257 0           my $args;
258 0 0         if( $args = Attribute::Storage::get_subattr( $code, "Command_arg" ) ) {
259 0           $args = [ map { Commandable::Command::_Argument->new( %$_ ) } @$args ];
  0            
260             }
261              
262 0           my $opts;
263 0 0         if( $opts = Attribute::Storage::get_subattr( $code, "Command_opt" ) ) {
264 0           $opts = { map { my $o = Commandable::Command::_Option->new( %$_ );
  0            
265 0           map { ( $_ => $o ) } $o->names
  0            
266             } @$opts };
267             }
268              
269             $commands{ $name } = Commandable::Command->new(
270             name => $name,
271             description => Attribute::Storage::get_subattr( $code, "Command_description" ),
272             arguments => $args,
273             options => $opts,
274             package => $self->{package},
275 0           code => $self->_wrap_code( $code ),
276             );
277             }
278              
279 0           $self->add_builtin_commands( \%commands );
280              
281 0           return \%commands;
282             }
283              
284             sub find_commands
285             {
286 0     0 1   my $self = shift;
287              
288 0           return values %{ $self->_commands };
  0            
289             }
290              
291             sub find_command
292             {
293 0     0 1   my $self = shift;
294 0           my ( $cmd ) = @_;
295              
296 0           return $self->_commands->{$cmd};
297             }
298              
299             =head1 AUTHOR
300              
301             Paul Evans
302              
303             =cut
304              
305             0x55AA;