X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDevel%2FDeclare%2FMethodInstaller%2FSimple.pm;h=a5f0c379bae2e1b87efcaf3ababdabf242a4f77a;hb=9de3c0575dae5881780a79b80867ae983edb7cc9;hp=9a11911c5dc6f8753b6fd41602a9e25130b697ec;hpb=ab449c2e81bf76bdd7348c6a1a10a25a70093dff;p=p5sagit%2FDevel-Declare.git diff --git a/lib/Devel/Declare/MethodInstaller/Simple.pm b/lib/Devel/Declare/MethodInstaller/Simple.pm index 9a11911..a5f0c37 100644 --- a/lib/Devel/Declare/MethodInstaller/Simple.pm +++ b/lib/Devel/Declare/MethodInstaller/Simple.pm @@ -7,6 +7,8 @@ use Sub::Name; use strict; use warnings; +our $VERSION = '0.003005'; + sub install_methodhandler { my $class = shift; my %args = @_; @@ -22,49 +24,29 @@ sub install_methodhandler { ); } -sub strip_attrs { - my $self = shift; - $self->skipspace; - - my $linestr = Devel::Declare::get_linestr; - my $attrs = ''; - - if (substr($linestr, $self->offset, 1) eq ':') { - while (substr($linestr, $self->offset, 1) ne '{') { - if (substr($linestr, $self->offset, 1) eq ':') { - substr($linestr, $self->offset, 1) = ''; - Devel::Declare::set_linestr($linestr); - - $attrs .= ':'; - } - - $self->skipspace; - $linestr = Devel::Declare::get_linestr(); - - if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) { - my $name = substr($linestr, $self->offset, $len); - substr($linestr, $self->offset, $len) = ''; - Devel::Declare::set_linestr($linestr); - - $attrs .= " ${name}"; - - if (substr($linestr, $self->offset, 1) eq '(') { - my $length = Devel::Declare::toke_scan_str($self->offset); - my $arg = Devel::Declare::get_lex_stuff(); - Devel::Declare::clear_lex_stuff(); - $linestr = Devel::Declare::get_linestr(); - substr($linestr, $self->offset, $length) = ''; - Devel::Declare::set_linestr($linestr); +sub code_for { + my ($self, $name) = @_; - $attrs .= "(${arg})"; - } - } - } - - $linestr = Devel::Declare::get_linestr(); + if (defined $name) { + my $pkg = $self->get_curstash_name; + $name = join( '::', $pkg, $name ) + unless( $name =~ /::/ ); + return sub (&) { + my $code = shift; + # So caller() gets the subroutine name + no strict 'refs'; + *{$name} = subname $name => $code; + return; + }; + } else { + return sub (&) { shift }; } +} + +sub install { + my ($self, $name ) = @_; - return $attrs; + $self->shadow( $self->code_for($name) ); } sub parser { @@ -81,22 +63,13 @@ sub parser { $inject = $self->scope_injector_call() . $inject; } $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : ''); - if (defined $name) { - my $pkg = $self->get_curstash_name; - $name = join( '::', $pkg, $name ) - unless( $name =~ /::/ ); - $self->shadow( sub (&) { - my $code = shift; - # So caller() gets the subroutine name - no strict 'refs'; - *{$name} = subname $name => $code; - }); - } else { - $self->shadow(sub (&) { shift }); - } + + $self->install( $name ); + + return; } -sub parse_proto { } +sub parse_proto { '' } sub inject_parsed_proto { return $_[1];