lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.002002';
   8
   9 use constant DECLARE_NAME => 1;
  10 use constant DECLARE_PROTO => 2;
  11 use constant DECLARE_NONE => 4;
  12 use constant DECLARE_PACKAGE => 8+1; # name implicit
  13
  14 use vars qw(%declarators %declarator_handlers @ISA);
  15 use base qw(DynaLoader);
  16 use Scalar::Util 'set_prototype';
  17 use B::Hooks::OP::Check;
  18 use B::Hooks::Parser;
  19
  20 bootstrap Devel::Declare;
  21
  22 @ISA = ();
  23
  24 # temporary backcompat
  25 {
  26     for (qw/get_linestr get_linestr_offset set_linestr/) {
  27         no strict 'refs';
  28         *{ $_ } = B::Hooks::Parser->can($_);
  29     }
  30 }
  31
  32 sub import {
  33   my ($class, %args) = @_;
  34   my $target = caller;
  35   if (@_ == 1) { # "use Devel::Declare;"
  36     no strict 'refs';
  37     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  38       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  39     }
  40   } else {
  41     $class->setup_for($target => \%args);
  42   }
  43 }
  44
  45 sub unimport {
  46   my ($class) = @_;
  47   my $target = caller;
  48   $class->teardown_for($target);
  49 }
  50
  51 sub setup_for {
  52   my ($class, $target, $args) = @_;
  53   setup();
  54   foreach my $key (keys %$args) {
  55     my $info = $args->{$key};
  56     my ($flags, $sub);
  57     if (ref($info) eq 'ARRAY') {
  58       ($flags, $sub) = @$info;
  59     } elsif (ref($info) eq 'CODE') {
  60       $flags = DECLARE_NAME;
  61       $sub = $info;
  62     } elsif (ref($info) eq 'HASH') {
  63       $flags = 1;
  64       $sub = $info;
  65     } else {
  66       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
  67     }
  68     $declarators{$target}{$key} = $flags;
  69     $declarator_handlers{$target}{$key} = $sub;
  70   }
  71 }
  72
  73 sub teardown_for {
  74   my ($class, $target) = @_;
  75   delete $declarators{$target};
  76   delete $declarator_handlers{$target};
  77 }
  78
  79 my $temp_name;
  80 my $temp_save;
  81
  82 sub init_declare {
  83   my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
  84   my ($name_h, $XX_h, $extra_code)
  85        = $declarator_handlers{$usepack}{$use}->(
  86            $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
  87          );
  88   ($temp_name, $temp_save) = ([], []);
  89   if ($name) {
  90     $name = "${inpack}::${name}" unless $name =~ /::/;
  91     shadow_sub($name, $name_h);
  92   }
  93   if ($XX_h) {
  94     shadow_sub("${inpack}::X", $XX_h);
  95   }
  96   if (defined wantarray) {
  97     return $extra_code || '0;';
  98   } else {
  99     return;
 100   }
 101 }
 102
 103 sub shadow_sub {
 104   my ($name, $cr) = @_;
 105   push(@$temp_name, $name);
 106   no strict 'refs';
 107   my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
 108   push(@$temp_save, $pack->can($pname));
 109   delete ${"${pack}::"}{$pname};
 110   no warnings 'redefine';
 111   no warnings 'prototype';
 112   *{$name} = $cr;
 113   set_in_declare(~~@{$temp_name||[]});
 114 }
 115
 116 sub done_declare {
 117   no strict 'refs';
 118   my $name = shift(@{$temp_name||[]});
 119   die "done_declare called with no temp_name stack" unless defined($name);
 120   my $saved = shift(@$temp_save);
 121   $name =~ s/(.*):://;
 122   my $temp_pack = $1;
 123   delete ${"${temp_pack}::"}{$name};
 124   if ($saved) {
 125     no warnings 'prototype';
 126     *{"${temp_pack}::${name}"} = $saved;
 127   }
 128   set_in_declare(~~@{$temp_name||[]});
 129 }
 130
 131 sub build_sub_installer {
 132   my ($class, $pack, $name, $proto) = @_;
 133   return eval "
 134     package ${pack};
 135     my \$body;
 136     sub ${name} (${proto}) :lvalue {\n"
 137     .'  if (wantarray) {
 138         goto &$body;
 139       }
 140       my $ret = $body->(@_);
 141       return $ret;
 142     };
 143     sub { ($body) = @_; };';
 144 }
 145
 146 sub setup_declarators {
 147   my ($class, $pack, $to_setup) = @_;
 148   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 149     unless defined($pack) && ref($to_setup) eq 'HASH';
 150   my %setup_for_args;
 151   foreach my $name (keys %$to_setup) {
 152     my $info = $to_setup->{$name};
 153     my $flags = $info->{flags} || DECLARE_NAME;
 154     my $run = $info->{run};
 155     my $compile = $info->{compile};
 156     my $proto = $info->{proto} || '&';
 157     my $sub_proto = $proto;
 158     # make all args optional to enable lvalue for DECLARE_NONE
 159     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 160     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 161     my $installer = $class->build_sub_installer($pack, $name, '@');
 162     $installer->(sub :lvalue {
 163 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 164       if (@_) {
 165         if (ref $_[0] eq 'HASH') {
 166           shift;
 167           if (wantarray) {
 168             my @ret = $run->(undef, undef, @_);
 169             return @ret;
 170           }
 171           my $r = $run->(undef, undef, @_);
 172           return $r;
 173         } else {
 174           return @_[1..$#_];
 175         }
 176       }
 177       return my $sv;
 178     });
 179     $setup_for_args{$name} = [
 180       $flags,
 181       sub {
 182         my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
 183         my $extra_code = $compile->($name, $proto, $traits);
 184         my $main_handler = sub { shift if $shift_hashref;
 185           ("DONE", $run->($name, $proto, @_));
 186         };
 187         my ($name_h, $XX);
 188         if (defined $proto) {
 189           $name_h = sub :lvalue { return my $sv; };
 190           $XX = $main_handler;
 191         } elsif (defined $name && length $name) {
 192           $name_h = $main_handler;
 193         }
 194         $extra_code ||= '';
 195         $extra_code = '}, sub {'.$extra_code;
 196         return ($name_h, $XX, $extra_code);
 197       }
 198     ];
 199   }
 200   $class->setup_for($pack, \%setup_for_args);
 201 }
 202
 203 sub install_declarator {
 204   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 205   $class->setup_declarators($target_pack, {
 206     $target_name => {
 207       flags => $flags,
 208       compile => $filter,
 209       run => $handler,
 210    }
 211   });
 212 }
 213
 214 sub linestr_callback_rv2cv {
 215   my ($name, $offset) = @_;
 216   $offset += toke_move_past_token($offset);
 217   my $pack = get_curstash_name();
 218   my $flags = $declarators{$pack}{$name};
 219   my ($found_name, $found_proto);
 220   if ($flags & DECLARE_NAME) {
 221     $offset += toke_skipspace($offset);
 222     my $linestr = get_linestr();
 223     if (substr($linestr, $offset, 2) eq '::') {
 224       substr($linestr, $offset, 2) = '';
 225       set_linestr($linestr);
 226     }
 227     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 228       $found_name = substr($linestr, $offset, $len);
 229       $offset += $len;
 230     }
 231   }
 232   if ($flags & DECLARE_PROTO) {
 233     $offset += toke_skipspace($offset);
 234     my $linestr = get_linestr();
 235     if (substr($linestr, $offset, 1) eq '(') {
 236       my $length = toke_scan_str($offset);
 237       $found_proto = get_lex_stuff();
 238       clear_lex_stuff();
 239       my $replace =
 240         ($found_name ? ' ' : '=')
 241         .'X'.(' ' x length($found_proto));
 242       $linestr = get_linestr();
 243       substr($linestr, $offset, $length) = $replace;
 244       set_linestr($linestr);
 245       $offset += $length;
 246     }
 247   }
 248   my @args = ($pack, $name, $pack, $found_name, $found_proto);
 249   $offset += toke_skipspace($offset);
 250   my $linestr = get_linestr();
 251   if (substr($linestr, $offset, 1) eq '{') {
 252     my $ret = init_declare(@args);
 253     $offset++;
 254     if (defined $ret && length $ret) {
 255       substr($linestr, $offset, 0) = $ret;
 256       set_linestr($linestr);
 257     }
 258   } else {
 259     init_declare(@args);
 260   }
 261   #warn "linestr now ${linestr}";
 262 }
 263
 264 sub linestr_callback_const {
 265   my ($name, $offset) = @_;
 266   my $pack = get_curstash_name();
 267   my $flags = $declarators{$pack}{$name};
 268   if ($flags & DECLARE_NAME) {
 269     $offset += toke_move_past_token($offset);
 270     $offset += toke_skipspace($offset);
 271     if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 272       my $linestr = get_linestr();
 273       substr($linestr, $offset, 0) = '::';
 274       set_linestr($linestr);
 275     }
 276   }
 277 }
 278
 279 sub linestr_callback {
 280   my $type = shift;
 281   my $name = $_[0];
 282   my $pack = get_curstash_name();
 283   my $handlers = $declarator_handlers{$pack}{$name};
 284   if (ref $handlers eq 'CODE') {
 285     my $meth = "linestr_callback_${type}";
 286     __PACKAGE__->can($meth)->(@_);
 287   } elsif (ref $handlers eq 'HASH') {
 288     if ($handlers->{$type}) {
 289       $handlers->{$type}->(@_);
 290     }
 291   } else {
 292     die "PANIC: unknown thing in handlers for $pack $name: $handlers";
 293   }
 294 }
 295
 296 =head1 NAME
 297
 298 Devel::Declare -
 299
 300 =head1 SYNOPSIS
 301
 302   use Devel::Declare ();
 303
 304   {
 305     package MethodHandlers;
 306
 307     use strict;
 308     use warnings;
 309     use B::Hooks::EndOfScope;
 310
 311     our ($Declarator, $Offset);
 312
 313     sub skip_declarator {
 314       $Offset += Devel::Declare::toke_move_past_token($Offset);
 315     }
 316
 317     sub skipspace {
 318       $Offset += Devel::Declare::toke_skipspace($Offset);
 319     }
 320
 321     sub strip_name {
 322       skipspace;
 323       if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
 324         my $linestr = Devel::Declare::get_linestr();
 325         my $name = substr($linestr, $Offset, $len);
 326         substr($linestr, $Offset, $len) = '';
 327         Devel::Declare::set_linestr($linestr);
 328         return $name;
 329       }
 330       return;
 331     }
 332
 333     sub strip_proto {
 334       skipspace;
 335
 336       my $linestr = Devel::Declare::get_linestr();
 337       if (substr($linestr, $Offset, 1) eq '(') {
 338         my $length = Devel::Declare::toke_scan_str($Offset);
 339         my $proto = Devel::Declare::get_lex_stuff();
 340         Devel::Declare::clear_lex_stuff();
 341         $linestr = Devel::Declare::get_linestr();
 342         substr($linestr, $Offset, $length) = '';
 343         Devel::Declare::set_linestr($linestr);
 344         return $proto;
 345       }
 346       return;
 347     }
 348
 349     sub shadow {
 350       my $pack = Devel::Declare::get_curstash_name;
 351       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 352     }
 353
 354     # undef  -> my ($self) = shift;
 355     # ''     -> my ($self) = @_;
 356     # '$foo' -> my ($self, $foo) = @_;
 357
 358     sub make_proto_unwrap {
 359       my ($proto) = @_;
 360       my $inject = 'my ($self';
 361       if (defined $proto) {
 362         $inject .= ", $proto" if length($proto);
 363         $inject .= ') = @_; ';
 364       } else {
 365         $inject .= ') = shift;';
 366       }
 367       return $inject;
 368     }
 369
 370     sub inject_if_block {
 371       my $inject = shift;
 372       skipspace;
 373       my $linestr = Devel::Declare::get_linestr;
 374       if (substr($linestr, $Offset, 1) eq '{') {
 375         substr($linestr, $Offset+1, 0) = $inject;
 376         Devel::Declare::set_linestr($linestr);
 377       }
 378     }
 379
 380     sub scope_injector_call {
 381       return ' BEGIN { MethodHandlers::inject_scope }; ';
 382     }
 383
 384     sub parser {
 385       local ($Declarator, $Offset) = @_;
 386       skip_declarator;
 387       my $name = strip_name;
 388       my $proto = strip_proto;
 389       my $inject = make_proto_unwrap($proto);
 390       if (defined $name) {
 391         $inject = scope_injector_call().$inject;
 392       }
 393       inject_if_block($inject);
 394       if (defined $name) {
 395         $name = join('::', Devel::Declare::get_curstash_name(), $name)
 396           unless ($name =~ /::/);
 397         shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 398       } else {
 399         shadow(sub (&) { shift });
 400       }
 401     }
 402
 403     sub inject_scope {
 404       on_scope_end {
 405         my $linestr = Devel::Declare::get_linestr;
 406         my $offset = Devel::Declare::get_linestr_offset;
 407         substr($linestr, $offset, 0) = ';';
 408         Devel::Declare::set_linestr($linestr);
 409       };
 410     }
 411   }
 412
 413   my ($test_method1, $test_method2, @test_list);
 414
 415   {
 416     package DeclareTest;
 417
 418     sub method (&);
 419
 420     BEGIN {
 421       Devel::Declare->setup_for(
 422         __PACKAGE__,
 423         { method => { const => \&MethodHandlers::parser } }
 424       );
 425     }
 426
 427     method new {
 428       my $class = ref $self || $self;
 429       return bless({ @_ }, $class);
 430     }
 431
 432     method foo ($foo) {
 433       return (ref $self).': Foo: '.$foo;
 434     }
 435
 436     method upgrade(){ # no spaces to make case pathological
 437       bless($self, 'DeclareTest2');
 438     }
 439
 440     method DeclareTest2::bar () {
 441       return 'DeclareTest2: bar';
 442     }
 443
 444     $test_method1 = method {
 445       return join(', ', $self->{attr}, $_[1]);
 446     };
 447
 448     $test_method2 = method ($what) {
 449       return join(', ', ref $self, $what);
 450     };
 451
 452     method main () { return "main"; }
 453
 454     @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 455
 456   }
 457
 458   use Test::More 'no_plan';
 459
 460   my $o = DeclareTest->new(attr => "value");
 461
 462   isa_ok($o, 'DeclareTest');
 463
 464   is($o->{attr}, 'value', '@_ args ok');
 465
 466   is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 467
 468   is($o->main, 'main', 'declaration of package named method ok');
 469
 470   $o->upgrade;
 471
 472   isa_ok($o, 'DeclareTest2');
 473
 474   is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 475
 476   is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 477
 478   is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 479
 480   is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
 481
 482 (this is t/method-no-semi.t in this distribution)
 483
 484 =head1 DESCRIPTION
 485
 486 =head2 setup_for
 487
 488   Devel::Declare->setup_for(
 489     $package,
 490     {
 491       $name => { $op_type => $sub }
 492     }
 493   );
 494
 495 Currently valid op types: 'check', 'rv2cv'
 496
 497 =head1 AUTHORS
 498
 499 Matt S Trout - <mst@shadowcat.co.uk>
 500
 501 Company: http://www.shadowcat.co.uk/
 502 Blog: http://chainsawblues.vox.com/
 503
 504 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
 505
 506 =head1 LICENSE
 507
 508 This library is free software under the same terms as perl itself
 509
 510 =cut
 511
 512 1;