lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.006005';
   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
  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 length of the expression matched.  Use C<get_lex_stuff> to
 517 get the actual matched text.
 518
 519 =head4 C<get_lex_stuff>
 520
 521 This builtin returns what was matched by C<toke_scan_str>.  To avoid segfaults,
 522 you should call C<clear_lex_stuff> immediately afterwards.
 523
 524 =head2 Munging the subroutine
 525
 526 Let's look at what we need to do in detail.
 527
 528 =head3 C<make_proto_unwrap>
 529
 530 We may have defined our method in different ways, which will result
 531 in a different value for our prototype, as parsed above.  For example:
 532
 533     method foo         {  # undefined
 534     method foo ()      {  # ''
 535     method foo ($arg1) {  # '$arg1'
 536
 537 We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;>
 538 string.
 539
 540     sub make_proto_unwrap {
 541       my ($proto) = @_;
 542       my $inject = 'my ($self';
 543       if (defined $proto) {
 544         $inject .= ", $proto" if length($proto);
 545         $inject .= ') = @_; ';
 546       } else {
 547         $inject .= ') = shift;';
 548       }
 549       return $inject;
 550     }
 551
 552 =head3 C<inject_if_block>
 553
 554 Now we need to inject it after the opening C<'{'> of the method body.
 555 We can do this with the building blocks we defined above like C<skipspace>
 556 and C<get_linestr>.
 557
 558     sub inject_if_block {
 559       my $inject = shift;
 560       skipspace;
 561       my $linestr = Devel::Declare::get_linestr;
 562       if (substr($linestr, $Offset, 1) eq '{') {
 563         substr($linestr, $Offset+1, 0) = $inject;
 564         Devel::Declare::set_linestr($linestr);
 565       }
 566     }
 567
 568 =head3 C<scope_injector_call>
 569
 570 We want to be able to handle both named and anonymous methods.  i.e.
 571
 572     method foo () { ... }
 573     my $meth = method () { ... };
 574
 575 These will then get rewritten as
 576
 577     method { ... }
 578     my $meth = method { ... };
 579
 580 where 'method' is a subroutine that takes a code block.  Spot the problem?
 581 The first one doesn't have a semicolon at the end of it!  Unlike 'sub' which
 582 is a builtin, this is just a normal statement, so we need to terminate it.
 583 Luckily, using C<B::Hooks::EndOfScope>, we can do this!
 584
 585   use B::Hooks::EndOfScope;
 586
 587 We'll add this to what gets 'injected' at the beginning of the method source.
 588
 589   sub scope_injector_call {
 590     return ' BEGIN { MethodHandlers::inject_scope }; ';
 591   }
 592
 593 So at the beginning of every method, we are passing a callback that will get invoked
 594 at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
 595 is compiled.
 596
 597   sub inject_scope {
 598     on_scope_end {
 599       my $linestr = Devel::Declare::get_linestr;
 600       my $offset = Devel::Declare::get_linestr_offset;
 601       substr($linestr, $offset, 0) = ';';
 602       Devel::Declare::set_linestr($linestr);
 603     };
 604   }
 605
 606 =head2 Shadowing each method.
 607
 608 =head3 C<shadow>
 609
 610 We override the current definition of 'method' using C<shadow>.
 611
 612     sub shadow {
 613       my $pack = Devel::Declare::get_curstash_name;
 614       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 615     }
 616
 617 For a named method we invoked like this:
 618
 619     shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 620
 621 So in the case of a C<method foo { ... }>, this call would redefine C<method>
 622 to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>.
 623
 624 The case of an anonymous method is also cute:
 625
 626     shadow(sub (&) { shift });
 627
 628 This means that
 629
 630     my $meth = method () { ... };
 631
 632 is rewritten with C<method> taking the codeblock, and returning it as is to become
 633 the value of C<$meth>.
 634
 635 =head4 C<get_curstash_name>
 636
 637 This returns the package name I<currently being compiled>.
 638
 639 =head4 C<shadow_sub>
 640
 641 Handles the details of redefining the subroutine.
 642
 643 =head1 SEE ALSO
 644
 645 One of the best ways to learn C<Devel::Declare> is still to look at
 646 modules that use it:
 647
 648 L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
 649
 650 =head1 AUTHORS
 651
 652 Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
 653
 654 Company: http://www.shadowcat.co.uk/
 655 Blog: http://chainsawblues.vox.com/
 656
 657 Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
 658
 659 osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation
 660
 661 =head1 COPYRIGHT AND LICENSE
 662
 663 This library is free software under the same terms as perl itself
 664
 665 Copyright (c) 2007, 2008, 2009  Matt S Trout
 666
 667 Copyright (c) 2008, 2009  Florian Ragwitz
 668
 669 stolen_chunk_of_toke.c based on toke.c from the perl core, which is
 670
 671 Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 672 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
 673
 674 =cut
 675
 676 1;