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_rv2cv {
 200   my ($name, $offset) = @_;
 201   $offset += toke_move_past_token($offset);
 202   my $pack = get_curstash_name();
 203   my $flags = $declarators{$pack}{$name};
 204   my ($found_name, $found_proto);
 205   my $in_declare = 0;
 206   if ($flags & DECLARE_NAME) {
 207     $offset += toke_skipspace($offset);
 208     my $linestr = get_linestr();
 209     if (substr($linestr, $offset, 2) eq '::') {
 210       substr($linestr, $offset, 2) = '';
 211       set_linestr($linestr);
 212     }
 213     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 214       $found_name = substr($linestr, $offset, $len);
 215       $offset += $len;
 216       $in_declare++;
 217     }
 218   }
 219   if ($flags & DECLARE_PROTO) {
 220     $offset += toke_skipspace($offset);
 221     my $linestr = get_linestr();
 222     if (substr($linestr, $offset, 1) eq '(') {
 223       my $length = toke_scan_str($offset);
 224       $found_proto = get_lex_stuff();
 225       clear_lex_stuff();
 226       my $replace =
 227         ($found_name ? ' ' : '=')
 228         .'X'.(' ' x length($found_proto));
 229       $linestr = get_linestr();
 230       substr($linestr, $offset, $length) = $replace;
 231       set_linestr($linestr);
 232       $offset += $length;
 233       $in_declare++;
 234     }
 235   }
 236   my @args = ($pack, $name, $pack, $found_name, $found_proto);
 237   set_in_declare($in_declare);
 238   $offset += toke_skipspace($offset);
 239   my $linestr = get_linestr();
 240   if (substr($linestr, $offset, 1) eq '{') {
 241     my $ret = init_declare(@args);
 242     $offset++;
 243     if (defined $ret && length $ret) {
 244       substr($linestr, $offset, 0) = $ret;
 245       set_linestr($linestr);
 246     }
 247   } else {
 248     init_declare(@args);
 249   }
 250   #warn "linestr now ${linestr}";
 251 }
 252
 253 sub linestr_callback_const {
 254   my ($name, $offset) = @_;
 255   my $pack = get_curstash_name();
 256   my $flags = $declarators{$pack}{$name};
 257   if ($flags & DECLARE_NAME) {
 258     $offset += toke_move_past_token($offset);
 259     $offset += toke_skipspace($offset);
 260     if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 261       my $linestr = get_linestr();
 262       substr($linestr, $offset, 0) = '::';
 263       set_linestr($linestr);
 264     }
 265   }
 266 }
 267
 268 sub linestr_callback {
 269   my $type = shift;
 270   my $meth = "linestr_callback_${type}";
 271   __PACKAGE__->can($meth)->(@_);
 272 }
 273
 274 =head1 NAME
 275
 276 Devel::Declare -
 277
 278 =head1 SYNOPSIS
 279
 280 Look at the tests. This module is currently on CPAN to ease smoke testing
 281 and allow early adopters who've been involved in the design to experiment
 282 with it.
 283
 284 =head1 DESCRIPTION
 285
 286 =head2 import
 287
 288   use Devel::Declare qw(list of subs);
 289
 290 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 291
 292 =head2 unimport
 293
 294   no Devel::Declare;
 295
 296 Calls Devel::Declare->teardown_for(__PACKAGE__);
 297
 298 =head2 setup_for
 299
 300   Devel::Declare->setup_for($package => \@subnames);
 301
 302 Installs declarator magic (unless already installed) and registers
 303 "${package}::$name" for each member of @subnames
 304
 305 =head2 teardown_for
 306
 307   Devel::Declare->teardown_for($package);
 308
 309 Deregisters all subs currently registered for $package and uninstalls
 310 declarator magic if number of teardown_for calls matches number of setup_for
 311 calls.
 312
 313 =head1 AUTHOR
 314
 315 Matt S Trout - <mst@shadowcat.co.uk>
 316
 317 Company: http://www.shadowcat.co.uk/
 318 Blog: http://chainsawblues.vox.com/
 319
 320 =head1 LICENSE
 321
 322 This library is free software under the same terms as perl itself
 323
 324 =cut
 325
 326 1;