1use 5.006;
2use warnings;
3use strict;
4
5package Class::Accessor::Installer;
6our $VERSION = '1.100880';
7
8# ABSTRACT: Install an accessor subroutine
9use Sub::Name;
10use UNIVERSAL::require;
11
12sub install_accessor {
13    my ($self, %args) = @_;
14    my ($package, $name, $code) = @args{qw(package name code)};
15    unless (defined $package) {
16        $package = ref $self || $self;
17    }
18    $name = [$name] unless ref $name eq 'ARRAY';
19    my @caller;
20    if ($::PTAGS) {
21        my $level = 1;
22        do { @caller = caller($level++) }
23          while $caller[0] =~ /^Class(::\w+)*::Accessor::/o;
24    }
25    for my $sub (@$name) {
26        no strict 'refs';
27        $::PTAGS && $::PTAGS->add_tag($sub, $caller[1], $caller[2]);
28        *{"${package}::${sub}"} = subname "${package}::${sub}" => $code;
29    }
30}
31
32sub document_accessor {
33    my ($self, %args) = @_;
34
35    # Don't use() it - this should still work if we don't have
36    # Sub::Documentation.
37    Sub::Documentation->require;
38    return if $@;
39    my $package = delete $args{package};
40    unless (defined $package) {
41        $package = ref $self || $self;
42    }
43    my $name = delete $args{name};
44    $name = [$name] unless ref $name eq 'ARRAY';
45    my $belongs_to = delete $args{belongs_to};
46    while (my ($type, $documentation) = each %args) {
47        Sub::Documentation::add_documentation(
48            package       => $package,
49            name          => $name,
50            glob_type     => 'CODE',
51            type          => $type,
52            documentation => $documentation,
53            ($belongs_to ? (belongs_to => $belongs_to) : ()),
54        );
55    }
56}
571;
58
59
60__END__
61=pod
62
63=head1 NAME
64
65Class::Accessor::Installer - Install an accessor subroutine
66
67=head1 VERSION
68
69version 1.100880
70
71=head1 SYNOPSIS
72
73    package Class::Accessor::Foo;
74
75    use base 'Class::Accessor::Installer';
76
77    sub mk_foo_accessors {
78        my ($self, @fields) = @_;
79        my $class = ref $self || $self;
80
81        for my $field (@fields) {
82            $self->install_accessor(
83                sub     => "${field}_foo",
84                code    => sub { rand() },
85            );
86        }
87
88        my $field = '...';
89        $self->document_accessor(
90            name     => "${field}_foo",
91            purpose  => 'Does this, that and the other',
92            examples => [
93                "my \$result = $class->${field}_foo(\$value)",
94                "my \$result = $class->${field}_foo(\$value, \$value2)",
95            ],
96            belongs_to => 'foo',
97        );
98    }
99
100=head1 DESCRIPTION
101
102This mixin class provides a method that will install a code reference. There
103are other modules that do this, but this one is a bit more specific to the
104needs of L<Class::Accessor::Complex> and friends.
105
106It is intended as a mixin, that is, your accessor-generating class should
107inherit from this class.
108
109=head1 METHODS
110
111=head2 install_accessor
112
113Takes as arguments a named hash. The following keys are recognized:
114
115=over 4
116
117=item C<package>
118
119The package into which to install the subroutine. If this argument is omitted,
120it will inspect C<$self> to determine the package. Class::Accessor::*
121accessor generators are typically used like this:
122
123    __PACKAGE__
124        ->mk_new
125        ->mk_array_accessors(qw(foo bar));
126
127Therefore C<install_accessor()> can determine the right package into which to
128install the subroutine.
129
130=item C<name>
131
132The name or names to use for the subroutine. You can either pass a single
133string or a reference to an array of strings. Each string is interpreted as a
134subroutine name inside the given package, and the code reference is installed
135into the appropriate typeglob.
136
137Why would you want to install a subroutine in more than one place inside your
138package? For example, L<Class::Accessor::Complex> often creates aliases so the
139user can choose the version of the name that reads more naturally.
140
141An example of this usage would be:
142
143        $self->install_accessor(
144            name => [ "clear_${field}", "${field}_clear" ],
145            code => sub { ... }
146        );
147
148=item C<code>
149
150This is the code reference that should be installed.
151
152=back
153
154The installed subroutine is named using L<Sub::Name>, so it shows up with a
155meaningful name in stack traces (instead of as C<__ANON__>). However, the
156inside the debugger, the subroutine still shows up as C<__ANON__>. You might
157therefore want to use the following lines at the beginning of your subroutine:
158
159        $self->install_accessor(
160            name => $field,
161            code => sub {
162                local $DB::sub = local *__ANON__ = "${class}::${field}"
163                    if defined &DB::DB && !$Devel::DProf::VERSION;
164                ...
165        );
166
167Now the subroutine will be named both in a stack trace and inside the
168debugger.
169
170=head2 document_accessor
171
172Adds documentation for an accessor - not necessarily one that has been
173generated with C<install_accessor()>. See L<Sub::Documentation> for details.
174
175Takes as arguments a named hash. The following keys are recognized:
176
177=over 4
178
179=item C<package>
180
181Like the C<package> argument of C<install_accessor()>.
182
183=item C<name>
184
185The name of the accessor being documented. This can be a string or a reference
186to an array of strings, if the same documentation applies to more than one
187method. This can occur, for example, when there are aliases for a method such
188as C<clear_foo()> and C<foo_clear()>.
189
190=item C<purpose>
191
192A string describing the generated method.
193
194=item C<examples>
195
196An array reference containing one or more examples of using the method. These
197will also be used in the generated documentation.
198
199=back
200
201You can pass additional arbitrary key/value pairs; they will be stored as
202well. It depends on your documentation tool which keys are useful. For
203example, L<Class::Accessor::Complex> generates and
204L<Pod::Weaver::Section::CollectWithAutoDoc> supports a C<belongs_to> key that
205shows which generated helper method belongs to which main accessor.
206
207=head1 INSTALLATION
208
209See perlmodinstall for information and options on installing Perl modules.
210
211=head1 BUGS AND LIMITATIONS
212
213No bugs have been reported.
214
215Please report any bugs or feature requests through the web interface at
216L<http://rt.cpan.org/Public/Dist/Display.html?Name=Class-Accessor-Installer>.
217
218=head1 AVAILABILITY
219
220The latest version of this module is available from the Comprehensive Perl
221Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN
222site near you, or see
223L<http://search.cpan.org/dist/Class-Accessor-Installer/>.
224
225The development version lives at
226L<http://github.com/hanekomu/Class-Accessor-Installer/>.
227Instead of sending patches, please fork this project using the standard git
228and github infrastructure.
229
230=head1 AUTHORS
231
232  Marcel Gruenauer <marcel@cpan.org>
233  Florian Helmberger <florian@cpan.org>
234
235=head1 COPYRIGHT AND LICENSE
236
237This software is copyright (c) 2007 by Marcel Gruenauer.
238
239This is free software; you can redistribute it and/or modify it under
240the same terms as the Perl 5 programming language system itself.
241
242=cut
243
244