lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = 0.001000;
   8
   9 # mirrored in Declare.xs as DD_HANDLE_*
  10
  11 use constant DECLARE_NAME => 1;
  12 use constant DECLARE_PROTO => 2;
  13 use constant DECLARE_NONE => 4;
  14 use constant DECLARE_PACKAGE => 8+1; # name implicit
  15
  16 use vars qw(%declarators %declarator_handlers @ISA);
  17 use base qw(DynaLoader);
  18 use Scalar::Util 'set_prototype';
  19
  20 bootstrap Devel::Declare;
  21
  22 @ISA = ();
  23
  24 sub import {
  25   my ($class, %args) = @_;
  26   my $target = caller;
  27   if (@_ == 1) { # "use Devel::Declare;"
  28     no strict 'refs';
  29     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  30       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  31     }
  32   } else {
  33     $class->setup_for($target => \%args);
  34   }
  35 }
  36
  37 sub unimport {
  38   my ($class) = @_;
  39   my $target = caller;
  40   $class->teardown_for($target);
  41 }
  42
  43 sub setup_for {
  44   my ($class, $target, $args) = @_;
  45   setup();
  46   foreach my $key (keys %$args) {
  47     my $info = $args->{$key};
  48     my ($flags, $sub);
  49     if (ref($info) eq 'ARRAY') {
  50       ($flags, $sub) = @$info;
  51     } elsif (ref($info) eq 'CODE') {
  52       $flags = DECLARE_NAME;
  53       $sub = $info;
  54     } else {
  55       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
  56     }
  57     $declarators{$target}{$key} = $flags;
  58     $declarator_handlers{$target}{$key} = $sub;
  59   }
  60 }
  61
  62 sub teardown_for {
  63   my ($class, $target) = @_;
  64   delete $declarators{$target};
  65   delete $declarator_handlers{$target};
  66   teardown();
  67 }
  68
  69 my $temp_name;
  70 my $temp_save;
  71
  72 sub init_declare {
  73   my ($usepack, $use, $inpack, $name, $proto) = @_;
  74   my ($name_h, $XX_h, $extra_code)
  75        = $declarator_handlers{$usepack}{$use}->(
  76            $usepack, $use, $inpack, $name, $proto, defined(wantarray)
  77          );
  78   ($temp_name, $temp_save) = ([], []);
  79   if ($name) {
  80     $name = "${inpack}::${name}" unless $name =~ /::/;
  81     push(@$temp_name, $name);
  82     no strict 'refs';
  83     push(@$temp_save, \&{$name});
  84     no warnings 'redefine';
  85     no warnings 'prototype';
  86     *{$name} = $name_h;
  87   }
  88   if ($XX_h) {
  89     push(@$temp_name, "${inpack}::X");
  90     no strict 'refs';
  91     push(@$temp_save, \&{"${inpack}::X"});
  92     no warnings 'redefine';
  93     no warnings 'prototype';
  94     *{"${inpack}::X"} = $XX_h;
  95   }
  96   if (defined wantarray) {
  97     return $extra_code || '0;';
  98   } else {
  99     return;
 100   }
 101 }
 102
 103 sub done_declare {
 104   no strict 'refs';
 105   my $name = shift(@{$temp_name||[]});
 106   die "done_declare called with no temp_name stack" unless defined($name);
 107   my $saved = shift(@$temp_save);
 108   $name =~ s/(.*):://;
 109   my $temp_pack = $1;
 110   delete ${"${temp_pack}::"}{$name};
 111   if ($saved) {
 112     no warnings 'prototype';
 113     *{"${temp_pack}::${name}"} = $saved;
 114   }
 115 }
 116
 117 sub build_sub_installer {
 118   my ($class, $pack, $name, $proto) = @_;
 119   return eval "
 120     package ${pack};
 121     my \$body;
 122     sub ${name} (${proto}) :lvalue {\n"
 123     .'my $ret = $body->(@_);
 124       return $ret;
 125     };
 126     sub { ($body) = @_; };';
 127 }
 128
 129 sub setup_declarators {
 130   my ($class, $pack, $to_setup) = @_;
 131   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 132     unless defined($pack) && ref($to_setup) eq 'HASH';
 133   my %setup_for_args;
 134   foreach my $name (keys %$to_setup) {
 135     my $info = $to_setup->{$name};
 136     my $flags = $info->{flags} || DECLARE_NAME;
 137     my $run = $info->{run};
 138     my $compile = $info->{compile};
 139     my $proto = $info->{proto} || '&';
 140     my $sub_proto = $proto;
 141     # make all args optional to enable lvalue for DECLARE_NONE
 142     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 143     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 144     my $installer = $class->build_sub_installer($pack, $name, '@');
 145     my $proto_maker = eval q!
 146       sub {
 147         my $body = shift;
 148         sub (!.$sub_proto.q!) {
 149           $body->(@_);
 150         };
 151       };
 152     !;
 153     $installer->(sub :lvalue {
 154       if (@_) { warn @_;
 155         $run->(undef, undef, @_);
 156       }
 157       return my $sv;
 158     });
 159     $setup_for_args{$name} = [
 160       $flags,
 161       sub {
 162         my ($usepack, $use, $inpack, $name, $proto) = @_;
 163         my $extra_code = $compile->($name, $proto);
 164         my $main_handler = $proto_maker->(sub {
 165           $run->($name, $proto, @_);
 166         });
 167         my ($name_h, $XX);
 168         if (defined $proto) {
 169           $name_h = sub :lvalue { return my $sv; };
 170           $XX = $main_handler;
 171         } else {
 172           $name_h = $main_handler;
 173         }
 174         return ($name_h, $XX, $extra_code);
 175       }
 176     ];
 177   }
 178   $class->setup_for($pack, \%setup_for_args);
 179 }
 180
 181 sub install_declarator {
 182   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 183   $class->setup_declarators($target_pack, {
 184     $target_name => {
 185       flags => $flags,
 186       compile => $filter,
 187       run => $handler,
 188    }
 189   });
 190 }
 191
 192 =head1 NAME
 193
 194 Devel::Declare -
 195
 196 =head1 SYNOPSIS
 197
 198 =head1 DESCRIPTION
 199
 200 =head2 import
 201
 202   use Devel::Declare qw(list of subs);
 203
 204 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 205
 206 =head2 unimport
 207
 208   no Devel::Declare;
 209
 210 Calls Devel::Declare->teardown_for(__PACKAGE__);
 211
 212 =head2 setup_for
 213
 214   Devel::Declare->setup_for($package => \@subnames);
 215
 216 Installs declarator magic (unless already installed) and registers
 217 "${package}::$name" for each member of @subnames
 218
 219 =head2 teardown_for
 220
 221   Devel::Declare->teardown_for($package);
 222
 223 Deregisters all subs currently registered for $package and uninstalls
 224 declarator magic if number of teardown_for calls matches number of setup_for
 225 calls.
 226
 227 =head1 AUTHOR
 228
 229 Matt S Trout - <mst@shadowcatsystems.co.uk>
 230
 231 Company: http://www.shadowcatsystems.co.uk/
 232 Blog: http://chainsawblues.vox.com/
 233
 234 =head1 LICENSE
 235
 236 This library is free software under the same terms as perl itself
 237
 238 =cut
 239
 240 1;