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 (@_) {
 155         if (ref $_[0] eq 'HASH') {
 156           shift;
 157           my $r = $run->(undef, undef, @_);
 158           return $r;
 159         } else {
 160           return $_[1];
 161         }
 162       }
 163       return my $sv;
 164     });
 165     $setup_for_args{$name} = [
 166       $flags,
 167       sub {
 168         my ($usepack, $use, $inpack, $name, $proto) = @_;
 169         my $extra_code = $compile->($name, $proto);
 170         my $main_handler = $proto_maker->(sub {
 171           ("DONE", $run->($name, $proto, @_));
 172         });
 173         my ($name_h, $XX);
 174         if (defined $proto) {
 175           $name_h = sub :lvalue { return my $sv; };
 176           $XX = $main_handler;
 177         } elsif (defined $name && length $name) {
 178           $name_h = $main_handler;
 179         } else {
 180           $extra_code ||= '';
 181           $extra_code = '}, sub {'.$extra_code;
 182         }
 183         return ($name_h, $XX, $extra_code);
 184       }
 185     ];
 186   }
 187   $class->setup_for($pack, \%setup_for_args);
 188 }
 189
 190 sub install_declarator {
 191   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 192   $class->setup_declarators($target_pack, {
 193     $target_name => {
 194       flags => $flags,
 195       compile => $filter,
 196       run => $handler,
 197    }
 198   });
 199 }
 200
 201 =head1 NAME
 202
 203 Devel::Declare -
 204
 205 =head1 SYNOPSIS
 206
 207 =head1 DESCRIPTION
 208
 209 =head2 import
 210
 211   use Devel::Declare qw(list of subs);
 212
 213 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 214
 215 =head2 unimport
 216
 217   no Devel::Declare;
 218
 219 Calls Devel::Declare->teardown_for(__PACKAGE__);
 220
 221 =head2 setup_for
 222
 223   Devel::Declare->setup_for($package => \@subnames);
 224
 225 Installs declarator magic (unless already installed) and registers
 226 "${package}::$name" for each member of @subnames
 227
 228 =head2 teardown_for
 229
 230   Devel::Declare->teardown_for($package);
 231
 232 Deregisters all subs currently registered for $package and uninstalls
 233 declarator magic if number of teardown_for calls matches number of setup_for
 234 calls.
 235
 236 =head1 AUTHOR
 237
 238 Matt S Trout - <mst@shadowcatsystems.co.uk>
 239
 240 Company: http://www.shadowcatsystems.co.uk/
 241 Blog: http://chainsawblues.vox.com/
 242
 243 =head1 LICENSE
 244
 245 This library is free software under the same terms as perl itself
 246
 247 =cut
 248
 249 1;