use warnings;
use 5.008001;
-our $VERSION = '0.001011';
-
-# mirrored in Declare.xs as DD_HANDLE_*
+our $VERSION = '0.002000';
use constant DECLARE_NAME => 1;
use constant DECLARE_PROTO => 2;
=head1 SYNOPSIS
-Look at the tests. This module is currently on CPAN to ease smoke testing
-and allow early adopters who've been involved in the design to experiment
-with it.
-
-=head1 DESCRIPTION
-
-=head2 import
-
- use Devel::Declare qw(list of subs);
-
-Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
-
-=head2 unimport
+ use Devel::Declare ();
+ use Scope::Guard;
+
+ {
+ package MethodHandlers;
+
+ use strict;
+ use warnings;
+
+ our ($Declarator, $Offset);
+
+ 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) eq '(') {
+ 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]);
+ }
+
+ # undef -> my ($self) = shift;
+ # '' -> my ($self) = @_;
+ # '$foo' -> my ($self, $foo) = @_;
+
+ sub make_proto_unwrap {
+ my ($proto) = @_;
+ my $inject = 'my ($self';
+ if (defined $proto) {
+ $inject .= ", $proto" if length($proto);
+ $inject .= ') = @_; ';
+ } else {
+ $inject .= ') = shift;';
+ }
+ return $inject;
+ }
+
+ 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);
+ }
+ }
- no Devel::Declare;
+ sub scope_injector_call {
+ return ' BEGIN { MethodHandlers::inject_scope }; ';
+ }
+
+ sub parser {
+ local ($Declarator, $Offset) = @_;
+ skip_declarator;
+ my $name = strip_name;
+ my $proto = strip_proto;
+ my $inject = make_proto_unwrap($proto);
+ if (defined $name) {
+ $inject = scope_injector_call().$inject;
+ }
+ inject_if_block($inject);
+ if (defined $name) {
+ $name = join('::', Devel::Declare::get_curstash_name(), $name)
+ unless ($name =~ /::/);
+ shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+ } else {
+ shadow(sub (&) { shift });
+ }
+ }
+
+ 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);
+ });
+ }
+ }
+
+ my ($test_method1, $test_method2, @test_list);
+
+ {
+ package DeclareTest;
+
+ sub method (&);
+
+ BEGIN {
+ Devel::Declare->setup_for(
+ __PACKAGE__,
+ { method => { const => \&MethodHandlers::parser } }
+ );
+ }
+
+ method new {
+ my $class = ref $self || $self;
+ return bless({ @_ }, $class);
+ }
+
+ method foo ($foo) {
+ return (ref $self).': Foo: '.$foo;
+ }
+
+ method upgrade(){ # no spaces to make case pathological
+ bless($self, 'DeclareTest2');
+ }
+
+ method DeclareTest2::bar () {
+ return 'DeclareTest2: bar';
+ }
+
+ $test_method1 = method {
+ return join(', ', $self->{attr}, $_[1]);
+ };
+
+ $test_method2 = method ($what) {
+ return join(', ', ref $self, $what);
+ };
+
+ method main () { return "main"; }
+
+ @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
+
+ }
+
+ use Test::More 'no_plan';
+
+ my $o = DeclareTest->new(attr => "value");
+
+ isa_ok($o, 'DeclareTest');
+
+ is($o->{attr}, 'value', '@_ args ok');
+
+ is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
+
+ is($o->main, 'main', 'declaration of package named method ok');
+
+ $o->upgrade;
+
+ isa_ok($o, 'DeclareTest2');
+
+ is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
+
+ is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
+
+ is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
+
+ is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
+
+(this is t/method-no-semi.t in this distribution)
-Calls Devel::Declare->teardown_for(__PACKAGE__);
+=head1 DESCRIPTION
=head2 setup_for
- Devel::Declare->setup_for($package => \@subnames);
-
-Installs declarator magic (unless already installed) and registers
-"${package}::$name" for each member of @subnames
-
-=head2 teardown_for
-
- Devel::Declare->teardown_for($package);
+ Devel::Declare->setup_for(
+ $package,
+ {
+ $name => { $op_type => $sub }
+ }
+ );
-Deregisters all subs currently registered for $package and uninstalls
-declarator magic if number of teardown_for calls matches number of setup_for
-calls.
+Currently valid op types: 'check', 'rv2cv'
=head1 AUTHOR
projects / p5sagit/Devel-Declare.git / blobdiff