--- /dev/null
+.*
+!.gitignore
+Makefile*
+!Makefile.PL
+META.yml
+blib
+build
+inc
+pm_to_blib
+MANIFEST*
+!MANIFEST.SKIP
+Debian*
+README
+Devel-Declare-*
+*.bs
+Declare.*
+!Declare.xs
Changes for Devel-Declare
+0.005004
+ - Don't redefine MEM_WRAP_CHECK_ if it's already defined, getting rid of
+ compilation errors on some perls (Maik Fischer).
+
+0.005003
+ - Failing tests for line number issues (Ash Berlin).
+ - Add strip_names_and_args (Cory Watson).
+ - Various pod fixes (Yanick Champoux, Florian Ragwitz).
+ - Add copyright statements.
+
0.005002
- Don't invoke the linestr callback if the parser was expecting an operator.
This makes calling a method with the name of a declarator work.
use warnings;
use 5.008001;
-our $VERSION = '0.005002';
+our $VERSION = '0.005004';
use constant DECLARE_NAME => 1;
use constant DECLARE_PROTO => 2;
return ' BEGIN { MethodHandlers::inject_scope }; ';
}
-So at the beginning of every method, we assing a callback that will get invoked
+So at the beginning of every method, we are passing a callback that will get invoked
at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
is compiled.
=head1 COPYRIGHT AND LICENSE
+This library is free software under the same terms as perl itself
+
Copyright (c) 2007, 2008, 2009 Matt S Trout
Copyright (c) 2008, 2009 Florian Ragwitz
-This library is free software under the same terms as perl itself
+stolen_chunk_of_toke.c based on toke.c from the perl core, which is
+
+Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
=cut
return;
}
+sub strip_names_and_args {
+ my $self = shift;
+ $self->skipspace;
+
+ my @args;
+
+ my $linestr = $self->get_linestr;
+ if (substr($linestr, $self->offset, 1) eq '(') {
+ # We had a leading paren, so we will now expect comma separated
+ # arguments
+ substr($linestr, $self->offset, 1) = '';
+ $self->set_linestr($linestr);
+ $self->skipspace;
+
+ # At this point we expect to have a comma-separated list of
+ # barewords with optional protos afterward, so loop until we
+ # run out of comma-separated values
+ while (1) {
+ # Get the bareword
+ my $thing = $self->strip_name;
+ # If there's no bareword here, bail
+ confess "failed to parse bareword. found ${linestr}"
+ unless defined $thing;
+
+ $linestr = $self->get_linestr;
+ if (substr($linestr, $self->offset, 1) eq '(') {
+ # This one had a proto, pull it out
+ push(@args, [ $thing, $self->strip_proto ]);
+ } else {
+ # This had no proto, so store it with an undef
+ push(@args, [ $thing, undef ]);
+ }
+ $self->skipspace;
+ $linestr = $self->get_linestr;
+
+ if (substr($linestr, $self->offset, 1) eq ',') {
+ # We found a comma, strip it out and set things up for
+ # another iteration
+ substr($linestr, $self->offset, 1) = '';
+ $self->set_linestr($linestr);
+ $self->skipspace;
+ } else {
+ # No comma, get outta here
+ last;
+ }
+ }
+
+ # look for the final closing paren of the list
+ if (substr($linestr, $self->offset, 1) eq ')') {
+ substr($linestr, $self->offset, 1) = '';
+ $self->set_linestr($linestr);
+ $self->skipspace;
+ }
+ else {
+ # fail if it isn't there
+ confess "couldn't find closing paren for argument. found ${linestr}"
+ }
+ } else {
+ # No parens, so expect a single arg
+ my $thing = $self->strip_name;
+ # If there's no bareword here, bail
+ confess "failed to parse bareword. found ${linestr}"
+ unless defined $thing;
+ $linestr = $self->get_linestr;
+ if (substr($linestr, $self->offset, 1) eq '(') {
+ # This one had a proto, pull it out
+ push(@args, [ $thing, $self->strip_proto ]);
+ } else {
+ # This had no proto, so store it with an undef
+ push(@args, [ $thing, undef ]);
+ }
+ }
+
+ return \@args;
+}
+
sub get_curstash_name {
return Devel::Declare::get_curstash_name;
}
#define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */
#define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */
#define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */
-/*#define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),*/
/* conditionalise these two because as of 5.9.5 we already get them from
the headers (mst) */
#ifndef SvPVX_const
#define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
#endif
+#ifndef MEM_WRAP_CHECK_
+#define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),
+#endif
#define SvPV_renew(sv,n) \
STMT_START { SvLEN_set(sv, n); \
$ctx->skip_declarator;
my $name = $ctx->strip_name;
my $proto = $ctx->strip_proto;
+
+ # Check for an 'is' to test strip_name_and_args
+ my $word = $ctx->strip_name;
+ my $traits;
+ if (defined($word) && ($word eq 'is')) {
+ $traits = $ctx->strip_names_and_args;
+ }
+
my $inject = make_proto_unwrap($proto);
if (defined $name) {
$inject = $ctx->scope_injector_call().$inject;
if (defined $name) {
$name = join('::', Devel::Declare::get_curstash_name(), $name)
unless ($name =~ /::/);
- $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+ # for trait testing we're just interested in the trait parse result, not
+ # the method body and its injections
+ $ctx->shadow(sub (&) {
+ no strict 'refs';
+ *{$name} = $traits
+ ? sub { $traits }
+ : shift;
+ });
} else {
$ctx->shadow(sub (&) { shift });
}
return (ref $self).': Foo: '.$foo;
}
+ method has_many_traits() is (Trait1, Trait2(foo => 'bar'), Baz(one, two)) {
+ return 1;
+ }
+
+ method has_a_trait() is Foo1 {
+ return 1;
+ }
+
method upgrade(){ # no spaces to make case pathological
bless($self, 'DeclareTest2');
}
is($o->multiline2(1,2), '1 2', 'multiline2 proto ok');
is($o->multiline3(4,5), '5 4', 'multiline3 proto ok');
+is_deeply(
+ $o->has_many_traits,
+ [['Trait1', undef], ['Trait2', q[foo => 'bar']], ['Baz', 'one, two']],
+ 'extracting multiple traits',
+);
+
+is_deeply(
+ $o->has_a_trait,
+ [['Foo1', undef]],
+ 'extract one trait without arguments',
+);
+
$o->upgrade;
isa_ok($o, 'DeclareTest2');
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ eval 'use B::Compiling';
+
+ $@ and plan 'skip_all' => $@
+ or plan tests => 5;
+}
+
+my @lines;
+
+
+sub handle_fun {
+ my $pack = shift;
+
+ push @lines, PL_compiling->line;
+
+ my $offset = Devel::Declare::get_linestr_offset();
+ $offset += Devel::Declare::toke_move_past_token($offset);
+ my $stripped = Devel::Declare::toke_skipspace($offset);
+ my $linestr = Devel::Declare::get_linestr();
+
+ push @lines, PL_compiling->line;
+}
+
+
+use Devel::Declare;
+BEGIN {
+sub fun(&) {}
+
+Devel::Declare->setup_for(
+ __PACKAGE__,
+ { fun => { const => \&handle_fun } }
+);
+}
+
+
+#line 100
+fun
+{ };
+my $line = __LINE__;
+my $line2 = __LINE__;
+
+# Reset the line number back to what it actually is
+#line 48
+is(@lines, 2, "2 line numbers recorded");
+is $lines[0], 100, "fun starts on line 100";
+{
+ local $TODO = "line numbers aren't quite right yet, sometimes";
+ is $lines[1], 101, "fun stops on line 101";
+ is $line, 102, "next statement on line 102";
+ is $line2, 103, "next statement on line 103";
+}
projects / p5sagit/Devel-Declare.git / commitdiff