lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.006006';
   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 0.19;
  18
  19 bootstrap Devel::Declare;
  20
  21 @ISA = ();
  22
  23 sub import {
  24   my ($class, %args) = @_;
  25   my $target = caller;
  26   if (@_ == 1) { # "use Devel::Declare;"
  27     no strict 'refs';
  28     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  29       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  30     }
  31   } else {
  32     $class->setup_for($target => \%args);
  33   }
  34 }
  35
  36 sub unimport {
  37   my ($class) = @_;
  38   my $target = caller;
  39   $class->teardown_for($target);
  40 }
  41
  42 sub setup_for {
  43   my ($class, $target, $args) = @_;
  44   setup();
  45   foreach my $key (keys %$args) {
  46     my $info = $args->{$key};
  47     my ($flags, $sub);
  48     if (ref($info) eq 'ARRAY') {
  49       ($flags, $sub) = @$info;
  50     } elsif (ref($info) eq 'CODE') {
  51       $flags = DECLARE_NAME;
  52       $sub = $info;
  53     } elsif (ref($info) eq 'HASH') {
  54       $flags = 1;
  55       $sub = $info;
  56     } else {
  57       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
  58     }
  59     $declarators{$target}{$key} = $flags;
  60     $declarator_handlers{$target}{$key} = $sub;
  61   }
  62 }
  63
  64 sub teardown_for {
  65   my ($class, $target) = @_;
  66   delete $declarators{$target};
  67   delete $declarator_handlers{$target};
  68 }
  69
  70 my $temp_name;
  71 my $temp_save;
  72
  73 sub init_declare {
  74   my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
  75   my ($name_h, $XX_h, $extra_code)
  76        = $declarator_handlers{$usepack}{$use}->(
  77            $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
  78          );
  79   ($temp_name, $temp_save) = ([], []);
  80   if ($name) {
  81     $name = "${inpack}::${name}" unless $name =~ /::/;
  82     shadow_sub($name, $name_h);
  83   }
  84   if ($XX_h) {
  85     shadow_sub("${inpack}::X", $XX_h);
  86   }
  87   if (defined wantarray) {
  88     return $extra_code || '0;';
  89   } else {
  90     return;
  91   }
  92 }
  93
  94 sub shadow_sub {
  95   my ($name, $cr) = @_;
  96   push(@$temp_name, $name);
  97   no strict 'refs';
  98   my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
  99   push(@$temp_save, $pack->can($pname));
 100   no warnings 'redefine';
 101   no warnings 'prototype';
 102   *{$name} = $cr;
 103   set_in_declare(~~@{$temp_name||[]});
 104 }
 105
 106 sub done_declare {
 107   no strict 'refs';
 108   my $name = shift(@{$temp_name||[]});
 109   die "done_declare called with no temp_name stack" unless defined($name);
 110   my $saved = shift(@$temp_save);
 111   $name =~ s/(.*):://;
 112   my $temp_pack = $1;
 113   delete ${"${temp_pack}::"}{$name};
 114   if ($saved) {
 115     no warnings 'prototype';
 116     *{"${temp_pack}::${name}"} = $saved;
 117   }
 118   set_in_declare(~~@{$temp_name||[]});
 119 }
 120
 121 sub build_sub_installer {
 122   my ($class, $pack, $name, $proto) = @_;
 123   return eval "
 124     package ${pack};
 125     my \$body;
 126     sub ${name} (${proto}) :lvalue {\n"
 127     .'  if (wantarray) {
 128         goto &$body;
 129       }
 130       my $ret = $body->(@_);
 131       return $ret;
 132     };
 133     sub { ($body) = @_; };';
 134 }
 135
 136 sub setup_declarators {
 137   my ($class, $pack, $to_setup) = @_;
 138   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 139     unless defined($pack) && ref($to_setup) eq 'HASH';
 140   my %setup_for_args;
 141   foreach my $name (keys %$to_setup) {
 142     my $info = $to_setup->{$name};
 143     my $flags = $info->{flags} || DECLARE_NAME;
 144     my $run = $info->{run};
 145     my $compile = $info->{compile};
 146     my $proto = $info->{proto} || '&';
 147     my $sub_proto = $proto;
 148     # make all args optional to enable lvalue for DECLARE_NONE
 149     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 150     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 151     my $installer = $class->build_sub_installer($pack, $name, '@');
 152     $installer->(sub :lvalue {
 153 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 154       if (@_) {
 155         if (ref $_[0] eq 'HASH') {
 156           shift;
 157           if (wantarray) {
 158             my @ret = $run->(undef, undef, @_);
 159             return @ret;
 160           }
 161           my $r = $run->(undef, undef, @_);
 162           return $r;
 163         } else {
 164           return @_[1..$#_];
 165         }
 166       }
 167       return my $sv;
 168     });
 169     $setup_for_args{$name} = [
 170       $flags,
 171       sub {
 172         my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
 173         my $extra_code = $compile->($name, $proto, $traits);
 174         my $main_handler = sub { shift if $shift_hashref;
 175           ("DONE", $run->($name, $proto, @_));
 176         };
 177         my ($name_h, $XX);
 178         if (defined $proto) {
 179           $name_h = sub :lvalue { return my $sv; };
 180           $XX = $main_handler;
 181         } elsif (defined $name && length $name) {
 182           $name_h = $main_handler;
 183         }
 184         $extra_code ||= '';
 185         $extra_code = '}, sub {'.$extra_code;
 186         return ($name_h, $XX, $extra_code);
 187       }
 188     ];
 189   }
 190   $class->setup_for($pack, \%setup_for_args);
 191 }
 192
 193 sub install_declarator {
 194   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 195   $class->setup_declarators($target_pack, {
 196     $target_name => {
 197       flags => $flags,
 198       compile => $filter,
 199       run => $handler,
 200    }
 201   });
 202 }
 203
 204 sub linestr_callback_rv2cv {
 205   my ($name, $offset) = @_;
 206   $offset += toke_move_past_token($offset);
 207   my $pack = get_curstash_name();
 208   my $flags = $declarators{$pack}{$name};
 209   my ($found_name, $found_proto);
 210   if ($flags & DECLARE_NAME) {
 211     $offset += toke_skipspace($offset);
 212     my $linestr = get_linestr();
 213     if (substr($linestr, $offset, 2) eq '::') {
 214       substr($linestr, $offset, 2) = '';
 215       set_linestr($linestr);
 216     }
 217     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 218       $found_name = substr($linestr, $offset, $len);
 219       $offset += $len;
 220     }
 221   }
 222   if ($flags & DECLARE_PROTO) {
 223     $offset += toke_skipspace($offset);
 224     my $linestr = get_linestr();
 225     if (substr($linestr, $offset, 1) eq '(') {
 226       my $length = toke_scan_str($offset);
 227       $found_proto = get_lex_stuff();
 228       clear_lex_stuff();
 229       my $replace =
 230         ($found_name ? ' ' : '=')
 231         .'X'.(' ' x length($found_proto));
 232       $linestr = get_linestr();
 233       substr($linestr, $offset, $length) = $replace;
 234       set_linestr($linestr);
 235       $offset += $length;
 236     }
 237   }
 238   my @args = ($pack, $name, $pack, $found_name, $found_proto);
 239   $offset += toke_skipspace($offset);
 240   my $linestr = get_linestr();
 241   if (substr($linestr, $offset, 1) eq '{') {
 242     my $ret = init_declare(@args);
 243     $offset++;
 244     if (defined $ret && length $ret) {
 245       substr($linestr, $offset, 0) = $ret;
 246       set_linestr($linestr);
 247     }
 248   } else {
 249     init_declare(@args);
 250   }
 251   #warn "linestr now ${linestr}";
 252 }
 253
 254 sub linestr_callback_const {
 255   my ($name, $offset) = @_;
 256   my $pack = get_curstash_name();
 257   my $flags = $declarators{$pack}{$name};
 258   if ($flags & DECLARE_NAME) {
 259     $offset += toke_move_past_token($offset);
 260     $offset += toke_skipspace($offset);
 261     if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 262       my $linestr = get_linestr();
 263       substr($linestr, $offset, 0) = '::';
 264       set_linestr($linestr);
 265     }
 266   }
 267 }
 268
 269 sub linestr_callback {
 270   my $type = shift;
 271   my $name = $_[0];
 272   my $pack = get_curstash_name();
 273   my $handlers = $declarator_handlers{$pack}{$name};
 274   if (ref $handlers eq 'CODE') {
 275     my $meth = "linestr_callback_${type}";
 276     __PACKAGE__->can($meth)->(@_);
 277   } elsif (ref $handlers eq 'HASH') {
 278     if ($handlers->{$type}) {
 279       $handlers->{$type}->(@_);
 280     }
 281   } else {
 282     die "PANIC: unknown thing in handlers for $pack $name: $handlers";
 283   }
 284 }
 285
 286 =head1 NAME
 287
 288 Devel::Declare - Adding keywords to perl, in perl
 289
 290 =head1 SYNOPSIS
 291
 292   use Method::Signatures;
 293   # or ...
 294   use MooseX::Declare;
 295   # etc.
 296
 297   # Use some new and exciting syntax like:
 298   method hello (Str :$who, Int :$age where { $_ > 0 }) {
 299     $self->say("Hello ${who}, I am ${age} years old!");
 300   }
 301
 302 =head1 DESCRIPTION
 303
 304 L<Devel::Declare> can install subroutines called declarators which locally take
 305 over Perl's parser, allowing the creation of new syntax.
 306
 307 This document describes how to create a simple declarator.
 308
 309 =head1 USAGE
 310
 311 We'll demonstrate the usage of C<Devel::Declare> with a motivating example: a new
 312 C<method> keyword, which acts like the builtin C<sub>, but automatically unpacks
 313 C<$self> and the other arguments.
 314
 315   package My::Methods;
 316   use Devel::Declare;
 317
 318 =head2 Creating a declarator with C<setup_for>
 319
 320 You will typically create
 321
 322   sub import {
 323     my $class = shift;
 324     my $caller = caller;
 325
 326     Devel::Declare->setup_for(
 327         $caller,
 328         { method => { const => \&parser } }
 329     );
 330     no strict 'refs';
 331     *{$caller.'::method'} = sub (&) {};
 332   }
 333
 334 Starting from the end of this import routine, you'll see that we're creating a
 335 subroutine called C<method> in the caller's namespace.  Yes, that's just a normal
 336 subroutine, and it does nothing at all (yet!)  Note the prototype C<(&)> which means
 337 that the caller would call it like so:
 338
 339     method {
 340         my ($self, $arg1, $arg2) = @_;
 341         ...
 342     }
 343
 344 However we want to be able to call it like this
 345
 346     method foo ($arg1, $arg2) {
 347         ...
 348     }
 349
 350 That's why we call C<setup_for> above, to register the declarator 'method' with a custom
 351 parser, as per the next section.  It acts on an optype, usually C<'const'> as above.
 352 (Other valid values are C<'check'> and C<'rv2cv'>).
 353
 354 For a simpler way to install new methods, see also L<Devel::Declare::MethodInstaller::Simple>
 355
 356 =head2 Writing a parser subroutine
 357
 358 This subroutine is called at I<compilation> time, and allows you to read the custom
 359 syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and
 360 munge it so that the result will be parsed by the C<perl> compiler.
 361
 362 For this example, we're defining some globals for convenience:
 363
 364     our ($Declarator, $Offset);
 365
 366 Then we define a parser subroutine to handle our declarator.  We'll look at this in
 367 a few chunks.
 368
 369     sub parser {
 370       local ($Declarator, $Offset) = @_;
 371
 372 C<Devel::Declare> provides some very low level utility methods to parse character
 373 strings.  We'll define some useful higher level routines below for convenience,
 374 and we can use these to parse the various elements in our new syntax.
 375
 376 Notice how our parser subroutine is invoked at compile time,
 377 when the C<perl> parser is pointed just I<before> the declarator name.
 378
 379       skip_declarator;          # step past 'method'
 380       my $name = strip_name;    # strip out the name 'foo', if present
 381       my $proto = strip_proto;  # strip out the prototype '($arg1, $arg2)', if present
 382
 383 Now we can prepare some code to 'inject' into the new subroutine.  For example we
 384 might want the method as above to have C<my ($self, $arg1, $arg2) = @_> injected at
 385 the beginning of it.  We also do some clever stuff with scopes that we'll look
 386 at shortly.
 387
 388       my $inject = make_proto_unwrap($proto);
 389       if (defined $name) {
 390         $inject = scope_injector_call().$inject;
 391       }
 392       inject_if_block($inject);
 393
 394 We've now managed to change C<method ($arg1, $arg2) { ... }> into C<method {
 395 injected_code; ... }>.  This will compile...  but we've lost the name of the
 396 method!
 397
 398 In a cute (or horrifying, depending on your perspective) trick, we temporarily
 399 change the definition of the subroutine C<method> itself, to specialise it with
 400 the C<$name> we stripped, so that it assigns the code block to that name.
 401
 402 Even though the I<next> time C<method> is compiled, it will be
 403 redefined again, C<perl> caches these definitions in its parse
 404 tree, so we'll always get the right one!
 405
 406 Note that we also handle the case where there was no name, allowing
 407 an anonymous method analogous to an anonymous subroutine.
 408
 409       if (defined $name) {
 410         $name = join('::', Devel::Declare::get_curstash_name(), $name)
 411           unless ($name =~ /::/);
 412         shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 413       } else {
 414         shadow(sub (&) { shift });
 415       }
 416     }
 417
 418
 419 =head2 Parser utilities in detail
 420
 421 For simplicity, we're using global variables like C<$Offset> in these examples.
 422 You may prefer to look at L<Devel::Declare::Context::Simple>, which
 423 encapsulates the context much more cleanly.
 424
 425 =head3 C<skip_declarator>
 426
 427 This simple parser just moves across a 'token'.  The common case is
 428 to skip the declarator, i.e.  to move to the end of the string
 429 'method' and before the prototype and code block.
 430
 431     sub skip_declarator {
 432       $Offset += Devel::Declare::toke_move_past_token($Offset);
 433     }
 434
 435 =head4 C<toke_move_past_token>
 436
 437 This builtin parser simply moves past a 'token' (matching C</[a-zA-Z_]\w*/>)
 438 It takes an offset into the source document, and skips past the token.
 439 It returns the number of characters skipped.
 440
 441 =head3 C<strip_name>
 442
 443 This parser skips any whitespace, then scans the next word (again matching a
 444 'token').  We can then analyse the current line, and manipulate it (using pure
 445 Perl).  In this case we take the name of the method out, and return it.
 446
 447     sub strip_name {
 448       skipspace;
 449       if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
 450         my $linestr = Devel::Declare::get_linestr();
 451         my $name = substr($linestr, $Offset, $len);
 452         substr($linestr, $Offset, $len) = '';
 453         Devel::Declare::set_linestr($linestr);
 454         return $name;
 455       }
 456       return;
 457     }
 458
 459 =head4 C<toke_scan_word>
 460
 461 This builtin parser, given an offset into the source document,
 462 matches a 'token' as above but does not skip.  It returns the
 463 length of the token matched, if any.
 464
 465 =head4 C<get_linestr>
 466
 467 This builtin returns the full text of the current line of the source document.
 468
 469 =head4 C<set_linestr>
 470
 471 This builtin sets the full text of the current line of the source document.
 472
 473 =head3 C<skipspace>
 474
 475 This parser skips whitsepace.
 476
 477     sub skipspace {
 478       $Offset += Devel::Declare::toke_skipspace($Offset);
 479     }
 480
 481 =head4 C<toke_skipspace>
 482
 483 This builtin parser, given an offset into the source document,
 484 skips over any whitespace, and returns the number of characters
 485 skipped.
 486
 487 =head3 C<strip_proto>
 488
 489 This is a more complex parser that checks if it's found something that
 490 starts with C<'('> and returns everything till the matching C<')'>.
 491
 492     sub strip_proto {
 493       skipspace;
 494
 495       my $linestr = Devel::Declare::get_linestr();
 496       if (substr($linestr, $Offset, 1) eq '(') {
 497         my $length = Devel::Declare::toke_scan_str($Offset);
 498         my $proto = Devel::Declare::get_lex_stuff();
 499         Devel::Declare::clear_lex_stuff();
 500         $linestr = Devel::Declare::get_linestr();
 501         substr($linestr, $Offset, $length) = '';
 502         Devel::Declare::set_linestr($linestr);
 503         return $proto;
 504       }
 505       return;
 506     }
 507
 508 =head4 C<toke_scan_str>
 509
 510 This builtin parser uses Perl's own parsing routines to match a "stringlike"
 511 expression.  Handily, this includes bracketed expressions (just think about
 512 things like C<q(this is a quote)>).
 513
 514 Also it Does The Right Thing with nested delimiters (like C<q(this (is (a) quote))>).
 515
 516 It returns the effective length of the expression matched.  Really, what
 517 it returns is the difference in position between where the string started,
 518 within the buffer, and where it finished.  If the string extended across
 519 multiple lines then the contents of the buffer may have been completely
 520 replaced by the new lines, so this position difference is not the same
 521 thing as the actual length of the expression matched.  However, because
 522 moving backward in the buffer causes problems, the function arranges
 523 for the effective length to always be positive, padding the start of
 524 the buffer if necessary.
 525
 526 Use C<get_lex_stuff> to get the actual matched text, the content of
 527 the string.  Because of the behaviour around multiline strings, you
 528 can't reliably get this from the buffer.  In fact, after the function
 529 returns, you can't rely on any content of the buffer preceding the end
 530 of the string.
 531
 532 =head4 C<get_lex_stuff>
 533
 534 This builtin returns what was matched by C<toke_scan_str>.  To avoid segfaults,
 535 you should call C<clear_lex_stuff> immediately afterwards.
 536
 537 =head2 Munging the subroutine
 538
 539 Let's look at what we need to do in detail.
 540
 541 =head3 C<make_proto_unwrap>
 542
 543 We may have defined our method in different ways, which will result
 544 in a different value for our prototype, as parsed above.  For example:
 545
 546     method foo         {  # undefined
 547     method foo ()      {  # ''
 548     method foo ($arg1) {  # '$arg1'
 549
 550 We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;>
 551 string.
 552
 553     sub make_proto_unwrap {
 554       my ($proto) = @_;
 555       my $inject = 'my ($self';
 556       if (defined $proto) {
 557         $inject .= ", $proto" if length($proto);
 558         $inject .= ') = @_; ';
 559       } else {
 560         $inject .= ') = shift;';
 561       }
 562       return $inject;
 563     }
 564
 565 =head3 C<inject_if_block>
 566
 567 Now we need to inject it after the opening C<'{'> of the method body.
 568 We can do this with the building blocks we defined above like C<skipspace>
 569 and C<get_linestr>.
 570
 571     sub inject_if_block {
 572       my $inject = shift;
 573       skipspace;
 574       my $linestr = Devel::Declare::get_linestr;
 575       if (substr($linestr, $Offset, 1) eq '{') {
 576         substr($linestr, $Offset+1, 0) = $inject;
 577         Devel::Declare::set_linestr($linestr);
 578       }
 579     }
 580
 581 =head3 C<scope_injector_call>
 582
 583 We want to be able to handle both named and anonymous methods.  i.e.
 584
 585     method foo () { ... }
 586     my $meth = method () { ... };
 587
 588 These will then get rewritten as
 589
 590     method { ... }
 591     my $meth = method { ... };
 592
 593 where 'method' is a subroutine that takes a code block.  Spot the problem?
 594 The first one doesn't have a semicolon at the end of it!  Unlike 'sub' which
 595 is a builtin, this is just a normal statement, so we need to terminate it.
 596 Luckily, using C<B::Hooks::EndOfScope>, we can do this!
 597
 598   use B::Hooks::EndOfScope;
 599
 600 We'll add this to what gets 'injected' at the beginning of the method source.
 601
 602   sub scope_injector_call {
 603     return ' BEGIN { MethodHandlers::inject_scope }; ';
 604   }
 605
 606 So at the beginning of every method, we are passing a callback that will get invoked
 607 at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
 608 is compiled.
 609
 610   sub inject_scope {
 611     on_scope_end {
 612       my $linestr = Devel::Declare::get_linestr;
 613       my $offset = Devel::Declare::get_linestr_offset;
 614       substr($linestr, $offset, 0) = ';';
 615       Devel::Declare::set_linestr($linestr);
 616     };
 617   }
 618
 619 =head2 Shadowing each method.
 620
 621 =head3 C<shadow>
 622
 623 We override the current definition of 'method' using C<shadow>.
 624
 625     sub shadow {
 626       my $pack = Devel::Declare::get_curstash_name;
 627       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 628     }
 629
 630 For a named method we invoked like this:
 631
 632     shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 633
 634 So in the case of a C<method foo { ... }>, this call would redefine C<method>
 635 to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>.
 636
 637 The case of an anonymous method is also cute:
 638
 639     shadow(sub (&) { shift });
 640
 641 This means that
 642
 643     my $meth = method () { ... };
 644
 645 is rewritten with C<method> taking the codeblock, and returning it as is to become
 646 the value of C<$meth>.
 647
 648 =head4 C<get_curstash_name>
 649
 650 This returns the package name I<currently being compiled>.
 651
 652 =head4 C<shadow_sub>
 653
 654 Handles the details of redefining the subroutine.
 655
 656 =head1 SEE ALSO
 657
 658 One of the best ways to learn C<Devel::Declare> is still to look at
 659 modules that use it:
 660
 661 L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
 662
 663 =head1 AUTHORS
 664
 665 Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
 666
 667 Company: http://www.shadowcat.co.uk/
 668 Blog: http://chainsawblues.vox.com/
 669
 670 Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
 671
 672 osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation
 673
 674 =head1 COPYRIGHT AND LICENSE
 675
 676 This library is free software under the same terms as perl itself
 677
 678 Copyright (c) 2007, 2008, 2009  Matt S Trout
 679
 680 Copyright (c) 2008, 2009  Florian Ragwitz
 681
 682 stolen_chunk_of_toke.c based on toke.c from the perl core, which is
 683
 684 Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 685 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
 686
 687 =cut
 688
 689 1;