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