lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.001005';
   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     .'  if (wantarray) {
 124         goto &$body;
 125       }
 126       my $ret = $body->(@_);
 127       return $ret;
 128     };
 129     sub { ($body) = @_; };';
 130 }
 131
 132 sub setup_declarators {
 133   my ($class, $pack, $to_setup) = @_;
 134   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 135     unless defined($pack) && ref($to_setup) eq 'HASH';
 136   my %setup_for_args;
 137   foreach my $name (keys %$to_setup) {
 138     my $info = $to_setup->{$name};
 139     my $flags = $info->{flags} || DECLARE_NAME;
 140     my $run = $info->{run};
 141     my $compile = $info->{compile};
 142     my $proto = $info->{proto} || '&';
 143     my $sub_proto = $proto;
 144     # make all args optional to enable lvalue for DECLARE_NONE
 145     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 146     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 147     my $installer = $class->build_sub_installer($pack, $name, '@');
 148     $installer->(sub :lvalue {
 149 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 150       if (@_) {
 151         if (ref $_[0] eq 'HASH') {
 152           shift;
 153           if (wantarray) {
 154             my @ret = $run->(undef, undef, @_);
 155             return @ret;
 156           }
 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, $shift_hashref) = @_;
 169         my $extra_code = $compile->($name, $proto);
 170         my $main_handler = sub { shift if $shift_hashref;
 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         }
 180         $extra_code ||= '';
 181         $extra_code = '}, sub {'.$extra_code;
 182         return ($name_h, $XX, $extra_code);
 183       }
 184     ];
 185   }
 186   $class->setup_for($pack, \%setup_for_args);
 187 }
 188
 189 sub install_declarator {
 190   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 191   $class->setup_declarators($target_pack, {
 192     $target_name => {
 193       flags => $flags,
 194       compile => $filter,
 195       run => $handler,
 196    }
 197   });
 198 }
 199
 200 =head1 NAME
 201
 202 Devel::Declare -
 203
 204 =head1 SYNOPSIS
 205
 206 Look at the tests. This module is currently on CPAN to ease smoke testing
 207 and allow early adopters who've been involved in the design to experiment
 208 with it.
 209
 210 =head1 DESCRIPTION
 211
 212 =head2 import
 213
 214   use Devel::Declare qw(list of subs);
 215
 216 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 217
 218 =head2 unimport
 219
 220   no Devel::Declare;
 221
 222 Calls Devel::Declare->teardown_for(__PACKAGE__);
 223
 224 =head2 setup_for
 225
 226   Devel::Declare->setup_for($package => \@subnames);
 227
 228 Installs declarator magic (unless already installed) and registers
 229 "${package}::$name" for each member of @subnames
 230
 231 =head2 teardown_for
 232
 233   Devel::Declare->teardown_for($package);
 234
 235 Deregisters all subs currently registered for $package and uninstalls
 236 declarator magic if number of teardown_for calls matches number of setup_for
 237 calls.
 238
 239 =head1 AUTHOR
 240
 241 Matt S Trout - <mst@shadowcat.co.uk>
 242
 243 Company: http://www.shadowcat.co.uk/
 244 Blog: http://chainsawblues.vox.com/
 245
 246 =head1 LICENSE
 247
 248 This library is free software under the same terms as perl itself
 249
 250 =cut
 251
 252 1;