lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.001002';
   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 Look at the tests. This module is currently on CPAN to ease smoke testing
 208 and allow early adopters who've been involved in the design to experiment
 209 with it.
 210
 211 =head1 DESCRIPTION
 212
 213 =head2 import
 214
 215   use Devel::Declare qw(list of subs);
 216
 217 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 218
 219 =head2 unimport
 220
 221   no Devel::Declare;
 222
 223 Calls Devel::Declare->teardown_for(__PACKAGE__);
 224
 225 =head2 setup_for
 226
 227   Devel::Declare->setup_for($package => \@subnames);
 228
 229 Installs declarator magic (unless already installed) and registers
 230 "${package}::$name" for each member of @subnames
 231
 232 =head2 teardown_for
 233
 234   Devel::Declare->teardown_for($package);
 235
 236 Deregisters all subs currently registered for $package and uninstalls
 237 declarator magic if number of teardown_for calls matches number of setup_for
 238 calls.
 239
 240 =head1 AUTHOR
 241
 242 Matt S Trout - <mst@shadowcat.co.uk>
 243
 244 Company: http://www.shadowcat.co.uk/
 245 Blog: http://chainsawblues.vox.com/
 246
 247 =head1 LICENSE
 248
 249 This library is free software under the same terms as perl itself
 250
 251 =cut
 252
 253 1;