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     } elsif (ref($info) eq 'HASH') {
  55       $flags = 1;
  56       $sub = $info;
  57     } else {
  58       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
  59     }
  60     $declarators{$target}{$key} = $flags;
  61     $declarator_handlers{$target}{$key} = $sub;
  62   }
  63 }
  64
  65 sub teardown_for {
  66   my ($class, $target) = @_;
  67   delete $declarators{$target};
  68   delete $declarator_handlers{$target};
  69 }
  70
  71 my $temp_name;
  72 my $temp_save;
  73
  74 sub init_declare {
  75   my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
  76   my ($name_h, $XX_h, $extra_code)
  77        = $declarator_handlers{$usepack}{$use}->(
  78            $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
  79          );
  80   ($temp_name, $temp_save) = ([], []);
  81   if ($name) {
  82     $name = "${inpack}::${name}" unless $name =~ /::/;
  83     shadow_sub($name, $name_h);
  84   }
  85   if ($XX_h) {
  86     shadow_sub("${inpack}::X", $XX_h);
  87   }
  88   if (defined wantarray) {
  89     return $extra_code || '0;';
  90   } else {
  91     return;
  92   }
  93 }
  94
  95 sub shadow_sub {
  96   my ($name, $cr) = @_;
  97   push(@$temp_name, $name);
  98   no strict 'refs';
  99   my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
 100   push(@$temp_save, $pack->can($pname));
 101   delete ${"${pack}::"}{$pname};
 102   no warnings 'redefine';
 103   no warnings 'prototype';
 104   *{$name} = $cr;
 105   set_in_declare(~~@{$temp_name||[]});
 106 }
 107
 108 sub done_declare {
 109   no strict 'refs';
 110   my $name = shift(@{$temp_name||[]});
 111   die "done_declare called with no temp_name stack" unless defined($name);
 112   my $saved = shift(@$temp_save);
 113   $name =~ s/(.*):://;
 114   my $temp_pack = $1;
 115   delete ${"${temp_pack}::"}{$name};
 116   if ($saved) {
 117     no warnings 'prototype';
 118     *{"${temp_pack}::${name}"} = $saved;
 119   }
 120   set_in_declare(~~@{$temp_name||[]});
 121 }
 122
 123 sub build_sub_installer {
 124   my ($class, $pack, $name, $proto) = @_;
 125   return eval "
 126     package ${pack};
 127     my \$body;
 128     sub ${name} (${proto}) :lvalue {\n"
 129     .'  if (wantarray) {
 130         goto &$body;
 131       }
 132       my $ret = $body->(@_);
 133       return $ret;
 134     };
 135     sub { ($body) = @_; };';
 136 }
 137
 138 sub setup_declarators {
 139   my ($class, $pack, $to_setup) = @_;
 140   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 141     unless defined($pack) && ref($to_setup) eq 'HASH';
 142   my %setup_for_args;
 143   foreach my $name (keys %$to_setup) {
 144     my $info = $to_setup->{$name};
 145     my $flags = $info->{flags} || DECLARE_NAME;
 146     my $run = $info->{run};
 147     my $compile = $info->{compile};
 148     my $proto = $info->{proto} || '&';
 149     my $sub_proto = $proto;
 150     # make all args optional to enable lvalue for DECLARE_NONE
 151     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 152     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 153     my $installer = $class->build_sub_installer($pack, $name, '@');
 154     $installer->(sub :lvalue {
 155 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 156       if (@_) {
 157         if (ref $_[0] eq 'HASH') {
 158           shift;
 159           if (wantarray) {
 160             my @ret = $run->(undef, undef, @_);
 161             return @ret;
 162           }
 163           my $r = $run->(undef, undef, @_);
 164           return $r;
 165         } else {
 166           return @_[1..$#_];
 167         }
 168       }
 169       return my $sv;
 170     });
 171     $setup_for_args{$name} = [
 172       $flags,
 173       sub {
 174         my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
 175         my $extra_code = $compile->($name, $proto, $traits);
 176         my $main_handler = sub { shift if $shift_hashref;
 177           ("DONE", $run->($name, $proto, @_));
 178         };
 179         my ($name_h, $XX);
 180         if (defined $proto) {
 181           $name_h = sub :lvalue { return my $sv; };
 182           $XX = $main_handler;
 183         } elsif (defined $name && length $name) {
 184           $name_h = $main_handler;
 185         }
 186         $extra_code ||= '';
 187         $extra_code = '}, sub {'.$extra_code;
 188         return ($name_h, $XX, $extra_code);
 189       }
 190     ];
 191   }
 192   $class->setup_for($pack, \%setup_for_args);
 193 }
 194
 195 sub install_declarator {
 196   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 197   $class->setup_declarators($target_pack, {
 198     $target_name => {
 199       flags => $flags,
 200       compile => $filter,
 201       run => $handler,
 202    }
 203   });
 204 }
 205
 206 sub linestr_callback_rv2cv {
 207   my ($name, $offset) = @_;
 208   $offset += toke_move_past_token($offset);
 209   my $pack = get_curstash_name();
 210   my $flags = $declarators{$pack}{$name};
 211   my ($found_name, $found_proto);
 212   if ($flags & DECLARE_NAME) {
 213     $offset += toke_skipspace($offset);
 214     my $linestr = get_linestr();
 215     if (substr($linestr, $offset, 2) eq '::') {
 216       substr($linestr, $offset, 2) = '';
 217       set_linestr($linestr);
 218     }
 219     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 220       $found_name = substr($linestr, $offset, $len);
 221       $offset += $len;
 222     }
 223   }
 224   if ($flags & DECLARE_PROTO) {
 225     $offset += toke_skipspace($offset);
 226     my $linestr = get_linestr();
 227     if (substr($linestr, $offset, 1) eq '(') {
 228       my $length = toke_scan_str($offset);
 229       $found_proto = get_lex_stuff();
 230       clear_lex_stuff();
 231       my $replace =
 232         ($found_name ? ' ' : '=')
 233         .'X'.(' ' x length($found_proto));
 234       $linestr = get_linestr();
 235       substr($linestr, $offset, $length) = $replace;
 236       set_linestr($linestr);
 237       $offset += $length;
 238     }
 239   }
 240   my @args = ($pack, $name, $pack, $found_name, $found_proto);
 241   $offset += toke_skipspace($offset);
 242   my $linestr = get_linestr();
 243   if (substr($linestr, $offset, 1) eq '{') {
 244     my $ret = init_declare(@args);
 245     $offset++;
 246     if (defined $ret && length $ret) {
 247       substr($linestr, $offset, 0) = $ret;
 248       set_linestr($linestr);
 249     }
 250   } else {
 251     init_declare(@args);
 252   }
 253   #warn "linestr now ${linestr}";
 254 }
 255
 256 sub linestr_callback_const {
 257   my ($name, $offset) = @_;
 258   my $pack = get_curstash_name();
 259   my $flags = $declarators{$pack}{$name};
 260   if ($flags & DECLARE_NAME) {
 261     $offset += toke_move_past_token($offset);
 262     $offset += toke_skipspace($offset);
 263     if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 264       my $linestr = get_linestr();
 265       substr($linestr, $offset, 0) = '::';
 266       set_linestr($linestr);
 267     }
 268   }
 269 }
 270
 271 sub linestr_callback {
 272   my $type = shift;
 273   my $name = $_[0];
 274   my $pack = get_curstash_name();
 275   my $handlers = $declarator_handlers{$pack}{$name};
 276   if (ref $handlers eq 'CODE') {
 277     my $meth = "linestr_callback_${type}";
 278     __PACKAGE__->can($meth)->(@_);
 279   } elsif (ref $handlers eq 'HASH') {
 280     if ($handlers->{$type}) {
 281       $handlers->{$type}->(@_);
 282     }
 283   } else {
 284     die "PANIC: unknown thing in handlers for $pack $name: $handlers";
 285   }
 286 }
 287
 288 =head1 NAME
 289
 290 Devel::Declare -
 291
 292 =head1 SYNOPSIS
 293
 294 Look at the tests. This module is currently on CPAN to ease smoke testing
 295 and allow early adopters who've been involved in the design to experiment
 296 with it.
 297
 298 =head1 DESCRIPTION
 299
 300 =head2 import
 301
 302   use Devel::Declare qw(list of subs);
 303
 304 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
 305
 306 =head2 unimport
 307
 308   no Devel::Declare;
 309
 310 Calls Devel::Declare->teardown_for(__PACKAGE__);
 311
 312 =head2 setup_for
 313
 314   Devel::Declare->setup_for($package => \@subnames);
 315
 316 Installs declarator magic (unless already installed) and registers
 317 "${package}::$name" for each member of @subnames
 318
 319 =head2 teardown_for
 320
 321   Devel::Declare->teardown_for($package);
 322
 323 Deregisters all subs currently registered for $package and uninstalls
 324 declarator magic if number of teardown_for calls matches number of setup_for
 325 calls.
 326
 327 =head1 AUTHOR
 328
 329 Matt S Trout - <mst@shadowcat.co.uk>
 330
 331 Company: http://www.shadowcat.co.uk/
 332 Blog: http://chainsawblues.vox.com/
 333
 334 =head1 LICENSE
 335
 336 This library is free software under the same terms as perl itself
 337
 338 =cut
 339
 340 1;