lib/Eval/Closure.pm

   1 package Eval::Closure;
   2 use strict;
   3 use warnings;
   4 use Sub::Exporter -setup => {
   5     exports => [qw(eval_closure)],
   6     groups  => { default => [qw(eval_closure)] },
   7 };
   8 # ABSTRACT: safely and cleanly create closures via string eval
   9
  10 use Carp;
  11 use overload ();
  12 use Memoize;
  13 use Scalar::Util qw(reftype);
  14 use Try::Tiny;
  15
  16 =head1 SYNOPSIS
  17
  18 =head1 DESCRIPTION
  19
  20 =cut
  21
  22 =func eval_closure(%args)
  23
  24 =cut
  25
  26 sub eval_closure {
  27     my (%args) = @_;
  28
  29     $args{source} = _canonicalize_source($args{source});
  30     _validate_env($args{environment} ||= {});
  31
  32     $args{source} = _line_directive($args{description}) . $args{source}
  33         if defined $args{description};
  34
  35     my ($code, $e) = _clean_eval_closure(@args{qw(source environment)});
  36
  37     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
  38         unless $code;
  39
  40     return $code;
  41 }
  42
  43 sub _canonicalize_source {
  44     my ($source) = @_;
  45
  46     if (defined($source)) {
  47         if (ref($source)) {
  48             if (reftype($source) eq 'ARRAY'
  49              || overload::Method($source, '@{}')) {
  50                 return join "\n", @$source;
  51             }
  52             elsif (overload::Method($source, '""')) {
  53                 return "$source";
  54             }
  55             else {
  56                 croak("The 'source' parameter to eval_closure must be a "
  57                     . "string or array reference");
  58             }
  59         }
  60         else {
  61             return $source;
  62         }
  63     }
  64     else {
  65         croak("The 'source' parameter to eval_closure is required");
  66     }
  67 }
  68
  69 sub _validate_env {
  70     my ($env) = @_;
  71
  72     croak("The 'environment' parameter must be a hashref")
  73         unless reftype($env) eq 'HASH';
  74
  75     for my $var (keys %$env) {
  76         croak("Environment key '$var' should start with \@, \%, or \$")
  77             unless $var =~ /^([\@\%\$])/;
  78         croak("Environment values must be references, not $env->{$var}")
  79             unless ref($env->{$var});
  80     }
  81 }
  82
  83 sub _line_directive {
  84     my ($description) = @_;
  85
  86     return qq{#line 1 "$description"\n};
  87 }
  88
  89 sub _clean_eval_closure {
  90      my ($source, $captures) = @_;
  91
  92     if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
  93         _dump_source(_make_compiler_source(@_));
  94     }
  95
  96     my @capture_keys = sort keys %$captures;
  97     my ($compiler, $e) = _make_compiler($source, @capture_keys);
  98     my $code;
  99     if (defined $compiler) {
 100         $code = $compiler->(@$captures{@capture_keys});
 101     }
 102
 103     if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) {
 104         $e = "The 'source' parameter must return a subroutine reference, "
 105            . "not $code";
 106         undef $code;
 107     }
 108
 109     return ($code, $e);
 110 }
 111
 112 sub _make_compiler {
 113     local $@;
 114     local $SIG{__DIE__};
 115     my $compiler = eval _make_compiler_source(@_);
 116     my $e = $@;
 117     return ($compiler, $e);
 118 }
 119 memoize('_make_compiler');
 120
 121 sub _make_compiler_source {
 122     my ($source, @capture_keys) = @_;
 123     my $i = 0;
 124     return join "\n", (
 125         'sub {',
 126         (map {
 127             'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};'
 128          } @capture_keys),
 129         $source,
 130         '}',
 131     );
 132 }
 133
 134 sub _dump_source {
 135     my ($source) = @_;
 136
 137     my $output;
 138     if (try { require Perl::Tidy }) {
 139         Perl::Tidy::perltidy(
 140             source      => \$source,
 141             destination => \$output,
 142         );
 143     }
 144     else {
 145         $output = $source;
 146     }
 147
 148     warn "$output\n";
 149 }
 150
 151 =head1 BUGS
 152
 153 No known bugs.
 154
 155 Please report any bugs through RT: email
 156 C<bug-eval-closure at rt.cpan.org>, or browse to
 157 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>.
 158
 159 =head1 SEE ALSO
 160
 161 =over 4
 162
 163 =item * L<Class::MOP::Method::Accessor>
 164
 165 This module is a factoring out of code that used to live here
 166
 167 =back
 168
 169 =head1 SUPPORT
 170
 171 You can find this documentation for this module with the perldoc command.
 172
 173     perldoc Eval::Closure
 174
 175 You can also look for information at:
 176
 177 =over 4
 178
 179 =item * AnnoCPAN: Annotated CPAN documentation
 180
 181 L<http://annocpan.org/dist/Eval-Closure>
 182
 183 =item * CPAN Ratings
 184
 185 L<http://cpanratings.perl.org/d/Eval-Closure>
 186
 187 =item * RT: CPAN's request tracker
 188
 189 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure>
 190
 191 =item * Search CPAN
 192
 193 L<http://search.cpan.org/dist/Eval-Closure>
 194
 195 =back
 196
 197 =head1 AUTHOR
 198
 199 Jesse Luehrs <doy at tozt dot net>
 200
 201 Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the
 202 Moose Cabal.
 203
 204 =cut
 205
 206 1;