1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2022-2024 -- leonerd@leonerd.org.uk
package Commandable::Finder::MethodAttributes 0.14;
use v5.14;
use warnings;
use experimental qw( signatures );
use base qw( Commandable::Finder::SubAttributes );
use Carp;
=head1 NAME
C<Commandable::Finder::MethodAttributes> - find commands stored as methods with attributes
=head1 SYNOPSIS
use Commandable::Finder::MethodAttributes;
my $object = SomeClass->new( ... );
my $finder = Commandable::Finder::MethodAttributes->new(
object => $object,
);
my $help_command = $finder->find_command( "help" );
foreach my $command ( $finder->find_commands ) {
...
}
=head1 DESCRIPTION
This subclass of L<Commandable::Finder::SubAttributes> looks for methods that
define commands, where each command is provided by an individual method in a
given class. It stores the object instance and arranges that each discovered
command method will capture it, passing it as the first argument when invoked.
The attributes on each method are those given by
C<Commandable::Finder::SubAttributes> and are used in the same way here.
=cut
=head1 CONSTRUCTOR
=cut
=head2 new
$finder = Commandable::Finder::MethodAttributes->new( %args )
Constructs a new instance of C<Commandable::Finder::MethodAttributes>.
Takes the following named arguments:
=over 4
=item object => OBJ
An object reference. Its class will be used for searching for command methods.
The instance itself is stored by the finder object and used to wrap each
command method.
=back
Any additional arguments are passed to the superclass constructor.
=cut
sub new ( $class, %args )
{
my $object = delete $args{object} or croak "Require 'object'";
$args{package} = ref $object;
my $self = $class->SUPER::new( %args );
$self->{object} = $object;
return $self;
}
sub _wrap_code ( $self, $code )
{
my $object = $self->{object};
return sub {
$object->$code( @_ );
};
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;
|
