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