lib/Class/MOP/Method/Generated.pm

   1
   2 package Class::MOP::Method::Generated;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp 'confess';
   8
   9 our $VERSION   = '0.94';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method';
  14
  15 use constant _PRINT_SOURCE => $ENV{MOP_PRINT_SOURCE} ? 1 : 0;
  16
  17 ## accessors
  18
  19 # FIXME refactor into a trait when those are introduced to Class::MOP
  20
  21 sub new {
  22     confess __PACKAGE__ . " is an abstract base class, you must provide a constructor.";
  23 }
  24
  25 sub _initialize_body {
  26     confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
  27 }
  28
  29 sub body {
  30     my $self = shift;
  31
  32     $self->{'body'} ||= $self->_initialize_body;
  33 }
  34
  35 sub _eval_closure {
  36     # my ($self, $captures, $sub_body) = @_;
  37     my $__captures = $_[1];
  38
  39     my $code;
  40
  41     my $e = do {
  42         local $@;
  43         local $SIG{__DIE__};
  44         my $source = join
  45             "\n", (
  46             map {
  47                 /^([\@\%\$])/
  48                     or die "capture key should start with \@, \% or \$: $_";
  49                 q[my ]
  50                     . $_ . q[ = ]
  51                     . $1
  52                     . q[{$__captures->{']
  53                     . $_ . q['}};];
  54                 } keys %$__captures
  55             ),
  56             $_[2];
  57         print STDERR "\n", $_[0]->name, ":\n", $source, "\n" if _PRINT_SOURCE;
  58         $code = eval $source;
  59         $@;
  60     };
  61
  62     return ( $code, $e );
  63 }
  64
  65 sub _add_line_directive {
  66     my ( $self, %args ) = @_;
  67
  68     my ( $line, $file );
  69
  70     if ( my $ctx = ( $args{context} || $self->definition_context ) ) {
  71         $line = $ctx->{line};
  72         if ( my $desc = $ctx->{description} ) {
  73             $file = "$desc defined at $ctx->{file}";
  74         } else {
  75             $file = $ctx->{file};
  76         }
  77     } else {
  78         ( $line, $file ) = ( 0, "generated method (unknown origin)" );
  79     }
  80
  81     my $code = $args{code};
  82
  83     # if it's an array of lines, join it up
  84     # don't use newlines so that the definition context is more meaningful
  85     $code = join(@$code, ' ') if ref $code;
  86
  87     return qq{#line $line "$file"\n} . $code;
  88 }
  89
  90 sub _compile_code {
  91     my ( $self, %args ) = @_;
  92
  93     my $code = $self->_add_line_directive(%args);
  94
  95     return $self->_eval_closure($args{environment}, $code);
  96 }
  97
  98 sub generate_method {
  99     Carp::cluck('The generate_reader_method method has been made private.'
 100         . " The public version is deprecated and will be removed in a future release.\n");
 101     shift->_generate_method;
 102 }
 103
 104 sub generate_method_inline {
 105     Carp::cluck('The generate_reader_method_inline method has been made private.'
 106         . " The public version is deprecated and will be removed in a future release.\n");
 107     shift->_generate_method_inline;
 108 }
 109
 110 sub initialize_body {
 111     Carp::cluck('The initialize_body method has been made private.'
 112         . " The public version is deprecated and will be removed in a future release.\n");
 113     shift->_initialize_body;
 114 }
 115
 116
 117 1;
 118
 119 __END__
 120
 121 =pod
 122
 123 =head1 NAME
 124
 125 Class::MOP::Method::Generated - Abstract base class for generated methods
 126
 127 =head1 DESCRIPTION
 128
 129 This is a C<Class::MOP::Method> subclass which is subclassed by
 130 C<Class::MOP::Method::Accessor> and
 131 C<Class::MOP::Method::Constructor>.
 132
 133 It is not intended to be used directly.
 134
 135 =head1 AUTHORS
 136
 137 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 138
 139 =head1 COPYRIGHT AND LICENSE
 140
 141 Copyright 2006-2009 by Infinity Interactive, Inc.
 142
 143 L<http://www.iinteractive.com>
 144
 145 This library is free software; you can redistribute it and/or modify
 146 it under the same terms as Perl itself.
 147
 148 =cut
 149