[Bast-commits] r4830 - in trunk/Devel-Declare: . t
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Sat Sep 20 15:22:27 BST 2008
Author: matthewt
Date: 2008-09-20 15:22:27 +0100 (Sat, 20 Sep 2008)
New Revision: 4830
Added:
trunk/Devel-Declare/t/method.t
trunk/Devel-Declare/t/new.t
trunk/Devel-Declare/t/statement.t
Modified:
trunk/Devel-Declare/Declare.xs
Log:
add offset function for non-callback driven stuff, add tests
Modified: trunk/Devel-Declare/Declare.xs
===================================================================
--- trunk/Devel-Declare/Declare.xs 2008-09-20 14:21:04 UTC (rev 4829)
+++ trunk/Devel-Declare/Declare.xs 2008-09-20 14:22:27 UTC (rev 4830)
@@ -136,6 +136,11 @@
return HvNAME(PL_curstash);
}
+int dd_get_linestr_offset(pTHX) {
+ char* linestr = SvPVX(PL_linestr);
+ return PL_bufptr - linestr;
+}
+
char* dd_move_past_token (pTHX_ char* s) {
/*
@@ -360,6 +365,13 @@
RETVAL
int
+get_linestr_offset()
+ CODE:
+ RETVAL = dd_get_linestr_offset(aTHX);
+ OUTPUT:
+ RETVAL
+
+int
toke_scan_word(int offset, int handle_package)
CODE:
RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
Added: trunk/Devel-Declare/t/method.t
===================================================================
--- trunk/Devel-Declare/t/method.t (rev 0)
+++ trunk/Devel-Declare/t/method.t 2008-09-20 14:22:27 UTC (rev 4830)
@@ -0,0 +1,179 @@
+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]);
+ }
+
+ sub inject_str {
+ my $linestr = Devel::Declare::get_linestr;
+ substr($linestr, $Offset, 0) = $_[0];
+ Devel::Declare::set_linestr($linestr);
+ }
+
+ sub strip_str {
+ my $linestr = Devel::Declare::get_linestr;
+ if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+ substr($linestr, $Offset, length($_[0])) = '';
+ Devel::Declare::set_linestr($linestr);
+ return 1;
+ }
+ return 0;
+ }
+
+ sub parser {
+ my $pack = shift;
+ local ($Declarator, $Offset) = @_;
+ skip_declarator;
+ skipspace;
+ my $name = strip_name;
+ skipspace if defined($name);
+ my $proto = strip_proto;
+ skipspace if defined($proto);
+ my $linestr = Devel::Declare::get_linestr;
+ if (substr($linestr, $Offset, 1) eq '{') {
+ my $inject = 'my ($self';
+ if (defined $proto) {
+ $inject .= ", $proto" if length($proto);
+ $inject .= ') = @_; ';
+ } else {
+ $inject .= ') = shift;';
+ }
+ if (defined $name) {
+ $inject = ' BEGIN { MethodHandlers::inject_scope }; '.$inject;
+ }
+ substr($linestr, $Offset+1, 0) = $inject;
+ Devel::Declare::set_linestr($linestr);
+ }
+ if (defined $name) {
+ $name = join('::', $pack, $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 => sub { MethodHandlers::parser(__PACKAGE__, @_) } } }
+ );
+ }
+
+ 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');
Added: trunk/Devel-Declare/t/new.t
===================================================================
--- trunk/Devel-Declare/t/new.t (rev 0)
+++ trunk/Devel-Declare/t/new.t 2008-09-20 14:22:27 UTC (rev 4830)
@@ -0,0 +1,103 @@
+use Devel::Declare ();
+use Test::More qw(no_plan);
+
+{
+ package FoomHandlers;
+
+ 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]);
+ }
+
+ sub inject_str {
+ my $linestr = Devel::Declare::get_linestr;
+ substr($linestr, $Offset, 0) = $_[0];
+ Devel::Declare::set_linestr($linestr);
+ }
+
+ sub strip_str {
+ my $linestr = Devel::Declare::get_linestr;
+ if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+ substr($linestr, $Offset, length($_[0])) = '';
+ Devel::Declare::set_linestr($linestr);
+ return 1;
+ }
+ return 0;
+ }
+
+ sub const {
+ local ($Declarator, $Offset) = @_;
+ skip_declarator;
+ my $name = strip_name;
+ my $str = "happy ".(defined $name ? "foom: ${name}" : "anonymous foom");
+ if (defined(my $proto = strip_proto)) {
+ $str .= "; ${proto}";
+ }
+ shadow(sub { $str });
+ }
+
+ package Foo;
+
+ use strict;
+ use warnings;
+
+ sub foom { }
+
+ BEGIN {
+ Devel::Declare->setup_for(
+ __PACKAGE__,
+ { foom => {
+ const => \&FoomHandlers::const,
+ } }
+ );
+ }
+
+ ::is(foom, "happy anonymous foom", "foom");
+
+ ::is(foom KABOOM, "happy foom: KABOOM", "foom KABOOM");
+
+ ::is(foom (zoom), "happy anonymous foom; zoom", "foom (zoom)");
+
+ ::is(foom KABOOM (zoom), "happy foom: KABOOM; zoom", "foom KABOOM (zoom)");
+}
Added: trunk/Devel-Declare/t/statement.t
===================================================================
--- trunk/Devel-Declare/t/statement.t (rev 0)
+++ trunk/Devel-Declare/t/statement.t 2008-09-20 14:22:27 UTC (rev 4830)
@@ -0,0 +1,113 @@
+use Devel::Declare ();
+use Test::More qw(no_plan);
+use Scope::Guard;
+
+{
+ package FoomHandlers;
+
+ 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]);
+ }
+
+ sub inject_str {
+ my $linestr = Devel::Declare::get_linestr;
+ substr($linestr, $Offset, 0) = $_[0];
+ Devel::Declare::set_linestr($linestr);
+ }
+
+ sub strip_str {
+ my $linestr = Devel::Declare::get_linestr;
+ if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+ substr($linestr, $Offset, length($_[0])) = '';
+ Devel::Declare::set_linestr($linestr);
+ return 1;
+ }
+ return 0;
+ }
+
+ sub const {
+ local ($Declarator, $Offset) = @_;
+ skip_declarator;
+ skipspace;
+ my $linestr = Devel::Declare::get_linestr;
+ if (substr($linestr, $Offset, 1) eq '{') {
+ substr($linestr, $Offset+1, 0) = ' BEGIN { FoomHandlers::inject_scope }; ';
+ Devel::Declare::set_linestr($linestr);
+ }
+ shadow(sub (&) { "foom?" });
+ }
+
+ sub inject_scope {
+ $^H |= 0x120000;
+ $^H{DD_FOOMHANDLERS} = 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);
+ });
+ }
+
+ package Foo;
+
+ use strict;
+ use warnings;
+
+ sub foom (&) { }
+
+ BEGIN {
+ Devel::Declare->setup_for(
+ __PACKAGE__,
+ { foom => {
+ const => \&FoomHandlers::const,
+ } }
+ );
+ }
+
+ foom {
+ 1;
+ }
+
+ ::ok(1, 'Compiled as statement ok');
+}
More information about the Bast-commits
mailing list