r36328 - in /trunk/libdevel-declare-perl: ./ debian/ inc/Module/ inc/Module/Install/ lib/Devel/ lib/Devel/Declare/Context/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun May 24 15:53:52 UTC 2009
Author: jawnsy-guest
Date: Sun May 24 15:53:47 2009
New Revision: 36328
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=36328
Log:
Fixed according to new upstream release (fix copyright)
Added:
trunk/libdevel-declare-perl/t/lines.t
Modified:
trunk/libdevel-declare-perl/Changes
trunk/libdevel-declare-perl/MANIFEST
trunk/libdevel-declare-perl/META.yml
trunk/libdevel-declare-perl/README
trunk/libdevel-declare-perl/debian/changelog
trunk/libdevel-declare-perl/debian/copyright
trunk/libdevel-declare-perl/inc/Module/Install.pm
trunk/libdevel-declare-perl/inc/Module/Install/Base.pm
trunk/libdevel-declare-perl/inc/Module/Install/MakeMaker.pm
trunk/libdevel-declare-perl/inc/Module/Install/Makefile.pm
trunk/libdevel-declare-perl/inc/Module/Install/Metadata.pm
trunk/libdevel-declare-perl/lib/Devel/Declare.pm
trunk/libdevel-declare-perl/lib/Devel/Declare/Context/Simple.pm
trunk/libdevel-declare-perl/t/ctx-simple.t
Modified: trunk/libdevel-declare-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/Changes?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/Changes (original)
+++ trunk/libdevel-declare-perl/Changes Sun May 24 15:53:47 2009
@@ -1,4 +1,10 @@
Changes for Devel-Declare
+
+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.
Modified: trunk/libdevel-declare-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/MANIFEST?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/MANIFEST (original)
+++ trunk/libdevel-declare-perl/MANIFEST Sun May 24 15:53:47 2009
@@ -19,6 +19,7 @@
t/ctx-simple.t
t/eval.t
t/fail.t
+t/lines.t
t/load_module.t
t/methinstaller-simple.t
t/method-installer-runtime.t
Modified: trunk/libdevel-declare-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/META.yml?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/META.yml (original)
+++ trunk/libdevel-declare-perl/META.yml Sun May 24 15:53:47 2009
@@ -10,7 +10,7 @@
ExtUtils::Depends: 0
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.85'
+generated_by: 'Module::Install version 0.90'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -28,4 +28,4 @@
perl: 5.8.1
resources:
license: http://dev.perl.org/licenses/
-version: 0.005002
+version: 0.005003
Modified: trunk/libdevel-declare-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/README?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/README (original)
+++ trunk/libdevel-declare-perl/README Sun May 24 15:53:47 2009
@@ -291,9 +291,9 @@
return ' BEGIN { MethodHandlers::inject_scope }; ';
}
- So at the beginning of every method, we assing a callback that will get
- invoked at the *end* of the method's compilation... i.e. exactly then
- the closing '}' is compiled.
+ So at the beginning of every method, we are passing a callback that will
+ get invoked at the *end* of the method's compilation... i.e. exactly
+ then the closing '}' is compiled.
sub inject_scope {
on_scope_end {
@@ -351,8 +351,17 @@
Florian Ragwitz <rafl at debian.org> - maintainer
- osfameron <osfameron at cpan.org<gt> - first draft of documentation
-
-LICENSE
+ osfameron <osfameron at cpan.org> - first draft of documentation
+
+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
+
+ 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
+
Modified: trunk/libdevel-declare-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/debian/changelog?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/debian/changelog (original)
+++ trunk/libdevel-declare-perl/debian/changelog Sun May 24 15:53:47 2009
@@ -1,7 +1,5 @@
-libdevel-declare-perl (0.005002-1) UNRELEASED; urgency=low
-
- WAIT for new upstream version.
+libdevel-declare-perl (0.005003-1) UNRELEASED; urgency=low
* Initial Release. (Closes: #529234)
- -- Jonathan Yu <frequency at cpan.org> Tue, 19 May 2009 01:22:14 -0400
+ -- Jonathan Yu <frequency at cpan.org> Sun, 24 May 2009 11:50:16 -0400
Modified: trunk/libdevel-declare-perl/debian/copyright
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/debian/copyright?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/debian/copyright (original)
+++ trunk/libdevel-declare-perl/debian/copyright Sun May 24 15:53:47 2009
@@ -9,9 +9,6 @@
2007-2009, Matt S Trout <mst at shadowcat.co.uk>
License-Alias: Perl
License: Artistic | GPL-1+
-X-Comment: This copyright information comes from a new revision of this file
- by the upstream maintainer: http://github.com/rafl/devel-declare/tree/master
- (See: lib/Devel/Declare.pm)
Files: stolen_chunk_of_toke.c
Copyright: 1991-2006, Larry Wall (et. al.) <larry at wall.org>
Modified: trunk/libdevel-declare-perl/inc/Module/Install.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/inc/Module/Install.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/inc/Module/Install.pm (original)
+++ trunk/libdevel-declare-perl/inc/Module/Install.pm Sun May 24 15:53:47 2009
@@ -28,7 +28,7 @@
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.85';
+ $VERSION = '0.90';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -353,7 +353,7 @@
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
@@ -384,7 +384,7 @@
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
Modified: trunk/libdevel-declare-perl/inc/Module/Install/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/inc/Module/Install/Base.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/inc/Module/Install/Base.pm (original)
+++ trunk/libdevel-declare-perl/inc/Module/Install/Base.pm Sun May 24 15:53:47 2009
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.90';
}
# Suspend handler for "redefined" warnings
@@ -13,42 +13,34 @@
$SIG{__WARN__} = sub { $w };
}
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 45
+#line 42
sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- next if defined &{"$class\::$method"};
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- };
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
}
-
- bless( \%args, $class );
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
}
-#line 66
+#line 61
sub AUTOLOAD {
- my $self = shift;
local $@;
- my $autoload = eval {
- $self->_top->autoload
- } or return;
- goto &$autoload;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
}
-#line 83
+#line 75
sub _top {
$_[0]->{_top};
}
-#line 98
+#line 90
sub admin {
$_[0]->_top->{admin}
@@ -56,7 +48,7 @@
Module::Install::Base::FakeAdmin->new;
}
-#line 114
+#line 106
sub is_admin {
$_[0]->admin->VERSION;
@@ -83,4 +75,4 @@
1;
-#line 162
+#line 154
Modified: trunk/libdevel-declare-perl/inc/Module/Install/MakeMaker.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/inc/Module/Install/MakeMaker.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/inc/Module/Install/MakeMaker.pm (original)
+++ trunk/libdevel-declare-perl/inc/Module/Install/MakeMaker.pm Sun May 24 15:53:47 2009
@@ -2,14 +2,14 @@
package Module::Install::MakeMaker;
use strict;
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.90';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
my $makefile;
Modified: trunk/libdevel-declare-perl/inc/Module/Install/Makefile.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/inc/Module/Install/Makefile.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/inc/Module/Install/Makefile.pm (original)
+++ trunk/libdevel-declare-perl/inc/Module/Install/Makefile.pm Sun May 24 15:53:47 2009
@@ -2,14 +2,14 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.90';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
Modified: trunk/libdevel-declare-perl/inc/Module/Install/Metadata.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/inc/Module/Install/Metadata.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/inc/Module/Install/Metadata.pm (original)
+++ trunk/libdevel-declare-perl/inc/Module/Install/Metadata.pm Sun May 24 15:53:47 2009
@@ -2,18 +2,17 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.90';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
- mymeta
};
my @scalar_keys = qw{
@@ -440,21 +439,21 @@
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
+ 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
@@ -511,12 +510,13 @@
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
- $v = $v + 0; # Numify
+ # Numify
+ $v = $v + 0;
}
return $v;
}
@@ -526,21 +526,56 @@
######################################################################
-# MYMETA.yml Support
+# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
-sub write_mymeta {
- my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return unless -f 'META.yml';
+sub write_mymeta_yaml {
+ my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
}
# Merge the perl version into the dependencies
@@ -558,7 +593,7 @@
}
# Load the advisory META.yml file
- my @yaml = YAML::Tiny::LoadFile('META.yml');
+ my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
@@ -572,9 +607,7 @@
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
- # Save as the MYMETA.yml file
- print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+ return $meta;
}
1;
Modified: trunk/libdevel-declare-perl/lib/Devel/Declare.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/lib/Devel/Declare.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/lib/Devel/Declare.pm (original)
+++ trunk/libdevel-declare-perl/lib/Devel/Declare.pm Sun May 24 15:53:47 2009
@@ -4,7 +4,7 @@
use warnings;
use 5.008001;
-our $VERSION = '0.005002';
+our $VERSION = '0.005003';
use constant DECLARE_NAME => 1;
use constant DECLARE_PROTO => 2;
@@ -590,7 +590,7 @@
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.
@@ -649,19 +649,28 @@
=head1 AUTHORS
-Matt S Trout - <mst at shadowcat.co.uk> - original author
+Matt S Trout - E<lt>mst at shadowcat.co.ukE<gt> - original author
Company: http://www.shadowcat.co.uk/
Blog: http://chainsawblues.vox.com/
Florian Ragwitz E<lt>rafl at debian.orgE<gt> - maintainer
-osfameron E<lt>osfameron at cpan.org<gt> - first draft of documentation
-
-=head1 LICENSE
+osfameron E<lt>osfameron at cpan.orgE<gt> - first draft of documentation
+
+=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
+
+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
1;
Modified: trunk/libdevel-declare-perl/lib/Devel/Declare/Context/Simple.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/lib/Devel/Declare/Context/Simple.pm?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/lib/Devel/Declare/Context/Simple.pm (original)
+++ trunk/libdevel-declare-perl/lib/Devel/Declare/Context/Simple.pm Sun May 24 15:53:47 2009
@@ -111,6 +111,82 @@
return $proto;
}
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 {
Modified: trunk/libdevel-declare-perl/t/ctx-simple.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/t/ctx-simple.t?rev=36328&op=diff
==============================================================================
--- trunk/libdevel-declare-perl/t/ctx-simple.t (original)
+++ trunk/libdevel-declare-perl/t/ctx-simple.t Sun May 24 15:53:47 2009
@@ -30,6 +30,14 @@
$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;
@@ -38,7 +46,14 @@
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 });
}
@@ -67,6 +82,14 @@
method foo ($foo) {
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
@@ -124,6 +147,18 @@
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');
Added: trunk/libdevel-declare-perl/t/lines.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdevel-declare-perl/t/lines.t?rev=36328&op=file
==============================================================================
--- trunk/libdevel-declare-perl/t/lines.t (added)
+++ trunk/libdevel-declare-perl/t/lines.t Sun May 24 15:53:47 2009
@@ -1,0 +1,55 @@
+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";
+}
More information about the Pkg-perl-cvs-commits
mailing list