@@ -1,5 +1,12 @@
Revision history for Perl module Parallel::Scoreboard
+0.07 2015-01-26
+ - do not include MYMETA.* in the distribution
+
+0.06 2015-01-26
+ - create workspace directory by using mkpath instead of mkdir (tolid)
+ - fixed a warning that could occur during global destruction when an attribute in the scoreboard object was destroyed before the object itself (Dave Rolsky)
+
0.05 2014-04-09
- when cleaning up obsolete scoreboard files, ignore errors when another process cleaned up the file at the same time (Karen Etheridge)
@@ -17,14 +17,13 @@ inc/Test/Base/Filter.pm
inc/Test/Builder.pm
inc/Test/Builder/Module.pm
inc/Test/More.pm
+inc/Test/Warn.pm
lib/Parallel/Scoreboard.pm
lib/Parallel/Scoreboard/PSGI/App.pm
lib/Parallel/Scoreboard/PSGI/App/JSON.pm
Makefile.PL
MANIFEST This list of files
META.yml
-MYMETA.json
-MYMETA.yml
-Parallel-Scoreboard-0.04.tar
README
t/00base.t
+t/01destroy.t
@@ -3,11 +3,12 @@ abstract: 'a scoreboard for monitoring status of many workers'
author:
- 'Kazuho Oku <kazuhooku gmail.com>'
build_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.36
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.36
distribution_type: module
-generated_by: 'Module::Install version 1.00'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.14'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -25,4 +26,4 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: https://github.com/kazuho/p5-Parallel-Scoreboard
-version: 0.05
+version: '0.07'
@@ -1,52 +0,0 @@
-{
- "abstract" : "a scoreboard for monitoring status of many workers",
- "author" : [
- "Kazuho Oku <kazuhooku gmail.com>"
- ],
- "dynamic_config" : 0,
- "generated_by" : "Module::Install version 1.00, CPAN::Meta::Converter version 2.131560",
- "license" : [
- "perl_5"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "Parallel-Scoreboard",
- "no_index" : {
- "directory" : [
- "inc",
- "t"
- ]
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "6.42"
- }
- },
- "configure" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "6.42"
- }
- },
- "runtime" : {
- "requires" : {
- "Class::Accessor::Lite" : "0.05",
- "Filter::Util::Call" : "0",
- "HTML::Entities" : "0",
- "JSON" : "0"
- }
- }
- },
- "release_status" : "stable",
- "resources" : {
- "license" : [
- "http://dev.perl.org/licenses/"
- ],
- "repository" : {
- "url" : "https://github.com/kazuho/p5-Parallel-Scoreboard"
- }
- },
- "version" : "0.04"
-}
@@ -1,28 +0,0 @@
----
-abstract: 'a scoreboard for monitoring status of many workers'
-author:
- - 'Kazuho Oku <kazuhooku gmail.com>'
-build_requires:
- ExtUtils::MakeMaker: 6.42
-configure_requires:
- ExtUtils::MakeMaker: 6.42
-dynamic_config: 0
-generated_by: 'Module::Install version 1.00, CPAN::Meta::Converter version 2.131560'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Parallel-Scoreboard
-no_index:
- directory:
- - inc
- - t
-requires:
- Class::Accessor::Lite: 0.05
- Filter::Util::Call: 0
- HTML::Entities: 0
- JSON: 0
-resources:
- license: http://dev.perl.org/licenses/
- repository: https://github.com/kazuho/p5-Parallel-Scoreboard
-version: 0.04
@@ -12,6 +12,7 @@ requires 'JSON';
test_requires 'File::Temp';
test_requires 'Test::More';
+test_requires 'Test::Warn';
use_test_base;
auto_include;
@@ -1,18 +1,22 @@
#line 1
package File::Temp;
+# ABSTRACT: return name and handle of a temporary file safely
+our $VERSION = '0.2304'; # VERSION
-#line 137
-# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
-# People would like a version on 5.004 so give them what they want :-)
-use 5.004;
+# Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway.
+# It might be possible to make this v5.5, but many v5.6isms are creeping
+# into the code and tests.
+use 5.006;
use strict;
use Carp;
use File::Spec 0.8;
-use File::Path qw/ rmtree /;
+use Cwd ();
+use File::Path 2.06 qw/ rmtree /;
use Fcntl 1.03;
use IO::Seekable; # For SEEK_*
use Errno;
+use Scalar::Util 'refaddr';
require VMS::Stdio if $^O eq 'VMS';
# pre-emptively load Carp::Heavy. If we don't when we run out of file
@@ -26,18 +30,19 @@ eval { require Carp::Heavy; };
require Symbol if $] < 5.006;
### For the OO interface
-use base qw/ IO::Handle IO::Seekable /;
-use overload '""' => "STRINGIFY", fallback => 1;
+use parent 0.221 qw/ IO::Handle IO::Seekable /;
+use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
+ fallback => 1;
# use 'our' on v5.6.0
-use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
+use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
$DEBUG = 0;
$KEEP_ALL = 0;
# We are exporting functions
-use base qw/Exporter/;
+use Exporter 5.57 'import'; # 5.57 lets us import 'import'
# Export list - to allow fine tuning of export table
@@ -68,10 +73,6 @@ use base qw/Exporter/;
# add contents of these tags to @EXPORT
Exporter::export_tags('POSIX','mktemp','seekable');
-# Version number
-
-$VERSION = '0.22';
-
# This is a list of characters that can be used in random filenames
my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
@@ -502,7 +503,7 @@ sub _replace_XX {
}
# Internal routine to force a temp file to be writable after
-# it is created so that we can unlink it. Windows seems to occassionally
+# it is created so that we can unlink it. Windows seems to occasionally
# force a file to be readonly when written to certain temp locations
sub _force_writable {
my $file = shift;
@@ -617,7 +618,7 @@ sub _is_verysafe {
}
# To reach this point either, the _PC_CHOWN_RESTRICTED symbol
- # was not avialable or the symbol was there but chown giveaway
+ # was not available or the symbol was there but chown giveaway
# is allowed. Either way, we now have to test the entire tree for
# safety.
@@ -667,7 +668,7 @@ sub _is_verysafe {
sub _can_unlink_opened_file {
- if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') {
+ if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
return 0;
} else {
return 1;
@@ -708,7 +709,7 @@ sub _can_do_level {
# Arguments:
# _deferred_unlink( $fh, $fname, $isdir );
#
-# - filehandle (so that it can be expclicitly closed if open
+# - filehandle (so that it can be explicitly closed if open
# - filename (the thing we want to remove)
# - isdir (flag to indicate that we are being given a directory)
# [and hence no filehandle]
@@ -735,12 +736,17 @@ sub _can_do_level {
# Set up an end block to use these arrays
END {
local($., $@, $!, $^E, $?);
- cleanup();
+ cleanup(at_exit => 1);
}
- # Cleanup function. Always triggered on END but can be invoked
- # manually.
+ # Cleanup function. Always triggered on END (with at_exit => 1) but
+ # can be invoked manually.
sub cleanup {
+ my %h = @_;
+ my $at_exit = delete $h{at_exit};
+ $at_exit = 0 if not defined $at_exit;
+ { my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
+
if (!$KEEP_ALL) {
# Files
my @files = (exists $files_to_unlink{$$} ?
@@ -748,7 +754,7 @@ sub _can_do_level {
foreach my $file (@files) {
# close the filehandle without checking its state
# in order to make real sure that this is closed
- # if its already closed then I dont care about the answer
+ # if its already closed then I don't care about the answer
# probably a better way to do this
close($file->[0]); # file handle is [0]
@@ -760,17 +766,37 @@ sub _can_do_level {
# Dirs
my @dirs = (exists $dirs_to_unlink{$$} ?
@{ $dirs_to_unlink{$$} } : () );
+ my ($cwd, $cwd_to_remove);
foreach my $dir (@dirs) {
if (-d $dir) {
# Some versions of rmtree will abort if you attempt to remove
- # the directory you are sitting in. We protect that and turn it
- # into a warning. We do this because this occurs during
- # cleanup and so can not be caught by the user.
+ # the directory you are sitting in. For automatic cleanup
+ # at program exit, we avoid this by chdir()ing out of the way
+ # first. If not at program exit, it's best not to mess with the
+ # current directory, so just let it fail with a warning.
+ if ($at_exit) {
+ $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
+ my $abs = Cwd::abs_path($dir);
+ if ($abs eq $cwd) {
+ $cwd_to_remove = $dir;
+ next;
+ }
+ }
eval { rmtree($dir, $DEBUG, 0); };
warn $@ if ($@ && $^W);
}
}
+ if (defined $cwd_to_remove) {
+ # We do need to clean up the current directory, and everything
+ # else is done, so get out of there and remove it.
+ chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
+ my $updir = File::Spec->updir;
+ chdir $updir or die "cannot chdir to $updir: $!";
+ eval { rmtree($cwd_to_remove, $DEBUG, 0); };
+ warn $@ if ($@ && $^W);
+ }
+
# clear the arrays
@{ $files_to_unlink{$$} } = ()
if exists $files_to_unlink{$$};
@@ -795,6 +821,12 @@ sub _can_do_level {
warn "Setting up deferred removal of $fname\n"
if $DEBUG;
+ # make sure we save the absolute path for later cleanup
+ # OK to untaint because we only ever use this internally
+ # as a file path, never interpolating into the shell
+ $fname = Cwd::abs_path($fname);
+ ($fname) = $fname =~ /^(.*)$/;
+
# If we have a directory, check that it is a directory
if ($isdir) {
@@ -831,30 +863,40 @@ sub _can_do_level {
}
-#line 1007
+# normalize argument keys to upper case and do consistent handling
+# of leading template vs TEMPLATE
+sub _parse_args {
+ my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
+ my %args = @_;
+ %args = map { uc($_), $args{$_} } keys %args;
+
+ # template (store it in an array so that it will
+ # disappear from the arg list of tempfile)
+ my @template = (
+ exists $args{TEMPLATE} ? $args{TEMPLATE} :
+ $leading_template ? $leading_template : ()
+ );
+ delete $args{TEMPLATE};
+
+ return( \@template, \%args );
+}
+
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
- # read arguments and convert keys to upper case
- my %args = @_;
- %args = map { uc($_), $args{$_} } keys %args;
+ my ($maybe_template, $args) = _parse_args(@_);
# see if they are unlinking (defaulting to yes)
- my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 );
- delete $args{UNLINK};
-
- # template (store it in an array so that it will
- # disappear from the arg list of tempfile)
- my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () );
- delete $args{TEMPLATE};
+ my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
+ delete $args->{UNLINK};
# Protect OPEN
- delete $args{OPEN};
+ delete $args->{OPEN};
# Open the file and retain file handle and file name
- my ($fh, $path) = tempfile( @template, %args );
+ my ($fh, $path) = tempfile( @$maybe_template, %$args );
print "Tmp: $fh - $path\n" if $DEBUG;
@@ -865,7 +907,7 @@ sub new {
$FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
# Store unlink information in hash slot (plus other constructor info)
- %{*$fh} = %args;
+ %{*$fh} = %$args;
# create the object
bless $fh, $class;
@@ -876,32 +918,30 @@ sub new {
return $fh;
}
-#line 1065
sub newdir {
my $self = shift;
- # need to handle args as in tempdir because we have to force CLEANUP
- # default without passing CLEANUP to tempdir
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
- my %options = @_;
- my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 );
+ my ($maybe_template, $args) = _parse_args(@_);
- delete $options{CLEANUP};
+ # handle CLEANUP without passing CLEANUP to tempdir
+ my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
+ delete $args->{CLEANUP};
+
+ my $tempdir = tempdir( @$maybe_template, %$args);
+
+ # get a safe absolute path for cleanup, just like
+ # happens in _deferred_unlink
+ my $real_dir = Cwd::abs_path( $tempdir );
+ ($real_dir) = $real_dir =~ /^(.*)$/;
- my $tempdir;
- if (defined $template) {
- $tempdir = tempdir( $template, %options );
- } else {
- $tempdir = tempdir( %options );
- }
return bless { DIRNAME => $tempdir,
+ REALNAME => $real_dir,
CLEANUP => $cleanup,
LAUNCHPID => $$,
}, "File::Temp::Dir";
}
-#line 1100
sub filename {
my $self = shift;
@@ -913,7 +953,13 @@ sub STRINGIFY {
return $self->filename;
}
-#line 1130
+# For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
+# refaddr() demands one parameter only, whereas overload.pm calls with three
+# even for unary operations like '0+'.
+sub NUMIFY {
+ return refaddr($_[0]);
+}
+
sub unlink_on_destroy {
my $self = shift;
@@ -923,7 +969,6 @@ sub unlink_on_destroy {
return ${*$self}{UNLINK};
}
-#line 1159
sub DESTROY {
local($., $@, $!, $^E, $?);
@@ -957,10 +1002,11 @@ sub DESTROY {
}
}
-#line 1293
sub tempfile {
-
+ if ( @_ && $_[0] eq 'File::Temp' ) {
+ croak "'tempfile' can't be called as a method";
+ }
# Can not check for argument count since we can have any
# number of args
@@ -975,10 +1021,11 @@ sub tempfile {
);
# Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
+ my ($maybe_template, $args) = _parse_args(@_);
+ my $template = @$maybe_template ? $maybe_template->[0] : undef;
# Read the options and merge with defaults
- %options = (%options, @_) if @_;
+ %options = (%options, %$args);
# First decision is whether or not to open the file
if (! $options{"OPEN"}) {
@@ -1045,7 +1092,7 @@ sub tempfile {
# Create the file
my ($fh, $path, $errstr);
- croak "Error in tempfile() using $template: $errstr"
+ croak "Error in tempfile() using template $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
@@ -1085,11 +1132,13 @@ sub tempfile {
}
-#line 1482
# '
sub tempdir {
+ if ( @_ && $_[0] eq 'File::Temp' ) {
+ croak "'tempdir' can't be called as a method";
+ }
# Can not check for argument count since we can have any
# number of args
@@ -1102,10 +1151,11 @@ sub tempdir {
);
# Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
+ my ($maybe_template, $args) = _parse_args(@_);
+ my $template = @$maybe_template ? $maybe_template->[0] : undef;
# Read the options and merge with defaults
- %options = (%options, @_) if @_;
+ %options = (%options, %$args);
# Modify or generate the template
@@ -1183,7 +1233,6 @@ sub tempdir {
}
-#line 1604
@@ -1212,7 +1261,6 @@ sub mkstemp {
}
-#line 1647
sub mkstemps {
@@ -1242,7 +1290,6 @@ sub mkstemps {
}
-#line 1690
#' # for emacs
@@ -1274,7 +1321,6 @@ sub mkdtemp {
}
-#line 1733
sub mktemp {
@@ -1295,7 +1341,6 @@ sub mktemp {
return $tmpname;
}
-#line 1795
sub tmpnam {
@@ -1316,7 +1361,6 @@ sub tmpnam {
}
-#line 1831
sub tmpfile {
@@ -1332,7 +1376,6 @@ sub tmpfile {
}
-#line 1876
sub tempnam {
@@ -1350,7 +1393,6 @@ sub tempnam {
}
-#line 1948
sub unlink0 {
@@ -1381,18 +1423,16 @@ sub unlink0 {
# Make sure that the link count is zero
# - Cygwin provides deferred unlinking, however,
# on Win9x the link count remains 1
- # On NFS the link count may still be 1 but we cant know that
- # we are on NFS
- return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
+ # On NFS the link count may still be 1 but we can't know that
+ # we are on NFS. Since we can't be sure, we'll defer it
- } else {
- _deferred_unlink($fh, $path, 0);
- return 1;
+ return 1 if $fh[3] == 0 || $^O eq 'cygwin';
}
-
+ # fall-through if we can't unlink now
+ _deferred_unlink($fh, $path, 0);
+ return 1;
}
-#line 2013
sub cmpstat {
@@ -1465,7 +1505,6 @@ sub cmpstat {
return 1;
}
-#line 2106
sub unlink1 {
croak 'Usage: unlink1(filehandle, filename)'
@@ -1489,7 +1528,6 @@ sub unlink1 {
return unlink($path);
}
-#line 2221
{
# protect from using the variable itself
@@ -1501,7 +1539,7 @@ sub unlink1 {
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
} else {
- # Dont allow this on perl 5.005 or earlier
+ # Don't allow this on perl 5.005 or earlier
if ($] < 5.006 && $level != STANDARD) {
# Cant do MEDIUM or HIGH checks
croak "Currently requires perl 5.006 or newer to do the safe checks";
@@ -1515,7 +1553,6 @@ sub unlink1 {
}
}
-#line 2266
{
my $TopSystemUID = 10;
@@ -1532,13 +1569,14 @@ sub unlink1 {
}
}
-#line 2401
package File::Temp::Dir;
use File::Path qw/ rmtree /;
use strict;
-use overload '""' => "STRINGIFY", fallback => 1;
+use overload '""' => "STRINGIFY",
+ '0+' => \&File::Temp::NUMIFY,
+ fallback => 1;
# private class specifically to support tempdir objects
# created by File::Temp->newdir
@@ -1571,16 +1609,19 @@ sub DESTROY {
local($., $@, $!, $^E, $?);
if ($self->unlink_on_destroy &&
$$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
- if (-d $self->{DIRNAME}) {
+ if (-d $self->{REALNAME}) {
# Some versions of rmtree will abort if you attempt to remove
# the directory you are sitting in. We protect that and turn it
# into a warning. We do this because this occurs during object
# destruction and so can not be caught by the user.
- eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); };
+ eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
warn $@ if ($@ && $^W);
}
}
}
-
1;
+
+__END__
+
+#line 2594
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
}
# Suspend handler for "redefined" warnings
@@ -3,13 +3,12 @@ package Module::Install::Can;
use strict;
use Config ();
-use File::Spec ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -29,7 +28,7 @@ sub can_use {
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
-# check if we can run some command
+# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
@@ -38,14 +37,88 @@ sub can_run {
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
- my $abs = File::Spec->catfile($dir, $_[1]);
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
-# can we locate a (the) C compiler
+# Can our C compiler environment build XS files
+sub can_xs {
+ my $self = shift;
+
+ # Ensure we have the CBuilder module
+ $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
+
+ # Do we have the configure_requires checker?
+ local $@;
+ eval "require ExtUtils::CBuilder;";
+ if ( $@ ) {
+ # They don't obey configure_requires, so it is
+ # someone old and delicate. Try to avoid hurting
+ # them by falling back to an older simpler test.
+ return $self->can_cc();
+ }
+
+ # Do we have a working C compiler
+ my $builder = ExtUtils::CBuilder->new(
+ quiet => 1,
+ );
+ unless ( $builder->have_compiler ) {
+ # No working C compiler
+ return 0;
+ }
+
+ # Write a C file representative of what XS becomes
+ require File::Temp;
+ my ( $FH, $tmpfile ) = File::Temp::tempfile(
+ "compilexs-XXXXX",
+ SUFFIX => '.c',
+ );
+ binmode $FH;
+ print $FH <<'END_C';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+ return 0;
+}
+
+int boot_sanexs() {
+ return 1;
+}
+
+END_C
+ close $FH;
+
+ # Can the C compiler access the same headers XS does
+ my @libs = ();
+ my $object = undef;
+ eval {
+ local $^W = 0;
+ $object = $builder->compile(
+ source => $tmpfile,
+ );
+ @libs = $builder->link(
+ objects => $object,
+ module_name => 'sanexs',
+ );
+ };
+ my $result = $@ ? 0 : 1;
+
+ # Clean up all the build files
+ foreach ( $tmpfile, $object, @libs ) {
+ next unless defined $_;
+ 1 while unlink;
+ }
+
+ return $result;
+}
+
+# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
@@ -78,4 +151,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 156
+#line 236
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -133,7 +133,7 @@ sub makemaker_args {
return $args;
}
-# For mm args that take multiple space-seperated args,
+# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
@@ -215,18 +215,22 @@ sub write {
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
- $self->build_requires( 'ExtUtils::MakeMaker' => $v );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
@@ -241,7 +245,6 @@ in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
- $DB::single = 1;
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
@@ -412,4 +415,4 @@ sub postamble {
__END__
-#line 541
+#line 544
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -151,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
}
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
@@ -170,7 +176,7 @@ sub perl_version {
# Normalize the version
$version = $self->_perl_version($version);
- # We don't support the reall old versions
+ # We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
@@ -341,7 +347,7 @@ sub name_from {
^ \s*
package \s*
([\w:]+)
- \s* ;
+ [\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
@@ -515,6 +521,7 @@ sub __extract_license {
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
@@ -550,9 +557,9 @@ sub license_from {
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
- \Qhttp://rt.cpan.org/\E[^>]+|
- \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
- \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@@ -581,7 +588,7 @@ sub bugtracker_from {
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
@@ -698,7 +705,7 @@ sub _write_mymeta_data {
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
- # Overwrite the non-configure dependency hashs
+ # Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
@@ -7,29 +7,119 @@ use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.12';
+$VERSION = '0.22';
sub readme_from {
my $self = shift;
return unless $self->is_admin;
- my $file = shift || $self->_all_from
+ # Input file
+ my $in_file = shift || $self->_all_from
or die "Can't determine file to make readme_from";
- my $clean = shift;
- print "Writing README from $file\n";
+ # Get optional arguments
+ my ($clean, $format, $out_file, $options);
+ my $args = shift;
+ if ( ref $args ) {
+ # Arguments are in a hashref
+ if ( ref($args) ne 'HASH' ) {
+ die "Expected a hashref but got a ".ref($args)."\n";
+ } else {
+ $clean = $args->{'clean'};
+ $format = $args->{'format'};
+ $out_file = $args->{'output_file'};
+ $options = $args->{'options'};
+ }
+ } else {
+ # Arguments are in a list
+ $clean = $args;
+ $format = shift;
+ $out_file = shift;
+ $options = \@_;
+ }
+
+ # Default values;
+ $clean ||= 0;
+ $format ||= 'txt';
+
+ # Generate README
+ print "readme_from $in_file to $format\n";
+ if ($format =~ m/te?xt/) {
+ $out_file = $self->_readme_txt($in_file, $out_file, $options);
+ } elsif ($format =~ m/html?/) {
+ $out_file = $self->_readme_htm($in_file, $out_file, $options);
+ } elsif ($format eq 'man') {
+ $out_file = $self->_readme_man($in_file, $out_file, $options);
+ } elsif ($format eq 'pdf') {
+ $out_file = $self->_readme_pdf($in_file, $out_file, $options);
+ }
- require Pod::Text;
- my $parser = Pod::Text->new();
- open README, '> README' or die "$!\n";
- $parser->output_fh( *README );
- $parser->parse_file( $file );
if ($clean) {
- $self->clean_files('README');
+ $self->clean_files($out_file);
}
+
return 1;
}
+
+sub _readme_txt {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README';
+ require Pod::Text;
+ my $parser = Pod::Text->new( @$options );
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ $parser->output_fh( *$out_fh );
+ $parser->parse_file( $in_file );
+ close $out_fh;
+ return $out_file;
+}
+
+
+sub _readme_htm {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.htm';
+ require Pod::Html;
+ Pod::Html::pod2html(
+ "--infile=$in_file",
+ "--outfile=$out_file",
+ @$options,
+ );
+ # Remove temporary files if needed
+ for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') {
+ if (-e $file) {
+ unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n";
+ }
+ }
+ return $out_file;
+}
+
+
+sub _readme_man {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.1';
+ require Pod::Man;
+ my $parser = Pod::Man->new( @$options );
+ $parser->parse_from_file($in_file, $out_file);
+ return $out_file;
+}
+
+
+sub _readme_pdf {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.pdf';
+ eval { require App::pod2pdf; }
+ or die "Could not generate $out_file because pod2pdf could not be found\n";
+ my $parser = App::pod2pdf->new( @$options );
+ $parser->parse_from_file($in_file);
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ select $out_fh;
+ $parser->output;
+ select STDOUT;
+ close $out_fh;
+ return $out_file;
+}
+
+
sub _all_from {
my $self = shift;
return unless $self->admin->{extensions};
@@ -44,5 +134,5 @@ sub _all_from {
__END__
-#line 112
+#line 254
@@ -7,7 +7,7 @@ use Module::Install::Base;
use vars qw($VERSION @ISA);
BEGIN {
- $VERSION = '0.11';
+ $VERSION = '0.86';
@ISA = 'Module::Install::Base';
}
@@ -23,7 +23,3 @@ sub use_test_base {
}
1;
-
-=encoding utf8
-
-#line 70
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.14';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -17,7 +17,7 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.005;
+use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
@@ -31,7 +31,7 @@ BEGIN {
# 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 = '1.00';
+ $VERSION = '1.14';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -156,10 +156,10 @@ END_DIE
sub autoload {
my $self = shift;
my $who = $self->_caller;
- my $cwd = Cwd::cwd();
+ my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
+ my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
@@ -239,7 +239,7 @@ sub new {
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
@@ -338,7 +338,7 @@ sub find_extensions {
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
- foreach ( split //, $content ) {
+ foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
@@ -378,6 +378,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
@@ -386,6 +387,7 @@ END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
@@ -416,6 +418,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
@@ -425,6 +428,7 @@ END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
@@ -434,7 +438,7 @@ END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
-sub _version ($) {
+sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
@@ -450,12 +454,12 @@ sub _version ($) {
return $l + 0;
}
-sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+sub _cmp {
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
+sub _CLASS {
(
defined $_[0]
and
@@ -467,4 +471,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2010 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
@@ -1,17 +1,16 @@
#line 1
+use strict; use warnings;
package Spiffy;
-use strict;
-use 5.006001;
-use warnings;
+our $VERSION = '0.46';
+
use Carp;
require Exporter;
-our $VERSION = '0.30';
our @EXPORT = ();
our @EXPORT_BASE = qw(field const stub super);
our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
-my $stack_frame = 0;
+my $stack_frame = 0;
my $dump = 'yaml';
my $bases_map = {};
@@ -38,7 +37,7 @@ sub new {
my $method = shift;
$self->$method(shift);
}
- return $self;
+ return $self;
}
my $filtered_files = {};
@@ -46,7 +45,7 @@ my $filter_dump = 0;
my $filter_save = 0;
our $filter_result = '';
sub import {
- no strict 'refs';
+ no strict 'refs';
no warnings;
my $self_package = shift;
@@ -54,12 +53,12 @@ sub import {
# subclass's boolean_arguments and paired_arguments can conflict, causing
# difficult debugging. Consider using something truly local.
my ($args, @export_list) = do {
- local *boolean_arguments = sub {
+ local *boolean_arguments = sub {
qw(
- -base -Base -mixin -selfless
- -XXX -dumper -yaml
+ -base -Base -mixin -selfless
+ -XXX -dumper -yaml
-filter_dump -filter_save
- )
+ )
};
local *paired_arguments = sub { qw(-package) };
$self_package->parse_arguments(@_);
@@ -79,8 +78,8 @@ sub import {
unless grep /^XXX$/, @EXPORT_BASE;
}
- spiffy_filter()
- if ($args->{-selfless} or $args->{-Base}) and
+ spiffy_filter()
+ if ($args->{-selfless} or $args->{-Base}) and
not $filtered_files->{(caller($stack_frame))[1]}++;
my $caller_package = $args->{-package} || caller($stack_frame);
@@ -91,7 +90,7 @@ sub import {
next unless $class->isa('Spiffy');
my @export = grep {
not defined &{"$caller_package\::$_"};
- } ( @{"$class\::EXPORT"},
+ } ( @{"$class\::EXPORT"},
($args->{-Base} or $args->{-base})
? @{"$class\::EXPORT_BASE"} : (),
);
@@ -99,7 +98,7 @@ sub import {
not defined &{"$caller_package\::$_"};
} @{"$class\::EXPORT_OK"};
- # Avoid calling the expensive Exporter::export
+ # Avoid calling the expensive Exporter::export
# if there is nothing to do (optimization)
my %exportable = map { ($_, 1) } @export, @export_ok;
next unless keys %exportable;
@@ -163,7 +162,7 @@ sub base {
sub all_my_bases {
my $class = shift;
- return $bases_map->{$class}
+ return $bases_map->{$class}
if defined $bases_map->{$class};
my @bases = ($class);
@@ -175,10 +174,10 @@ sub all_my_bases {
$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
}
-my %code = (
- sub_start =>
+my %code = (
+ sub_start =>
"sub {\n",
- set_default =>
+ set_default =>
" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
init =>
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
@@ -189,13 +188,13 @@ my %code = (
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
" \$_[0]->{%s};\n" .
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
- return_if_get =>
+ return_if_get =>
" return \$_[0]->{%s} unless \$#_ > 0;\n",
- set =>
+ set =>
" \$_[0]->{%s} = \$_[1];\n",
- weaken =>
+ weaken =>
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
- sub_end =>
+ sub_end =>
" return \$_[0]->{%s};\n}\n",
);
@@ -223,13 +222,14 @@ sub field {
my $code = $code{sub_start};
if ($args->{-init}) {
my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
- $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ my @count = ($fragment =~ /(%s)/g);
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2);
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
- $code .= sprintf $code{weaken}, $field, $field
+ $code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
@@ -274,10 +274,10 @@ sub stub {
$package = $args->{-package} if defined $args->{-package};
no strict 'refs';
return if defined &{"${package}::$field"};
- *{"${package}::$field"} =
- sub {
+ *{"${package}::$field"} =
+ sub {
require Carp;
- Carp::confess
+ Carp::confess
"Method $field in package $package must be subclassed";
}
}
@@ -301,7 +301,7 @@ sub parse_arguments {
push @values, $elem;
}
}
- return wantarray ? ($args, @values) : $args;
+ return wantarray ? ($args, @values) : $args;
}
sub boolean_arguments { () }
@@ -325,8 +325,8 @@ sub id {
package DB;
{
no warnings 'redefine';
- sub super_args {
- my @dummy = caller(@_ ? $_[0] : 2);
+ sub super_args {
+ my @dummy = caller(@_ ? $_[0] : 2);
return @DB::args;
}
}
@@ -397,7 +397,7 @@ sub spiffy_base_import {
my $inheritor = caller(0);
for my $base_class (@base_classes) {
next if $inheritor->isa($base_class);
- croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
+ croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
"See the documentation of Spiffy.pm for details\n "
unless $base_class->isa('Spiffy');
$stack_frame = 1; # tell import to use different caller
@@ -439,7 +439,7 @@ sub spiffy_mixin_methods {
$methods{$_}
? ($_, \ &{"$methods{$_}\::$_"})
: ($_, \ &{"$mixin_class\::$_"})
- } @_
+ } @_
? (get_roles($mixin_class, @_))
: (keys %methods);
}
@@ -450,12 +450,12 @@ sub get_roles {
while (grep /^!*:/, @roles) {
@roles = map {
s/!!//g;
- /^!:(.*)/ ? do {
- my $m = "_role_$1";
+ /^!:(.*)/ ? do {
+ my $m = "_role_$1";
map("!$_", $mixin_class->$m);
} :
/^:(.*)/ ? do {
- my $m = "_role_$1";
+ my $m = "_role_$1";
($mixin_class->$m);
} :
($_)
@@ -533,7 +533,3 @@ sub ZZZ {
}
1;
-
-__END__
-
-#line 1066
@@ -1,7 +1,4 @@
#line 1
-#. TODO:
-#.
-
#===============================================================================
# This is the default class for handling Test::Base data filtering.
#===============================================================================
@@ -339,6 +336,4 @@ sub _write_to {
or die "Couldn't close $filename: $!\n";
}
-__DATA__
-
-#line 639
+1;
@@ -1,11 +1,22 @@
#line 1
-# TODO:
-#
package Test::Base;
-use 5.006001;
-use Spiffy 0.30 -Base;
+our $VERSION = '0.88';
+
+use Spiffy -Base;
use Spiffy ':XXX';
-our $VERSION = '0.59';
+
+my $HAS_PROVIDER;
+BEGIN {
+ $HAS_PROVIDER = eval "require Test::Builder::Provider; 1";
+
+ if ($HAS_PROVIDER) {
+ Test::Builder::Provider->import('provides');
+ }
+ else {
+ *provides = sub { 1 };
+ }
+}
+
my @test_more_exports;
BEGIN {
@@ -26,9 +37,9 @@ our @EXPORT = (@test_more_exports, qw(
is no_diff
blocks next_block first_block
- delimiters spec_file spec_string
+ delimiters spec_file spec_string
filters filters_delay filter_arguments
- run run_compare run_is run_is_deeply run_like run_unlike
+ run run_compare run_is run_is_deeply run_like run_unlike
skip_all_unless_require is_deep run_is_deep
WWW XXX YYY ZZZ
tie_output no_diag_on_only
@@ -61,7 +72,7 @@ my $default_class;
my $default_object;
my $reserved_section_names = {};
-sub default_object {
+sub default_object {
$default_object ||= $default_class->new;
return $default_object;
}
@@ -69,7 +80,7 @@ sub default_object {
my $import_called = 0;
sub import() {
$import_called = 1;
- my $class = (grep /^-base$/i, @_)
+ my $class = (grep /^-base$/i, @_)
? scalar(caller)
: $_[0];
if (not defined $default_class) {
@@ -92,7 +103,7 @@ sub import() {
Test::More->import(import => \@test_more_exports, @args)
if @args;
}
-
+
_strict_warnings();
goto &Spiffy::import;
}
@@ -149,14 +160,14 @@ sub blocks() {
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
my $blocks = $self->block_list;
-
+
my $section_name = shift || '';
my @blocks = $section_name
? (grep { exists $_->{$section_name} } @$blocks)
: (@$blocks);
return scalar(@blocks) unless wantarray;
-
+
return (@blocks) if $self->_filters_delay;
for my $block (@blocks) {
@@ -227,7 +238,7 @@ sub filters() {
if (ref($_[0]) eq 'HASH') {
$self->_filters_map(shift);
}
- else {
+ else {
my $filters = $self->_filters;
push @$filters, @_;
}
@@ -244,23 +255,24 @@ sub have_text_diff {
$Algorithm::Diff::VERSION >= 1.15;
}
+provides 'is';
sub is($$;$) {
(my ($self), @_) = find_my_self(@_);
my ($actual, $expected, $name) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER;
if ($ENV{TEST_SHOW_NO_DIFFS} or
not defined $actual or
not defined $expected or
- $actual eq $expected or
- not($self->have_text_diff) or
+ $actual eq $expected or
+ not($self->have_text_diff) or
$expected !~ /\n./s
) {
Test::More::is($actual, $expected, $name);
}
else {
$name = '' unless defined $name;
- ok $actual eq $expected,
- $name . "\n" . Text::Diff::diff(\$expected, \$actual);
+ ok $actual eq $expected, $name;
+ diag Text::Diff::diff(\$expected, \$actual);
}
}
@@ -324,7 +336,7 @@ sub run_is() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is($block->$x, $block->$y,
+ is($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -337,7 +349,7 @@ sub run_is_deeply() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deeply($block->$x, $block->$y,
+ is_deeply($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -393,7 +405,7 @@ sub run_is_deep() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deep($block->$x, $block->$y,
+ is_deep($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -464,7 +476,7 @@ sub _make_block {
}
$description =~ s/\s*\z//;
$block->set_value(description => $description);
-
+
my $section_map = {};
my $section_order = [];
while (@parts) {
@@ -501,9 +513,9 @@ sub _spec_init {
$spec = <FILE>;
close FILE;
}
- else {
- $spec = do {
- package main;
+ else {
+ $spec = do {
+ package main;
no warnings 'once';
<DATA>;
};
@@ -536,7 +548,7 @@ sub _strict_warnings() {
sub tie_output() {
my $handle = shift;
die "No buffer to tie" unless @_;
- tie $handle, 'Test::Base::Handle', $_[0];
+ tie *$handle, 'Test::Base::Handle', $_[0];
}
sub no_diff {
@@ -619,7 +631,7 @@ sub run_filters {
join '', @value;
my $old = $_;
@value = &$function(@value);
- if (not(@value) or
+ if (not(@value) or
@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
) {
if ($value[0] && $_ eq $old) {
@@ -652,7 +664,7 @@ sub _get_filters {
$map_filters = [ $map_filters ] unless ref $map_filters;
my @append = ();
for (
- @{$self->blocks_object->_filters},
+ @{$self->blocks_object->_filters},
@$map_filters,
split(/\s+/, $string),
) {
@@ -677,8 +689,4 @@ sub _get_filters {
} keys(%Test::Base::Block::), qw( new DESTROY );
}
-__DATA__
-
-=encoding utf8
-
-#line 1376
+1;
@@ -3,12 +3,12 @@ package Test::Builder::Module;
use strict;
-use Test::Builder;
+use Test::Builder 1.00;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.98';
+our $VERSION = '1.001014';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -5,7 +5,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '0.98';
+our $VERSION = '1.001014';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -90,7 +90,21 @@ sub create {
return $self;
}
-#line 168
+
+# Copy an object, currently a shallow.
+# This does *not* bless the destination. This keeps the destructor from
+# firing when we're just storing a copy of the object to restore later.
+sub _copy {
+ my($src, $dest) = @_;
+
+ %$dest = %$src;
+ _share_keys($dest);
+
+ return;
+}
+
+
+#line 182
sub child {
my( $self, $name ) = @_;
@@ -104,15 +118,20 @@ sub child {
# Clear $TODO for the child.
my $orig_TODO = $self->find_TODO(undef, 1, undef);
- my $child = bless {}, ref $self;
- $child->reset;
+ my $class = ref $self;
+ my $child = $class->create;
# Add to our indentation
$child->_indent( $self->_indent . ' ' );
-
- $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
- if ($parent_in_todo) {
- $child->{Fail_FH} = $self->{Todo_FH};
+
+ # Make the child use the same outputs as the parent
+ for my $method (qw(output failure_output todo_output)) {
+ $child->$method( $self->$method );
+ }
+
+ # Ensure the child understands if they're inside a TODO
+ if( $parent_in_todo ) {
+ $child->failure_output( $self->todo_output );
}
# This will be reset in finalize. We do this here lest one child failure
@@ -127,11 +146,11 @@ sub child {
}
-#line 211
+#line 233
sub subtest {
my $self = shift;
- my($name, $subtests) = @_;
+ my($name, $subtests, @args) = @_;
if ('CODE' ne ref $subtests) {
$self->croak("subtest()'s second argument must be a code ref");
@@ -139,18 +158,23 @@ sub subtest {
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
- my($error, $child, %parent);
+ my $error;
+ my $child;
+ my $parent = {};
{
# child() calls reset() which sets $Level to 1, so we localize
# $Level first to limit the scope of the reset to the subtest.
local $Test::Builder::Level = $Test::Builder::Level + 1;
+ # Store the guts of $self as $parent and turn $child into $self.
$child = $self->child($name);
- %parent = %$self;
- %$self = %$child;
+ _copy($self, $parent);
+ _copy($child, $self);
my $run_the_subtests = sub {
- $subtests->();
+ # Add subtest name for clarification of starting point
+ $self->note("Subtest: $name");
+ $subtests->(@args);
$self->done_testing unless $self->_plan_handled;
1;
};
@@ -161,8 +185,8 @@ sub subtest {
}
# Restore the parent and the copied child.
- %$child = %$self;
- %$self = %parent;
+ _copy($self, $child);
+ _copy($parent, $self);
# Restore the parent's $TODO
$self->find_TODO(undef, 1, $child->{Parent_TODO});
@@ -171,10 +195,14 @@ sub subtest {
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
local $Test::Builder::Level = $Test::Builder::Level + 1;
- return $child->finalize;
+ my $finalize = $child->finalize;
+
+ $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
+
+ return $finalize;
}
-#line 281
+#line 312
sub _plan_handled {
my $self = shift;
@@ -182,7 +210,7 @@ sub _plan_handled {
}
-#line 306
+#line 337
sub finalize {
my $self = shift;
@@ -201,14 +229,16 @@ sub finalize {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $ok = 1;
$self->parent->{Child_Name} = undef;
- if ( $self->{Skip_All} ) {
- $self->parent->skip($self->{Skip_All});
- }
- elsif ( not @{ $self->{Test_Results} } ) {
- $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
- }
- else {
- $self->parent->ok( $self->is_passing, $self->name );
+ unless ($self->{Bailed_Out}) {
+ if ( $self->{Skip_All} ) {
+ $self->parent->skip($self->{Skip_All}, $self->name);
+ }
+ elsif ( not @{ $self->{Test_Results} } ) {
+ $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
+ }
+ else {
+ $self->parent->ok( $self->is_passing, $self->name );
+ }
}
$? = $self->{Child_Error};
delete $self->{Parent};
@@ -226,11 +256,11 @@ sub _indent {
return $self->{Indent};
}
-#line 359
+#line 392
sub parent { shift->{Parent} }
-#line 371
+#line 404
sub name { shift->{Name} }
@@ -246,7 +276,7 @@ FAIL
}
}
-#line 395
+#line 428
our $Level;
@@ -269,7 +299,6 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Child_Name} = undef;
$self->{Indent} ||= '';
- share( $self->{Curr_Test} );
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share( [] );
@@ -288,12 +317,26 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Start_Todo} = 0;
$self->{Opened_Testhandles} = 0;
+ $self->_share_keys;
$self->_dup_stdhandles;
return;
}
-#line 474
+
+# Shared scalar values are lost when a hash is copied, so we have
+# a separate method to restore them.
+# Shared references are retained across copies.
+sub _share_keys {
+ my $self = shift;
+
+ share( $self->{Curr_Test} );
+
+ return;
+}
+
+
+#line 520
my %plan_cmds = (
no_plan => \&no_plan,
@@ -340,7 +383,7 @@ sub _plan_tests {
return;
}
-#line 529
+#line 575
sub expected_tests {
my $self = shift;
@@ -358,7 +401,7 @@ sub expected_tests {
return $self->{Expected_Tests};
}
-#line 553
+#line 599
sub no_plan {
my($self, $arg) = @_;
@@ -371,7 +414,7 @@ sub no_plan {
return 1;
}
-#line 586
+#line 632
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -390,7 +433,7 @@ sub _output_plan {
}
-#line 638
+#line 684
sub done_testing {
my($self, $num_tests) = @_;
@@ -433,7 +476,7 @@ sub done_testing {
}
-#line 689
+#line 735
sub has_plan {
my $self = shift;
@@ -443,7 +486,7 @@ sub has_plan {
return(undef);
}
-#line 706
+#line 752
sub skip_all {
my( $self, $reason ) = @_;
@@ -457,7 +500,7 @@ sub skip_all {
exit(0);
}
-#line 731
+#line 777
sub exported_to {
my( $self, $pack ) = @_;
@@ -468,7 +511,7 @@ sub exported_to {
return $self->{Exported_To};
}
-#line 761
+#line 807
sub ok {
my( $self, $test, $name ) = @_;
@@ -625,10 +668,10 @@ sub _is_dualvar {
no warnings 'numeric';
my $numval = $val + 0;
- return $numval != 0 and $numval ne $val ? 1 : 0;
+ return ($numval != 0 and $numval ne $val ? 1 : 0);
}
-#line 939
+#line 985
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
@@ -707,7 +750,7 @@ sub _isnt_diag {
DIAGNOSTIC
}
-#line 1032
+#line 1078
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -741,30 +784,37 @@ sub isnt_num {
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 1081
+#line 1127
sub like {
- my( $self, $this, $regex, $name ) = @_;
+ my( $self, $thing, $regex, $name ) = @_;
local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '=~', $name );
+ return $self->_regex_ok( $thing, $regex, '=~', $name );
}
sub unlike {
- my( $self, $this, $regex, $name ) = @_;
+ my( $self, $thing, $regex, $name ) = @_;
local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '!~', $name );
+ return $self->_regex_ok( $thing, $regex, '!~', $name );
}
-#line 1105
+#line 1151
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+# Bad, these are not comparison operators. Should we include more?
+my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
+
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
- my $test;
+ if ($cmp_ok_bl{$type}) {
+ $self->croak("$type is not a valid comparison operator in cmp_ok()");
+ }
+
+ my ($test, $succ);
my $error;
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -774,9 +824,10 @@ sub cmp_ok {
my($pack, $file, $line) = $self->caller();
# This is so that warnings come out at the caller's level
- $test = eval qq[
+ $succ = eval qq[
#line $line "(eval in cmp_ok) $file"
-\$got $type \$expect;
+\$test = (\$got $type \$expect);
+1;
];
$error = $@;
}
@@ -790,7 +841,7 @@ sub cmp_ok {
? '_unoverload_num'
: '_unoverload_str';
- $self->diag(<<"END") if $error;
+ $self->diag(<<"END") unless $succ;
An error occurred while using $type:
------------------------------------
$error
@@ -838,28 +889,36 @@ sub _caller_context {
return $code;
}
-#line 1205
+#line 1259
sub BAIL_OUT {
my( $self, $reason ) = @_;
$self->{Bailed_Out} = 1;
+
+ if ($self->parent) {
+ $self->{Bailed_Out_Reason} = $reason;
+ $self->no_ending(1);
+ die bless {} => 'Test::Builder::Exception';
+ }
+
$self->_print("Bail out! $reason");
exit 255;
}
-#line 1218
+#line 1279
{
no warnings 'once';
*BAILOUT = \&BAIL_OUT;
}
-#line 1232
+#line 1293
sub skip {
- my( $self, $why ) = @_;
+ my( $self, $why, $name ) = @_;
$why ||= '';
+ $name = '' unless defined $name;
$self->_unoverload_str( \$why );
lock( $self->{Curr_Test} );
@@ -869,7 +928,7 @@ sub skip {
{
'ok' => 1,
actual_ok => 1,
- name => '',
+ name => $name,
type => 'skip',
reason => $why,
}
@@ -886,7 +945,7 @@ sub skip {
return 1;
}
-#line 1273
+#line 1335
sub todo_skip {
my( $self, $why ) = @_;
@@ -914,7 +973,7 @@ sub todo_skip {
return 1;
}
-#line 1353
+#line 1415
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -949,7 +1008,7 @@ sub _is_qr {
}
sub _regex_ok {
- my( $self, $this, $regex, $cmp, $name ) = @_;
+ my( $self, $thing, $regex, $cmp, $name ) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
@@ -961,14 +1020,19 @@ sub _regex_ok {
}
{
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
my $test;
my $context = $self->_caller_context;
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
- $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+ # No point in issuing an uninit warning, they'll see it in the diagnostics
+ no warnings 'uninitialized';
+
+ $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
+ }
$test = !$test if $cmp eq '!~';
@@ -977,11 +1041,11 @@ sub _regex_ok {
}
unless($ok) {
- $this = defined $this ? "'$this'" : 'undef';
+ $thing = defined $thing ? "'$thing'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
local $Level = $Level + 1;
- $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
+ $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
%s
%13s '%s'
DIAGNOSTIC
@@ -994,7 +1058,7 @@ DIAGNOSTIC
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1449
+#line 1516
sub _try {
my( $self, $code, %opts ) = @_;
@@ -1014,7 +1078,7 @@ sub _try {
return wantarray ? ( $return, $error ) : $return;
}
-#line 1478
+#line 1545
sub is_fh {
my $self = shift;
@@ -1028,7 +1092,7 @@ sub is_fh {
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1521
+#line 1588
sub level {
my( $self, $level ) = @_;
@@ -1039,7 +1103,7 @@ sub level {
return $Level;
}
-#line 1553
+#line 1620
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -1050,7 +1114,7 @@ sub use_numbers {
return $self->{Use_Nums};
}
-#line 1586
+#line 1653
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -1068,7 +1132,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1639
+#line 1706
sub diag {
my $self = shift;
@@ -1076,7 +1140,7 @@ sub diag {
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1654
+#line 1721
sub note {
my $self = shift;
@@ -1113,7 +1177,7 @@ sub _print_comment {
return 0;
}
-#line 1704
+#line 1771
sub explain {
my $self = shift;
@@ -1132,7 +1196,7 @@ sub explain {
} @_;
}
-#line 1733
+#line 1800
sub _print {
my $self = shift;
@@ -1161,7 +1225,7 @@ sub _print_to_fh {
return print $fh $indent, $msg;
}
-#line 1793
+#line 1860
sub output {
my( $self, $fh ) = @_;
@@ -1288,7 +1352,7 @@ sub _apply_layers {
}
-#line 1926
+#line 1993
sub reset_outputs {
my $self = shift;
@@ -1300,7 +1364,7 @@ sub reset_outputs {
return;
}
-#line 1952
+#line 2019
sub _message_at_caller {
my $self = shift;
@@ -1321,7 +1385,7 @@ sub croak {
}
-#line 1992
+#line 2059
sub current_test {
my( $self, $num ) = @_;
@@ -1354,7 +1418,7 @@ sub current_test {
return $self->{Curr_Test};
}
-#line 2040
+#line 2107
sub is_passing {
my $self = shift;
@@ -1367,7 +1431,7 @@ sub is_passing {
}
-#line 2062
+#line 2129
sub summary {
my($self) = shift;
@@ -1375,14 +1439,14 @@ sub summary {
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 2117
+#line 2184
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 2146
+#line 2213
sub todo {
my( $self, $pack ) = @_;
@@ -1396,7 +1460,7 @@ sub todo {
return '';
}
-#line 2173
+#line 2240
sub find_TODO {
my( $self, $pack, $set, $new_value ) = @_;
@@ -1410,7 +1474,7 @@ sub find_TODO {
return $old_value;
}
-#line 2193
+#line 2260
sub in_todo {
my $self = shift;
@@ -1419,7 +1483,7 @@ sub in_todo {
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 2243
+#line 2310
sub todo_start {
my $self = shift;
@@ -1434,7 +1498,7 @@ sub todo_start {
return;
}
-#line 2265
+#line 2332
sub todo_end {
my $self = shift;
@@ -1455,7 +1519,7 @@ sub todo_end {
return;
}
-#line 2298
+#line 2365
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1470,9 +1534,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return wantarray ? @caller : $caller[0];
}
-#line 2315
+#line 2382
-#line 2329
+#line 2396
#'#
sub _sanity_check {
@@ -1485,7 +1549,7 @@ sub _sanity_check {
return;
}
-#line 2350
+#line 2417
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1500,7 +1564,7 @@ WHOA
return;
}
-#line 2374
+#line 2441
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1508,7 +1572,7 @@ sub _my_exit {
return 1;
}
-#line 2386
+#line 2453
sub _ending {
my $self = shift;
@@ -1527,6 +1591,26 @@ sub _ending {
if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
$self->is_passing(0);
$self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+
+ # But if the tests ran, handle exit code.
+ my $test_results = $self->{Test_Results};
+ if(@$test_results) {
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+ if ($num_failed > 0) {
+
+ my $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ _my_exit($exit_code) && return;
+ }
+ }
+ _my_exit(254) && return;
}
# Exit if plan() was never called. This is so "require Test::Simple"
@@ -1627,7 +1711,7 @@ END {
$Test->_ending if defined $Test;
}
-#line 2574
+#line 2669
1;
@@ -10,7 +10,7 @@ use warnings;
# We use a lot of subroutine prototypes
## no critic (Subroutines::ProhibitSubroutinePrototypes)
-# Can't use Carp because it might cause use_ok() to accidentally succeed
+# Can't use Carp because it might cause C<use_ok()> to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
@@ -18,10 +18,10 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.98';
+our $VERSION = '1.001014';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-use Test::Builder::Module;
+use Test::Builder::Module 0.99;
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
@@ -38,7 +38,7 @@ our @EXPORT = qw(ok use_ok require_ok
BAIL_OUT
);
-#line 164
+#line 163
sub plan {
my $tb = Test::More->builder;
@@ -72,14 +72,14 @@ sub import_extra {
return;
}
-#line 217
+#line 216
sub done_testing {
my $tb = Test::More->builder;
$tb->done_testing(@_);
}
-#line 289
+#line 288
sub ok ($;$) {
my( $test, $name ) = @_;
@@ -88,7 +88,7 @@ sub ok ($;$) {
return $tb->ok( $test, $name );
}
-#line 372
+#line 371
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -103,6 +103,7 @@ sub isnt ($$;$) {
}
*isn't = \&isnt;
+# ' to unconfuse syntax higlighters
#line 416
@@ -120,7 +121,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 476
+#line 477
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -128,7 +129,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 511
+#line 512
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -162,67 +163,89 @@ sub can_ok ($@) {
return $ok;
}
-#line 577
+#line 578
sub isa_ok ($$;$) {
- my( $object, $class, $obj_name ) = @_;
+ my( $thing, $class, $thing_name ) = @_;
my $tb = Test::More->builder;
- my $diag;
+ my $whatami;
+ if( !defined $thing ) {
+ $whatami = 'undef';
+ }
+ elsif( ref $thing ) {
+ $whatami = 'reference';
- if( !defined $object ) {
- $obj_name = 'The thing' unless defined $obj_name;
- $diag = "$obj_name isn't defined";
+ local($@,$!);
+ require Scalar::Util;
+ if( Scalar::Util::blessed($thing) ) {
+ $whatami = 'object';
+ }
}
else {
- my $whatami = ref $object ? 'object' : 'class';
- # We can't use UNIVERSAL::isa because we want to honor isa() overrides
- my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
- if($error) {
- if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
- # Its an unblessed reference
- $obj_name = 'The reference' unless defined $obj_name;
- if( !UNIVERSAL::isa( $object, $class ) ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
- elsif( $error =~ /Can't call method "isa" without a package/ ) {
- # It's something that can't even be a class
- $obj_name = 'The thing' unless defined $obj_name;
- $diag = "$obj_name isn't a class or reference";
- }
- else {
- die <<WHOA;
+ $whatami = 'class';
+ }
+
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );
+
+ if($error) {
+ die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/;
WHOA! I tried to call ->isa on your $whatami and got some weird error.
Here's the error.
$error
WHOA
- }
- }
- else {
- $obj_name = "The $whatami" unless defined $obj_name;
- if( !$rslt ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
}
- my $name = "$obj_name isa $class";
- my $ok;
- if($diag) {
- $ok = $tb->ok( 0, $name );
- $tb->diag(" $diag\n");
+ # Special case for isa_ok( [], "ARRAY" ) and like
+ if( $whatami eq 'reference' ) {
+ $rslt = UNIVERSAL::isa($thing, $class);
+ }
+
+ my($diag, $name);
+ if( defined $thing_name ) {
+ $name = "'$thing_name' isa '$class'";
+ $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
+ }
+ elsif( $whatami eq 'object' ) {
+ my $my_class = ref $thing;
+ $thing_name = qq[An object of class '$my_class'];
+ $name = "$thing_name isa '$class'";
+ $diag = "The object of class '$my_class' isn't a '$class'";
+ }
+ elsif( $whatami eq 'reference' ) {
+ my $type = ref $thing;
+ $thing_name = qq[A reference of type '$type'];
+ $name = "$thing_name isa '$class'";
+ $diag = "The reference of type '$type' isn't a '$class'";
+ }
+ elsif( $whatami eq 'undef' ) {
+ $thing_name = 'undef';
+ $name = "$thing_name isa '$class'";
+ $diag = "$thing_name isn't defined";
+ }
+ elsif( $whatami eq 'class' ) {
+ $thing_name = qq[The class (or class-like) '$thing'];
+ $name = "$thing_name isa '$class'";
+ $diag = "$thing_name isn't a '$class'";
}
else {
+ die;
+ }
+
+ my $ok;
+ if($rslt) {
$ok = $tb->ok( 1, $name );
}
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
return $ok;
}
-#line 656
+#line 679
sub new_ok {
my $tb = Test::More->builder;
@@ -231,7 +254,6 @@ sub new_ok {
my( $class, $args, $object_name ) = @_;
$args ||= [];
- $object_name = "The object" unless defined $object_name;
my $obj;
my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
@@ -240,14 +262,15 @@ sub new_ok {
isa_ok $obj, $class, $object_name;
}
else {
- $tb->ok( 0, "new() died" );
+ $class = 'undef' if !defined $class;
+ $tb->ok( 0, "$class->new() died" );
$tb->diag(" Error was: $error");
}
return $obj;
}
-#line 741
+#line 765
sub subtest {
my ($name, $subtests) = @_;
@@ -256,7 +279,7 @@ sub subtest {
return $tb->subtest(@_);
}
-#line 765
+#line 789
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +293,52 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 833
+#line 842
+
+sub require_ok ($) {
+ my($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to determine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my $code = <<REQUIRE;
+package $pack;
+require $module;
+1;
+REQUIRE
+
+ my( $eval_result, $eval_error ) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+
+#line 936
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -278,6 +346,7 @@ sub use_ok ($;@) {
my $tb = Test::More->builder;
my( $pack, $filename, $line ) = caller;
+ $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
my $code;
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
@@ -285,6 +354,8 @@ sub use_ok ($;@) {
# for it to work with non-Exporter based modules.
$code = <<USE;
package $pack;
+
+#line $line $filename
use $module $imports[0];
1;
USE
@@ -292,6 +363,8 @@ USE
else {
$code = <<USE;
package $pack;
+
+#line $line $filename
use $module \@{\$args[0]};
1;
USE
@@ -332,51 +405,8 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 902
-
-sub require_ok ($) {
- my($module) = shift;
- my $tb = Test::More->builder;
-
- my $pack = caller;
-
- # Try to determine if we've been given a module name or file.
- # Module names must be barewords, files not.
- $module = qq['$module'] unless _is_module_name($module);
-
- my $code = <<REQUIRE;
-package $pack;
-require $module;
-1;
-REQUIRE
-
- my( $eval_result, $eval_error ) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
-
- unless($ok) {
- chomp $eval_error;
- $tb->diag(<<DIAGNOSTIC);
- Tried to require '$module'.
- Error: $eval_error
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub _is_module_name {
- my $module = shift;
-
- # Module names start with a letter.
- # End with an alphanumeric.
- # The rest is an alphanumeric or ::
- $module =~ s/\b::\b//g;
-
- return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
-}
-#line 979
+#line 1037
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -483,7 +513,7 @@ sub _type {
return '';
}
-#line 1139
+#line 1197
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +523,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1165
+#line 1223
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1231
+#line 1289
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +557,7 @@ sub skip {
last SKIP;
}
-#line 1315
+#line 1373
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +578,7 @@ sub todo_skip {
last TODO;
}
-#line 1370
+#line 1428
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +587,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1409
+#line 1467
#'#
sub eq_array {
@@ -697,7 +727,7 @@ WHOA
}
}
-#line 1556
+#line 1614
sub eq_hash {
local @Data_Stack = ();
@@ -732,7 +762,7 @@ sub _eq_hash {
return $ok;
}
-#line 1615
+#line 1673
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -757,6 +787,6 @@ sub eq_set {
);
}
-#line 1817
+#line 1946
1;
@@ -0,0 +1,225 @@
+#line 1
+#line 241
+
+
+package Test::Warn;
+
+use 5.006;
+use strict;
+use warnings;
+
+#use Array::Compare;
+use Sub::Uplevel 0.12;
+
+our $VERSION = '0.30';
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ @EXPORT
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+ warning_is warnings_are
+ warning_like warnings_like
+ warnings_exist
+);
+
+use Test::Builder;
+my $Tester = Test::Builder->new;
+
+{
+no warnings 'once';
+*warning_is = *warnings_are;
+*warning_like = *warnings_like;
+}
+
+sub warnings_are (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ push @got_warning, _canonical_got_warning($called_from, shift());
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_is( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+
+sub warnings_like (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ push @got_warning, _canonical_got_warning($called_from, shift());
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_like( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+sub warnings_exist (&$;$) {
+ my $block = shift;
+ my @exp_warning = map {_canonical_exp_warning($_)}
+ _to_array_if_necessary( shift() || [] );
+ my $testname = shift;
+ my @got_warning = ();
+ local $SIG{__WARN__} = sub {
+ my ($called_from) = caller(0); # to find out Carping methods
+ my $wrn_text=shift;
+ my $wrn_rec=_canonical_got_warning($called_from, $wrn_text);
+ foreach my $wrn (@exp_warning) {
+ if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) {
+ push @got_warning, $wrn_rec;
+ return;
+ }
+ }
+ warn $wrn_text;
+ };
+ uplevel 1,$block;
+ my $ok = _cmp_like( \@got_warning, \@exp_warning );
+ $Tester->ok( $ok, $testname );
+ $ok or _diag_found_warning(@got_warning),
+ _diag_exp_warning(@exp_warning);
+ return $ok;
+}
+
+
+sub _to_array_if_necessary {
+ return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
+}
+
+sub _canonical_got_warning {
+ my ($called_from, $msg) = @_;
+ my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
+ my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
+ return {$warn_kind => $warning_stack[0]}; # return only the real message
+}
+
+sub _canonical_exp_warning {
+ my ($exp) = @_;
+ if (ref($exp) eq 'HASH') { # could be {carped => ...}
+ my $to_carp = $exp->{carped} or return; # undefined message are ignored
+ return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] }
+ ? map({ {carped => $_} } grep {defined $_} @$to_carp)
+ : +{carped => $to_carp};
+ }
+ return {warn => $exp};
+}
+
+sub _cmp_got_to_exp_warning {
+ my ($got_kind, $got_msg) = %{ shift() };
+ my ($exp_kind, $exp_msg) = %{ shift() };
+ return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
+ my $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/;
+ return $cmp;
+}
+
+sub _cmp_got_to_exp_warning_like {
+ my ($got_kind, $got_msg) = %{ shift() };
+ my ($exp_kind, $exp_msg) = %{ shift() };
+ return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
+ if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//'
+ my $cmp = $got_msg =~ /$re/;
+ return $cmp;
+ } else {
+ return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
+ }
+}
+
+
+sub _cmp_is {
+ my @got = @{ shift() };
+ my @exp = @{ shift() };
+ scalar @got == scalar @exp or return 0;
+ my $cmp = 1;
+ $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
+ return $cmp;
+}
+
+sub _cmp_like {
+ my @got = @{ shift() };
+ my @exp = @{ shift() };
+ scalar @got == scalar @exp or return 0;
+ my $cmp = 1;
+ $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
+ return $cmp;
+}
+
+sub _diag_found_warning {
+ foreach (@_) {
+ if (ref($_) eq 'HASH') {
+ ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
+ : $Tester->diag("found warning: ${$_}{warn}");
+ } else {
+ $Tester->diag( "found warning: $_" );
+ }
+ }
+ $Tester->diag( "didn't find a warning" ) unless @_;
+}
+
+sub _diag_exp_warning {
+ foreach (@_) {
+ if (ref($_) eq 'HASH') {
+ ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
+ : $Tester->diag("expected to find warning: ${$_}{warn}");
+ } else {
+ $Tester->diag( "expected to find warning: $_" );
+ }
+ }
+ $Tester->diag( "didn't expect to find a warning" ) unless @_;
+}
+
+package Test::Warn::Categorization;
+
+use Carp;
+
+my $bits = \%warnings::Bits;
+my @warnings = sort grep {
+ my $warn_bits = $bits->{$_};
+ #!grep { $_ ne $warn_bits && ($_ & $warn_bits) eq $_ } values %$bits;
+} keys %$bits;
+
+my %warnings_in_category = (
+ 'utf8' => ['Wide character in \w+\b',],
+);
+
+sub _warning_category_regexp {
+ my $category = shift;
+ my $category_bits = $bits->{$category} or return;
+ my @category_warnings
+ = grep { ($bits->{$_} & $category_bits) eq $bits->{$_} } @warnings;
+
+ my @list =
+ map { exists $warnings_in_category{$_}? (@{ $warnings_in_category{$_}}) : ($_) }
+ @category_warnings;
+ my $re = join "|", @list;
+ return qr/$re/;
+}
+
+sub warning_like_category {
+ my ($warning, $category) = @_;
+ my $re = _warning_category_regexp($category) or
+ carp("Unknown warning category '$category'"),return;
+ my $ok = $warning =~ /$re/;
+ return $ok;
+}
+
+1;
@@ -7,8 +7,9 @@ use Digest::MD5 qw(md5);
use Fcntl qw(:flock);
use IO::Handle;
use POSIX qw(:fcntl_h);
+use File::Path;
-our $VERSION = '0.05';
+our $VERSION = '0.07';
use Class::Accessor::Lite (
ro => [ qw(base_dir worker_id) ],
@@ -21,7 +22,7 @@ sub new {
unless $args{base_dir};
# create base_dir if necessary
if (! -e $args{base_dir}) {
- mkdir $args{base_dir}
+ mkpath $args{base_dir}
or die "failed to create directory:$args{base_dir}:$!";
}
# build object
@@ -40,8 +41,8 @@ sub DESTROY {
# if file is open, close and unlink
if ($self->{fh}) {
close $self->{fh};
- my $fn = $self->_build_filename();
- unlink $fn;
+ # during global destruction we may already have lost this
+ unlink $self->_build_filename() if ($self->{base_dir});
}
}
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+
+use File::Temp qw(tempdir);
+
+use Test::More;
+use Test::Warn;
+
+plan tests => 2;
+
+use_ok('Parallel::Scoreboard');
+
+# create temporary directory
+my $base_dir = tempdir(CLEANUP => 1);
+
+# instantiate
+my $sb = Parallel::Scoreboard->new(
+ base_dir => $base_dir,
+);
+
+$sb->update('X');
+
+# simulate global destruction by deleting this attribute before DESTROY is
+# called
+delete $sb->{base_dir};
+
+warning_is(sub { undef $sb }, undef,
+ 'no warnings when object is destroyed and base_dir is undef');