lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.001010';
   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 }
  67
  68 my $temp_name;
  69 my $temp_save;
  70
  71 sub init_declare {
  72   my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
  73   my ($name_h, $XX_h, $extra_code)
  74        = $declarator_handlers{$usepack}{$use}->(
  75            $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
  76          );
  77   ($temp_name, $temp_save) = ([], []);
  78   if ($name) {
  79     $name = "${inpack}::${name}" unless $name =~ /::/;
  80     push(@$temp_name, $name);
  81     no strict 'refs';
  82     push(@$temp_save, \&{$name});
  83     no warnings 'redefine';
  84     no warnings 'prototype';
  85     *{$name} = $name_h;
  86   }
  87   if ($XX_h) {
  88     push(@$temp_name, "${inpack}::X");
  89     no strict 'refs';
  90     push(@$temp_save, \&{"${inpack}::X"});
  91     no warnings 'redefine';
  92     no warnings 'prototype';
  93     *{"${inpack}::X"} = $XX_h;
  94   }
  95   if (defined wantarray) {
  96     return $extra_code || '0;';
  97   } else {
  98     return;
  99   }
 100 }
 101
 102 sub done_declare {
 103   no strict 'refs';
 104   my $name = shift(@{$temp_name||[]});
 105   die "done_declare called with no temp_name stack" unless defined($name);
 106   my $saved = shift(@$temp_save);
 107   $name =~ s/(.*):://;
 108   my $temp_pack = $1;
 109   delete ${"${temp_pack}::"}{$name};
 110   if ($saved) {
 111     no warnings 'prototype';
 112     *{"${temp_pack}::${name}"} = $saved;
 113   }
 114 }
 115
 116 sub build_sub_installer {
 117   my ($class, $pack, $name, $proto) = @_;
 118   return eval "
 119     package ${pack};
 120     my \$body;
 121     sub ${name} (${proto}) :lvalue {\n"
 122     .'  if (wantarray) {
 123         goto &$body;
 124       }
 125       my $ret = $body->(@_);
 126       return $ret;
 127     };
 128     sub { ($body) = @_; };';
 129 }
 130
 131 sub setup_declarators {
 132   my ($class, $pack, $to_setup) = @_;
 133   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 134     unless defined($pack) && ref($to_setup) eq 'HASH';
 135   my %setup_for_args;
 136   foreach my $name (keys %$to_setup) {
 137     my $info = $to_setup->{$name};
 138     my $flags = $info->{flags} || DECLARE_NAME;
 139     my $run = $info->{run};
 140     my $compile = $info->{compile};
 141     my $proto = $info->{proto} || '&';
 142     my $sub_proto = $proto;
 143     # make all args optional to enable lvalue for DECLARE_NONE
 144     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 145     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 146     my $installer = $class->build_sub_installer($pack, $name, '@');
 147     $installer->(sub :lvalue {
 148 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 149       if (@_) {
 150         if (ref $_[0] eq 'HASH') {
 151           shift;
 152           if (wantarray) {
 153             my @ret = $run->(undef, undef, @_);
 154             return @ret;
 155           }
 156           my $r = $run->(undef, undef, @_);
 157           return $r;
 158         } else {
 159           return @_[1..$#_];
 160         }
 161       }
 162       return my $sv;
 163     });
 164     $setup_for_args{$name} = [
 165       $flags,
 166       sub {
 167         my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
 168         my $extra_code = $compile->($name, $proto, $traits);
 169         my $main_handler = sub { shift if $shift_hashref;
 170           ("DONE", $run->($name, $proto, @_));
 171         };
 172         my ($name_h, $XX);
 173         if (defined $proto) {
 174           $name_h = sub :lvalue { return my $sv; };
 175           $XX = $main_handler;
 176         } elsif (defined $name && length $name) {
 177           $name_h = $main_handler;
 178         }
 179         $extra_code ||= '';
 180         $extra_code = '}, sub {'.$extra_code;
 181         return ($name_h, $XX, $extra_code);
 182       }
 183     ];
 184   }
 185   $class->setup_for($pack, \%setup_for_args);
 186 }
 187
 188 sub install_declarator {
 189   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 190   $class->setup_declarators($target_pack, {
 191     $target_name => {
 192       flags => $flags,
 193       compile => $filter,
 194       run => $handler,
 195    }
 196   });
 197 }
 198
 199 =head1 NAME
 200
 201 Devel::Declare -
 202
 203 =head1 SYNOPSIS
 204
 205 Look at the tests. This module is currently on CPAN to ease smoke testing
 206 and allow early adopters who've been involved in the design to experiment
 207 with it.
 208
 209 =head1 DESCRIPTION
 210
 211 =head2 import
 212
 213   use Devel::Declare qw(list of subs);
 214
 215 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 216
 217 =head2 unimport
 218
 219   no Devel::Declare;
 220
 221 Calls Devel::Declare->teardown_for(__PACKAGE__);
 222
 223 =head2 setup_for
 224
 225   Devel::Declare->setup_for($package => \@subnames);
 226
 227 Installs declarator magic (unless already installed) and registers
 228 "${package}::$name" for each member of @subnames
 229
 230 =head2 teardown_for
 231
 232   Devel::Declare->teardown_for($package);
 233
 234 Deregisters all subs currently registered for $package and uninstalls
 235 declarator magic if number of teardown_for calls matches number of setup_for
 236 calls.
 237
 238 =head1 AUTHOR
 239
 240 Matt S Trout - <mst@shadowcat.co.uk>
 241
 242 Company: http://www.shadowcat.co.uk/
 243 Blog: http://chainsawblues.vox.com/
 244
 245 =head1 LICENSE
 246
 247 This library is free software under the same terms as perl itself
 248
 249 =cut
 250
 251 1;