File Coverage

blib/lib/Sub/Auto.pm

Criterion	Covered	Total	%
statement	111	113	98.2
branch	13	16	81.2
condition			n/a
subroutine	27	28	96.4
pod	0	10	0.0
total	151	167	90.4

package Sub::Auto;

our $VERSION = 0.0202;

=head1 NAME

Sub::Auto - declare individual handlers for AUTLOADed subs, respecting can and inheritance

=head1 SYNOPSIS

 use Sub::Auto;

 autosub /^get_(\w+)$/ {
    my ($what, @pars) = @_;
    print "Getting $what...\n";
 }

 autosub /^set_(\w+)_(\w+)$/ {
    my ($adjective, $noun, @pars) = @_;
    print "Setting the $adjective $noun\n";
 }

 autosub handle_foo_events /foo$/ {
    my ($subname, @pars) = @_;
    print "Called $subname to do something to a foo\n";
 }

 get_foo();
 if (__PACKAGE__->can('set_blue_cat')) { ... }

=head1 DESCRIPTION

C, like other languages' C features is a useful feature
for those situations when you want to handle sub or method calls dynamically, and
can't pre-generate the subroutines with accessor generators.

To be sure, this is almost never the case, but occasionally, C is convenient.

Well, "convenient" is a strong word, writing C handlers is mildly
unpleasant, and doesn't handle inheritance and C by default.

Using C you can:

=over 4

=item *

Declare multiple handlers, each responding to calls matching a given regular expression.

=item *

Optionally name your handler, for clarity, or because you want to call it directly.

=item *

Ensure that unhandled methods get dealt with by the next class in the inheritance chain.

=back

=head1 USAGE

=head2 C

 autosub [name] /regex/ { ... }

If the regex contains capturing parentheses, then each of those items will be prepended
to the sub's argument list.  For example:

 autosub /(\w+)_(\w+)/ {
    my ($verb, $noun, @params) = @_;
    print "$verb'ing $noun - " . join ','=>@params;
 }

 jump_up('one', 'two'); # prints "jump'ing up - one,two"

If the matching regex didn't have any capturing parens, the entire method name
is passed as the first argument.

The name of the sub is optional.  It registers a normal subroutine or method with
that name in the current package.  Nothing will be automatically prepended to a call
to this method!

 autosub foo /(\w+)_(\w+)/ {
    my ($verb, $noun, $one,$two) = @_;
    print $one + $two;
 }

 foo (undef,undef, 1, 2);

=head1 SEE ALSO

L by Ben Tilly, does all the heavy lifting.

L by Matt Trout provides the tasty syntactic sugar.

L

L or various other method generators that are a saner solution in general
than using AUTOLOAD at all.

=head1 AUTHOR AND LICENSE

 (c) 2008 [e-mail]

This module is released under the same terms as Perl itself.

=cut

use strict; use warnings;

use Class::AutoloadCAN;
use Devel::Declare 0.002;
use Sub::Name;
use Scope::Guard;
use vars qw($AUTOLOAD);

sub import {
    my $class = shift;
    my $caller = caller;

    my $parser = mk_parser($caller);
    Devel::Declare->setup_for(
        $caller => { autosub => { const => $parser }} );

    no strict 'refs';
    *{$caller.'::autosub'} = sub (&) {};

    # trick via mst.   See also export_to_level and Sub::Exporter
    *{ "${caller}::CAN" } = mk_can($caller);
    goto &Class::AutoloadCAN::import;
}

sub mk_can {
    my $package = shift;


    return sub {
        my ($class, $method, $self, @arguments) = @_;
        # YUCK!
        no strict 'refs';
        no warnings 'once';
        for my $can (@{"${package}::CANS"}) {
            my ($re, $sub) = @$can;
            if (my @result = $method =~ /$re/) {
                @result = $method unless defined $1; # or $& ?
                return sub {
                    $sub->(@result, @_)
                    };
            }
        }
        return;
        };
}

# Following boilerplate is stolen from Devel::Declare's t/method-no-semi.t
# Note that, as with Sub::Curried and Method::Signatures, this boilerplate
# may well be made into the "official" API shortly, at which point we'll
# refactor and clean up!

{
    our ($Declarator, $Offset);

    sub skip_declarator;
    sub strip_name;
    sub strip_proto;

    sub mk_parser {
      my $package = shift;
      return sub {
        local ($Declarator, $Offset) = @_;
        skip_declarator;
        my $name = strip_name;
        my $re = strip_proto;

        if (defined $name) {
            $name = join('::', Devel::Declare::get_curstash_name(), $name)
              unless ($name =~ /::/);
        }

        # we do scope trick even if no name (as the proto is a kind of name)
        my $inject = scope_injector_call();
        inject_if_block($inject);

        no strict 'refs';
        my $installer = sub (&) {
            my $f = shift;
            # YUCK!
            push @{"${package}::CANS"}, [qr/$re/, $f];
            # if we have a name, then install
            if ($name) {
                no strict 'refs';
                *{$name} = subname $name => $f;
            }
            return $f;
            };
        shadow($installer);
      };
    }

    sub skip_declarator {
        $Offset += Devel::Declare::toke_move_past_token($Offset);
    }

    sub skipspace {
        $Offset += Devel::Declare::toke_skipspace($Offset);
    }

    sub strip_name {
        skipspace;
        if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
            my $linestr = Devel::Declare::get_linestr();
            my $name = substr($linestr, $Offset, $len);
            substr($linestr, $Offset, $len) = '';
            Devel::Declare::set_linestr($linestr);
            return $name;
        }
        return;
    }

    sub strip_proto {
        skipspace;

        my $linestr = Devel::Declare::get_linestr();
        if (substr($linestr, $Offset, 1) =~/^[[:punct:]]$/ ) {
            my $length = Devel::Declare::toke_scan_str($Offset);
            my $proto = Devel::Declare::get_lex_stuff();
            Devel::Declare::clear_lex_stuff();
            $linestr = Devel::Declare::get_linestr();
            substr($linestr, $Offset, $length) = '';
            Devel::Declare::set_linestr($linestr);
            return $proto;
        }
        return;
    }

    sub shadow {
        my $pack = Devel::Declare::get_curstash_name;
        Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
    }

    sub inject_if_block {
        my $inject = shift;
        skipspace;
        my $linestr = Devel::Declare::get_linestr;
        if (substr($linestr, $Offset, 1) eq '{') {
            substr($linestr, $Offset+1, 0) = $inject;
            Devel::Declare::set_linestr($linestr);
        }
    }

    # Set up the parser scoping hacks that allow us to omit the final
    # semicolon
    sub scope_injector_call {
        my $pkg = __PACKAGE__;
        return " BEGIN { ${pkg}::inject_scope }; ";
    }
    sub inject_scope {
        $^H |= 0x120000;
        $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
            my $linestr = Devel::Declare::get_linestr;
            my $offset = Devel::Declare::get_linestr_offset;
            substr($linestr, $offset, 0) = ';';
            Devel::Declare::set_linestr($linestr);
        });
    }
}

1;