lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.001011';
   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 sub linestr_callback_const {
 200   warn "Linestr_callback_const: @_\n";
 201   my $l = get_linestr();
 202   warn "linestr: ${l}\n";
 203   warn "w/offset: ".substr($l, $_[1])."\n";
 204 }
 205
 206 sub linestr_callback {
 207   my $type = shift;
 208   my $meth = "linestr_callback_${type}";
 209   __PACKAGE__->can($meth)->(@_);
 210   return 'foo';
 211 }
 212
 213 =head1 NAME
 214
 215 Devel::Declare -
 216
 217 =head1 SYNOPSIS
 218
 219 Look at the tests. This module is currently on CPAN to ease smoke testing
 220 and allow early adopters who've been involved in the design to experiment
 221 with it.
 222
 223 =head1 DESCRIPTION
 224
 225 =head2 import
 226
 227   use Devel::Declare qw(list of subs);
 228
 229 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 230
 231 =head2 unimport
 232
 233   no Devel::Declare;
 234
 235 Calls Devel::Declare->teardown_for(__PACKAGE__);
 236
 237 =head2 setup_for
 238
 239   Devel::Declare->setup_for($package => \@subnames);
 240
 241 Installs declarator magic (unless already installed) and registers
 242 "${package}::$name" for each member of @subnames
 243
 244 =head2 teardown_for
 245
 246   Devel::Declare->teardown_for($package);
 247
 248 Deregisters all subs currently registered for $package and uninstalls
 249 declarator magic if number of teardown_for calls matches number of setup_for
 250 calls.
 251
 252 =head1 AUTHOR
 253
 254 Matt S Trout - <mst@shadowcat.co.uk>
 255
 256 Company: http://www.shadowcat.co.uk/
 257 Blog: http://chainsawblues.vox.com/
 258
 259 =head1 LICENSE
 260
 261 This library is free software under the same terms as perl itself
 262
 263 =cut
 264
 265 1;