@@ -1,18 +1,25 @@
Revision history for Crypt::OpenPGP
-1.06 2010.12.07
+1.07 2014-06-23
+ - Reformatted Changes as per CPAN::Changes::Spec.
+ - Fixed hash randomisation bug (RT#81442).
+ - Documentation now references most recent "OpenPGP Message Format" RFC.
+ - Fixed typo in Pod (@dsteinbrunner).
+ - Improved ASCII armor detection (@gwillen).
+
+1.06 2010-12-07
- Fixed an issue introduced in 1.05 on 32-bit systems in
Crypt::OpenPGP::Util::bigint2bin, where $base needed to be a
bigint. Thanks to Sam Crawley for the fix.
-1.05 2010.12.06
+1.05 2010-12-06
- Removed Math::Pari as a dependency of Crypt::OpenPGP itself (it's
still a dependency of some of the backends, including Crypt::RSA).
Thanks to Sam Crawley for the patch.
- Skipped RIPEMD160 test on amd64 due to known bug in Crypt::RIPEMD160
(see rt19138 & rt53323). Thanks to Sam Crawley for the patch.
-1.04 2009.12.10
+1.04 2009-12-10
- Keyring lookup by uid is now case-insensitive to match the behavior
in GnuPG. Fixes http://rt.cpan.org/Public/Bug/Display.html?id=2225
- Got rid of a warning in Crypt::OpenPGP::SKSessionKey related to
@@ -34,7 +41,7 @@ Revision history for Crypt::OpenPGP
- Added author tests (xt/) and modified SYNOPSIS for all modules to
make them pass the compilation test.
-1.03 2002.12.09
+1.03 2002-12-09
- Makefile.PL now uses ExtUtils::AutoInstall. Thanks to Autrijus Tang
for the note.
- SIGNATURE file now included with distribution.
@@ -48,7 +55,7 @@ Revision history for Crypt::OpenPGP
Crypt::OpenPGP::Cipher::supported.
- Fixed bug where signed cleartext has \r characters in the header.
-1.02 2002.10.12
+1.02 2002-10-12
- encrypt and verify now support auto-retrieval of public keys from
an HKP keyserver, if the keys are not found in the local keyring.
- Added support for the SHA-1 integrity checks on secret keys used
@@ -66,7 +73,7 @@ Revision history for Crypt::OpenPGP
- Added Crypt::OpenPGP::Signature::digest accessor. Thanks to Bob
Mathews for the patch.
-1.01 2002.07.15
+1.01 2002-07-15
- Added Crypt::OpenPGP::handle, a DWIM wrapper around the other
high-level interface methods. Given data, it determines whether the
data needs to be decrypted, verified, or both. And then it does what
@@ -89,7 +96,7 @@ Revision history for Crypt::OpenPGP
- Added Crypt::OpenPGP::KeyServer, which does lookups against an HKP
keyserver.
-1.00 2002.02.26
+1.00 2002-02-26
- CAST5 is now supported thanks to Crypt::CAST5_PP from Bob Mathews.
- bin/pgplet now supports encrypting and decrypting symmetrically-
encrypted messages.
@@ -108,7 +115,7 @@ Revision history for Crypt::OpenPGP
key data *and* user ID. Thanks to Joel Rowles for the spot.
- Fix bug in ElGamal encryption and k generation.
-0.18 2002.01.29
+0.18 2002-01-29
- Added IsPacketStream parameter to Crypt::OpenPGP::Message; this turns
off armour detection when initializing the message, and can be used
when you *know* that the message is a stream of packets, and not an
@@ -128,7 +135,7 @@ Revision history for Crypt::OpenPGP
- Fixed subkey IDs in list-keys with bin/pgplet.
- Check for errors when reading keyring.
-0.17 2001.09.15
+0.17 2001-09-15
- Added Crypt::OpenPGP::Config to hold per-instance configuration
information, either specified through the constructor, or set
in a config file. Reads from existing PGP/GnuPG config files.
@@ -143,10 +150,10 @@ Revision history for Crypt::OpenPGP
- Removed Crypt::DES_EDE3 from this distribution, moved into its own
distribution.
-0.16 2001.08.15
+0.16 2001-08-15
- Took stupid extraneous files out of lib. Ick.
-0.15 2001.08.15
+0.15 2001-08-15
- Added bin/pgplet as an example of Crypt::OpenPGP usage.
- Added PassphraseCallback parameter to Crypt::OpenPGP::decrypt
and Crypt::OpenPGP::sign; this callback will be invoked when a
@@ -185,7 +192,7 @@ Revision history for Crypt::OpenPGP
deserialized from some external source (network, database, etc.).
Thanks to Vipul for the idea.
-0.14 2001.08.09
+0.14 2001-08-09
- Crypt::OpenPGP::CFB now works in both standard and PGP-variant
mode (where PGP-variant is the slightly strange mode with the
resyncs). Support added via a 'sync' method to manually resync.
@@ -216,7 +223,7 @@ Revision history for Crypt::OpenPGP
IDs). Thanks to Vipul for the idea and patch (reworked).
- Fixed some compatibility (syntax) issues when using perl 5.005_03.
-0.13 2001.07.31
+0.13 2001-07-31
- Fix handling of partial length headers.
- Use proper version of Data::Buffer in Makefile.PL prereq.
- Fix bug with -----BEGIN PGP in text that is not actually armoured;
@@ -230,7 +237,7 @@ Revision history for Crypt::OpenPGP
when decrypting the message, in case there are multiple session
key packets. Thanks to Vipul for the patch.
-0.12 2001.07.29
+0.12 2001-07-29
- Added support for clear-text signatures, both creating (Clearsign
param to 'sign') and verifying (transparent support).
- For the time being Makefile.PL will not give a choice of
@@ -239,7 +246,7 @@ Revision history for Crypt::OpenPGP
reworked to auto-detect which module is installed and run the
tests with the appropriate key types.
-0.11 2001.07.29
+0.11 2001-07-29
- Added support for symmetric-key encrypted session key packets,
which means that Crypt::OpenPGP now supports "conventional"
encryption of data, in addition to the public-key encryption that
@@ -255,7 +262,7 @@ Revision history for Crypt::OpenPGP
- Fix Compat settings for PGP5, 3DES => DES3. Thanks to Vipul
for the spot and patch.
-0.10 2001.07.27
+0.10 2001-07-27
- Added Compat flag to encrypt and sign, added docs. Thanks to
Vipul for the idea.
- Added support for Twofish and Rijndael ciphers (128-, 192-, and
@@ -272,7 +279,7 @@ Revision history for Crypt::OpenPGP
- Cipher::key_len => Cipher::keysize.
- Added t/06-cipher.t, test all installed cipher packages.
-0.09 2001.07.27
+0.09 2001-07-27
- Fixed incompatibility with PGP2: PGP2 expects packets of certain
types to have certain header len sizes, no matter the actual len
of the data. eg. all Signature packets have to have 2 len bytes,
@@ -288,7 +295,7 @@ Revision history for Crypt::OpenPGP
with PGP2.
- Added tests for Crypt::OpenPGP::PacketFactory (t/05-packets.t).
-0.08 2001.07.26
+0.08 2001-07-26
- Fixed DEK encoding on encrypted session keys; the padding size
was incorrect, which meant that PGP5 could not recognize it
as a valid encoding.
@@ -311,7 +318,7 @@ Revision history for Crypt::OpenPGP
- Fix PARI error Util::mp2bin by casting 4*8 to PARI. Thanks to
Vipul for the spot and patch.
-0.07 2001.07.26
+0.07 2001-07-26
- Added key generation, in low-end Key etc. modules and in
high-level Crypt::OpenPGP frontend, which returns two
keyblocks.
@@ -319,7 +326,7 @@ Revision history for Crypt::OpenPGP
- Applied Vipul's patch to fix warnings about GNUPGHOME
and to add pubring.pkr and secring.skr. Thanks to Vipul.
-0.06 2001.07.25
+0.06 2001-07-25
- Fixed bug in SessionKey::_decode with using ciphers with
keys != 16 bytes. This caused incorrect checksums on the
key data.
@@ -335,14 +342,14 @@ Revision history for Crypt::OpenPGP
(in 01-util.t).
- Changed Certificate->decrypt to Certificate->unlock.
-0.05 2001.07.23
+0.05 2001-07-23
- Started test suite: currently it tests high-level OpenPGP
interface using keyrings from GnuPG.
- Rewrote CFB implementation (now faster).
- Improved installation process (ask questions, check for
required modules, etc.).
-0.04 2001.07.22
+0.04 2001-07-22
- Added support RSA signing and verification.
- Added support for ElGamal encryption/decryption.
- Added second arg to Crypt::OpenPGP::PacketFactory::parse that
@@ -354,13 +361,13 @@ Revision history for Crypt::OpenPGP
- Changed Crypt::OpenPGP methods to use find_keyblock_by_keyid
instead of reading in entire keyring.
-0.03 2001.07.20
+0.03 2001-07-20
- Fixed bug in un-armouring where checksum would not be picked up
properly if base64-encoded data had '=' at the end.
- Improved first crack at CRC24 implementation by using lookup
tables. This helps a lot.
-0.02 2001.07.20
+0.02 2001-07-20
- Added armouring in Crypt::OpenPGP::Armour.
- Added high-level DWIM interface to Crypt::OpenPGP.
- Now generate fingerprint on version 4 key certificates while
@@ -368,5 +375,5 @@ Revision history for Crypt::OpenPGP
can just generate the fingerprint using that data, rather than
having to serialize to get the key ID.
-0.01 2001.07.19
+0.01 2001-07-19
- Initial version.
@@ -3,11 +3,12 @@ abstract: 'Pure-Perl OpenPGP implementation'
author:
- Benjamin
build_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
-generated_by: 'Module::Install version 1.00'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.08'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -29,7 +30,7 @@ requires:
Crypt::RSA: 0
Crypt::Rijndael: 0
Crypt::Twofish: 0
- Data::Buffer: 0.04
+ Data::Buffer: '0.04'
Digest::MD5: 0
Digest::SHA1: 0
File::HomeDir: 0
@@ -42,4 +43,4 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/btrott/Crypt-OpenPGP.git
-version: 1.06
+version: '1.07'
@@ -842,6 +842,6 @@ AUTHOR & COPYRIGHT
Trott, cpan@stupidfool.org. All rights reserved.
REFERENCES
- 1 RFC2440 - OpenPGP Message Format (1998).
- http://www.faqs.org/rfcs/rfc2440.html
+ 1 RFC4880 - OpenPGP Message Format (2007).
+ http://www.faqs.org/rfcs/rfc4880.html
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.08';
}
# 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.08';
@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.08';
@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.08';
@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.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -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.08';
@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";
}
@@ -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;
@@ -1,36 +1,138 @@
#line 1
package Module::Install::ReadmeFromPod;
+use 5.006;
use strict;
use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.10';
+$VERSION = '0.22';
sub readme_from {
my $self = shift;
- return unless $Module::Install::AUTHOR;
- my $file = shift || return;
- my $clean = shift;
- require Pod::Text;
- my $parser = Pod::Text->new();
- open README, '> README' or die "$!\n";
- $parser->output_fh( *README );
- $parser->parse_file( $file );
- return 1 unless $clean;
- $self->postamble(<<"END");
-distclean :: license_clean
-
-license_clean:
-\t\$(RM_F) README
-END
+ return unless $self->is_admin;
+
+ # Input file
+ my $in_file = shift || $self->_all_from
+ or die "Can't determine file to make readme_from";
+
+ # 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);
+ }
+
+ if ($clean) {
+ $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};
+ my ($metadata) = grep {
+ ref($_) eq 'Module::Install::Metadata';
+ } @{$self->admin->{extensions}};
+ return unless $metadata;
+ return $metadata->{values}{all_from} || '';
+}
+
'Readme!';
__END__
-#line 94
+#line 254
@@ -7,7 +7,7 @@ use Module::Install::Base;
use vars qw($VERSION @ISA);
BEGIN {
- $VERSION = '0.11';
+ $VERSION = '0.60';
@ISA = 'Module::Install::Base';
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.08';
@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.08';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -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.08';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -451,7 +451,7 @@ sub _version ($) {
}
sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2010 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
@@ -1,17 +1,24 @@
#line 1
+##
+# name: Spiffy
+# abstract: Spiffy Perl Interface Framework For You
+# author: Ingy döt Net <ingy@ingy.net>
+# license: perl
+# copyright: 2004, 2006, 2011, 2012
+
package Spiffy;
use strict;
use 5.006001;
use warnings;
use Carp;
require Exporter;
-our $VERSION = '0.30';
+our $VERSION = '0.31';
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 +45,7 @@ sub new {
my $method = shift;
$self->$method(shift);
}
- return $self;
+ return $self;
}
my $filtered_files = {};
@@ -46,7 +53,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 +61,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 +86,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 +98,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 +106,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 +170,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 +182,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 +196,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",
);
@@ -229,7 +236,7 @@ sub 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 +281,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 +308,7 @@ sub parse_arguments {
push @values, $elem;
}
}
- return wantarray ? ($args, @values) : $args;
+ return wantarray ? ($args, @values) : $args;
}
sub boolean_arguments { () }
@@ -325,8 +332,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 +404,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 +446,7 @@ sub spiffy_mixin_methods {
$methods{$_}
? ($_, \ &{"$methods{$_}\::$_"})
: ($_, \ &{"$mixin_class\::$_"})
- } @_
+ } @_
? (get_roles($mixin_class, @_))
: (keys %methods);
}
@@ -450,12 +457,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);
} :
($_)
@@ -534,6 +541,3 @@ sub ZZZ {
1;
-__END__
-
-#line 1066
@@ -1,33 +1,55 @@
#line 1
package Sub::Uplevel;
-
use 5.006;
use strict;
-our $VERSION = '0.2002';
-$VERSION = eval $VERSION;
+# ABSTRACT: apparently run a function in a higher stack frame
+our $VERSION = '0.24'; # VERSION
-sub import {
- no strict 'refs';
- my ($class, @args) = @_;
- for my $fcn ( @args ) {
- if ( $fcn ne 'uplevel' ) {
- die qq{"$fcn" is not exported by the $class module\n}
- }
- }
- my $caller = caller(0);
- *{"$caller\::uplevel"} = \&uplevel;
- return;
+# Frame check global constant
+our $CHECK_FRAMES;
+BEGIN {
+ $CHECK_FRAMES = !! $CHECK_FRAMES;
}
+use constant CHECK_FRAMES => $CHECK_FRAMES;
# We must override *CORE::GLOBAL::caller if it hasn't already been
# overridden or else Perl won't see our local override later.
if ( not defined *CORE::GLOBAL::caller{CODE} ) {
- *CORE::GLOBAL::caller = \&_normal_caller;
+ *CORE::GLOBAL::caller = \&_normal_caller;
+}
+
+# modules to force reload if ":aggressive" is specified
+my @reload_list = qw/Exporter Exporter::Heavy/;
+
+sub import {
+ no strict 'refs'; ## no critic
+ my ($class, @args) = @_;
+ for my $tag ( @args, 'uplevel' ) {
+ if ( $tag eq 'uplevel' ) {
+ my $caller = caller(0);
+ *{"$caller\::uplevel"} = \&uplevel;
+ }
+ elsif( $tag eq ':aggressive' ) {
+ _force_reload( @reload_list );
+ }
+ else {
+ die qq{"$tag" is not exported by the $class module\n}
+ }
+ }
+ return;
}
+sub _force_reload {
+ no warnings 'redefine';
+ local $^W = 0;
+ for my $m ( @_ ) {
+ $m =~ s{::}{/}g;
+ $m .= ".pm";
+ require $m if delete $INC{$m};
+ }
+}
-#line 96
# @Up_Frames -- uplevel stack
# $Caller_Proxy -- whatever caller() override was in effect before uplevel
@@ -43,9 +65,7 @@ sub _apparent_stack_height {
}
sub uplevel {
- my($num_frames, $func, @args) = @_;
-
- # backwards compatible version of "no warnings 'redefine'"
+ # Backwards compatible version of "no warnings 'redefine'"
my $old_W = $^W;
$^W = 0;
@@ -53,41 +73,34 @@ sub uplevel {
local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
local *CORE::GLOBAL::caller = \&_uplevel_caller;
-
- # restore old warnings state
+
+ # Restore old warnings state
$^W = $old_W;
- if ( $num_frames >= _apparent_stack_height() ) {
+ if ( CHECK_FRAMES and $_[0] >= _apparent_stack_height() ) {
require Carp;
- Carp::carp("uplevel $num_frames is more than the caller stack");
+ Carp::carp("uplevel $_[0] is more than the caller stack");
}
- local @Up_Frames = ($num_frames, @Up_Frames );
-
- return $func->(@args);
+ local @Up_Frames = (shift, @Up_Frames );
+
+ my $function = shift;
+ return $function->(@_);
}
sub _normal_caller (;$) { ## no critic Prototypes
- my $height = $_[0];
+ my ($height) = @_;
$height++;
+ my @caller = CORE::caller($height);
if ( CORE::caller() eq 'DB' ) {
- # passthrough the @DB::args trick
+ # Oops, redo picking up @DB::args
package DB;
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
- }
- else {
- return CORE::caller($height);
- }
- }
- else {
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
- }
- else {
- return CORE::caller($height);
- }
+ @caller = CORE::caller($height);
}
+
+ return if ! @caller; # empty
+ return $caller[0] if ! wantarray; # scalar context
+ return @_ ? @caller : @caller[0..2]; # extra info or regular
}
sub _uplevel_caller (;$) { ## no critic Prototypes
@@ -98,7 +111,6 @@ sub _uplevel_caller (;$) { ## no critic Prototypes
# to skip this function's caller
return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
-#line 215
my $saw_uplevel = 0;
my $adjust = 0;
@@ -122,27 +134,21 @@ sub _uplevel_caller (;$) { ## no critic Prototypes
# For returning values, we pass through the call to the proxy caller
# function, just at a higher stack level
- my @caller;
+ my @caller = $Caller_Proxy->($height + $adjust + 1);
if ( CORE::caller() eq 'DB' ) {
- # passthrough the @DB::args trick
+ # Oops, redo picking up @DB::args
package DB;
@caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
}
- else {
- @caller = $Caller_Proxy->($height + $adjust + 1);
- }
- if( wantarray ) {
- if( !@_ ) {
- @caller = @caller[0..2];
- }
- return @caller;
- }
- else {
- return $caller[0];
- }
+ return if ! @caller; # empty
+ return $caller[0] if ! wantarray; # scalar context
+ return @_ ? @caller : @caller[0..2]; # extra info or regular
}
-#line 327
1;
+
+__END__
+#line 386
+
@@ -1,7 +1,4 @@
#line 1
-#. TODO:
-#.
-
#===============================================================================
# This is the default class for handling Test::Base data filtering.
#===============================================================================
@@ -341,4 +338,6 @@ sub _write_to {
__DATA__
-#line 639
+=encoding utf8
+
+#line 638
@@ -1,11 +1,9 @@
#line 1
-# TODO:
-#
package Test::Base;
-use 5.006001;
+our $VERSION = '0.62'; # VERSION
+
use Spiffy 0.30 -Base;
use Spiffy ':XXX';
-our $VERSION = '0.59';
my @test_more_exports;
BEGIN {
@@ -536,7 +534,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 {
@@ -681,4 +679,4 @@ __DATA__
=encoding utf8
-#line 1376
+#line 1374
@@ -3,12 +3,12 @@ package Test::Builder::Module;
use strict;
-use Test::Builder;
+use Test::Builder 0.99;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.94';
+our $VERSION = '1.001002';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -5,7 +5,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '0.94';
+our $VERSION = '1.001002';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -24,7 +24,7 @@ BEGIN {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
+ # occasionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
@@ -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 ) = @_;
@@ -99,25 +113,40 @@ sub child {
$self->croak("You already have a child named ($self->{Child_Name}) running");
}
- my $child = bless {}, ref $self;
- $child->reset;
+ my $parent_in_todo = $self->in_todo;
+
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
+
+ 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};
+
+ # 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
# cause all children to fail.
$child->{Child_Error} = $?;
$? = 0;
$child->{Parent} = $self;
+ $child->{Parent_TODO} = $orig_TODO;
$child->{Name} = $name || "Child of " . $self->name;
$self->{Child_Name} = $child->name;
return $child;
}
-#line 201
+#line 230
sub subtest {
my $self = shift;
@@ -129,27 +158,59 @@ 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 $child = $self->child($name);
- my %parent = %$self;
- %$self = %$child;
-
my $error;
- if( !eval { $subtests->(); 1 } ) {
- $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);
+ _copy($self, $parent);
+ _copy($child, $self);
+
+ my $run_the_subtests = sub {
+ # Add subtest name for clarification of starting point
+ $self->note("Subtest: $name");
+ $subtests->();
+ $self->done_testing unless $self->_plan_handled;
+ 1;
+ };
+
+ if( !eval { $run_the_subtests->() } ) {
+ $error = $@;
+ }
}
# 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});
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
- return $child->finalize;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $finalize = $child->finalize;
+
+ $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
+
+ return $finalize;
+}
+
+#line 309
+
+sub _plan_handled {
+ my $self = shift;
+ return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
}
-#line 250
+#line 334
sub finalize {
my $self = shift;
@@ -158,21 +219,26 @@ sub finalize {
if( $self->{Child_Name} ) {
$self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
}
+
+ local $? = 0; # don't fail if $subtests happened to set $? nonzero
$self->_ending;
# XXX This will only be necessary for TAP envelopes (we think)
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+ 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});
+ }
+ 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};
@@ -190,17 +256,17 @@ sub _indent {
return $self->{Indent};
}
-#line 300
+#line 389
sub parent { shift->{Parent} }
-#line 312
+#line 401
sub name { shift->{Name} }
sub DESTROY {
my $self = shift;
- if ( $self->parent ) {
+ if ( $self->parent and $$ == $self->{Original_Pid} ) {
my $name = $self->name;
$self->diag(<<"FAIL");
Child ($name) exited without calling finalize()
@@ -210,7 +276,7 @@ FAIL
}
}
-#line 336
+#line 425
our $Level;
@@ -227,12 +293,12 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
+ $self->{Done_Testing} = 0;
$self->{Original_Pid} = $$;
$self->{Child_Name} = undef;
$self->{Indent} ||= '';
- share( $self->{Curr_Test} );
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share( [] );
@@ -251,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 414
+
+# 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 517
my %plan_cmds = (
no_plan => \&no_plan,
@@ -303,8 +383,7 @@ sub _plan_tests {
return;
}
-
-#line 470
+#line 572
sub expected_tests {
my $self = shift;
@@ -322,7 +401,7 @@ sub expected_tests {
return $self->{Expected_Tests};
}
-#line 494
+#line 596
sub no_plan {
my($self, $arg) = @_;
@@ -335,8 +414,7 @@ sub no_plan {
return 1;
}
-
-#line 528
+#line 629
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -354,7 +432,8 @@ sub _output_plan {
return;
}
-#line 579
+
+#line 681
sub done_testing {
my($self, $num_tests) = @_;
@@ -397,7 +476,7 @@ sub done_testing {
}
-#line 630
+#line 732
sub has_plan {
my $self = shift;
@@ -407,7 +486,7 @@ sub has_plan {
return(undef);
}
-#line 647
+#line 749
sub skip_all {
my( $self, $reason ) = @_;
@@ -421,7 +500,7 @@ sub skip_all {
exit(0);
}
-#line 672
+#line 774
sub exported_to {
my( $self, $pack ) = @_;
@@ -432,7 +511,7 @@ sub exported_to {
return $self->{Exported_To};
}
-#line 702
+#line 804
sub ok {
my( $self, $test, $name ) = @_;
@@ -589,17 +668,15 @@ 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 876
+#line 982
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_str( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -616,8 +693,6 @@ sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_num( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -675,7 +750,7 @@ sub _isnt_diag {
DIAGNOSTIC
}
-#line 973
+#line 1075
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -709,29 +784,36 @@ sub isnt_num {
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 1022
+#line 1124
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 1046
+#line 1148
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 ) = @_;
+ if ($cmp_ok_bl{$type}) {
+ $self->croak("$type is not a valid comparison operator in cmp_ok()");
+ }
+
my $test;
my $error;
{
@@ -741,8 +823,9 @@ sub cmp_ok {
my($pack, $file, $line) = $self->caller();
+ # This is so that warnings come out at the caller's level
$test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
+#line $line "(eval in cmp_ok) $file"
\$got $type \$expect;
];
$error = $@;
@@ -805,24 +888,31 @@ sub _caller_context {
return $code;
}
-#line 1145
+#line 1255
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 1158
+#line 1275
{
no warnings 'once';
*BAILOUT = \&BAIL_OUT;
}
-#line 1172
+#line 1289
sub skip {
my( $self, $why ) = @_;
@@ -853,7 +943,7 @@ sub skip {
return 1;
}
-#line 1213
+#line 1330
sub todo_skip {
my( $self, $why ) = @_;
@@ -881,7 +971,7 @@ sub todo_skip {
return 1;
}
-#line 1293
+#line 1410
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -916,7 +1006,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);
@@ -928,14 +1018,19 @@ sub _regex_ok {
}
{
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
my $test;
my $context = $self->_caller_context;
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
- $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ # 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 '!~';
@@ -944,11 +1039,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
@@ -961,7 +1056,7 @@ DIAGNOSTIC
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1389
+#line 1511
sub _try {
my( $self, $code, %opts ) = @_;
@@ -981,7 +1076,7 @@ sub _try {
return wantarray ? ( $return, $error ) : $return;
}
-#line 1418
+#line 1540
sub is_fh {
my $self = shift;
@@ -995,7 +1090,7 @@ sub is_fh {
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1461
+#line 1583
sub level {
my( $self, $level ) = @_;
@@ -1006,7 +1101,7 @@ sub level {
return $Level;
}
-#line 1493
+#line 1615
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -1017,7 +1112,7 @@ sub use_numbers {
return $self->{Use_Nums};
}
-#line 1526
+#line 1648
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -1035,7 +1130,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1579
+#line 1701
sub diag {
my $self = shift;
@@ -1043,7 +1138,7 @@ sub diag {
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1594
+#line 1716
sub note {
my $self = shift;
@@ -1080,7 +1175,7 @@ sub _print_comment {
return 0;
}
-#line 1644
+#line 1766
sub explain {
my $self = shift;
@@ -1099,7 +1194,7 @@ sub explain {
} @_;
}
-#line 1673
+#line 1795
sub _print {
my $self = shift;
@@ -1114,20 +1209,21 @@ sub _print_to_fh {
return if $^C;
my $msg = join '', @msgs;
+ my $indent = $self->_indent;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
+ $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
- return print $fh $self->_indent, $msg;
+ return print $fh $indent, $msg;
}
-#line 1732
+#line 1855
sub output {
my( $self, $fh ) = @_;
@@ -1223,8 +1319,8 @@ sub _open_testhandles {
open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
- # $self->_copy_io_layers( \*STDOUT, $Testout );
- # $self->_copy_io_layers( \*STDERR, $Testerr );
+ $self->_copy_io_layers( \*STDOUT, $Testout );
+ $self->_copy_io_layers( \*STDERR, $Testerr );
$self->{Opened_Testhandles} = 1;
@@ -1239,14 +1335,22 @@ sub _copy_io_layers {
require PerlIO;
my @src_layers = PerlIO::get_layers($src);
- binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ _apply_layers($dst, @src_layers) if @src_layers;
}
);
return;
}
-#line 1857
+sub _apply_layers {
+ my ($fh, @layers) = @_;
+ my %seen;
+ my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
+ binmode($fh, join(":", "", "raw", @unique));
+}
+
+
+#line 1988
sub reset_outputs {
my $self = shift;
@@ -1258,7 +1362,7 @@ sub reset_outputs {
return;
}
-#line 1883
+#line 2014
sub _message_at_caller {
my $self = shift;
@@ -1279,7 +1383,7 @@ sub croak {
}
-#line 1923
+#line 2054
sub current_test {
my( $self, $num ) = @_;
@@ -1312,7 +1416,7 @@ sub current_test {
return $self->{Curr_Test};
}
-#line 1971
+#line 2102
sub is_passing {
my $self = shift;
@@ -1325,7 +1429,7 @@ sub is_passing {
}
-#line 1993
+#line 2124
sub summary {
my($self) = shift;
@@ -1333,14 +1437,14 @@ sub summary {
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 2048
+#line 2179
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 2077
+#line 2208
sub todo {
my( $self, $pack ) = @_;
@@ -1354,19 +1458,21 @@ sub todo {
return '';
}
-#line 2099
+#line 2235
sub find_TODO {
- my( $self, $pack ) = @_;
+ my( $self, $pack, $set, $new_value ) = @_;
$pack = $pack || $self->caller(1) || $self->exported_to;
return unless $pack;
no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
}
-#line 2117
+#line 2255
sub in_todo {
my $self = shift;
@@ -1375,7 +1481,7 @@ sub in_todo {
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 2167
+#line 2305
sub todo_start {
my $self = shift;
@@ -1390,7 +1496,7 @@ sub todo_start {
return;
}
-#line 2189
+#line 2327
sub todo_end {
my $self = shift;
@@ -1411,7 +1517,7 @@ sub todo_end {
return;
}
-#line 2222
+#line 2360
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1426,9 +1532,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return wantarray ? @caller : $caller[0];
}
-#line 2239
+#line 2377
-#line 2253
+#line 2391
#'#
sub _sanity_check {
@@ -1441,7 +1547,7 @@ sub _sanity_check {
return;
}
-#line 2274
+#line 2412
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1456,7 +1562,7 @@ WHOA
return;
}
-#line 2298
+#line 2436
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1464,7 +1570,7 @@ sub _my_exit {
return 1;
}
-#line 2310
+#line 2448
sub _ending {
my $self = shift;
@@ -1483,6 +1589,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"
@@ -1583,7 +1709,7 @@ END {
$Test->_ending if defined $Test;
}
-#line 2498
+#line 2656
1;
@@ -7,7 +7,7 @@ use Test::Builder;
use Sub::Uplevel qw( uplevel );
use base qw( Exporter );
-our $VERSION = '0.29';
+our $VERSION = '0.32';
our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
my $Tester = Test::Builder->new;
@@ -27,11 +27,44 @@ sub import {
sub _quiet_caller (;$) { ## no critic Prototypes
my $height = $_[0];
$height++;
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
+
+ if ( CORE::caller() eq 'DB' ) {
+ # passthrough the @DB::args trick
+ package DB;
+ if( wantarray ) {
+ if ( !@_ ) {
+ return (CORE::caller($height))[0..2];
+ }
+ else {
+ # If we got here, we are within a Test::Exception test, and
+ # something is producing a stacktrace. In case this is a full
+ # trace (i.e. confess() ), we have to make sure that the sub
+ # args are not visible. If we do not do this, and the test in
+ # question is throws_ok() with a regex, it will end up matching
+ # against itself in the args to throws_ok().
+ #
+ # While it is possible (and maybe wise), to test if we are
+ # indeed running under throws_ok (by crawling the stack right
+ # up from here), the old behavior of Test::Exception was to
+ # simply obliterate @DB::args altogether in _quiet_caller, so
+ # we are just preserving the behavior to avoid surprises
+ #
+ my @frame_info = CORE::caller($height);
+ @DB::args = ();
+ return @frame_info;
+ }
+ }
+
+ # fallback if nothing above returns
+ return CORE::caller($height);
}
else {
- return CORE::caller($height);
+ if( wantarray and !@_ ) {
+ return (CORE::caller($height))[0..2];
+ }
+ else {
+ return CORE::caller($height);
+ }
}
}
@@ -64,7 +97,7 @@ sub _exception_as_string {
};
-#line 168
+#line 206
sub throws_ok (&$;$) {
@@ -92,7 +125,7 @@ sub throws_ok (&$;$) {
};
-#line 216
+#line 254
sub dies_ok (&;$) {
my ( $coderef, $description ) = @_;
@@ -103,7 +136,7 @@ sub dies_ok (&;$) {
}
-#line 255
+#line 293
sub lives_ok (&;$) {
my ( $coderef, $description ) = @_;
@@ -115,7 +148,7 @@ sub lives_ok (&;$) {
}
-#line 295
+#line 333
sub lives_and (&;$) {
my ( $test, $description ) = @_;
@@ -139,6 +172,6 @@ sub lives_and (&;$) {
return;
}
-#line 462
+#line 502
1;
@@ -18,10 +18,10 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.94';
+our $VERSION = '1.001002';
$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 367
+#line 371
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +104,7 @@ sub isnt ($$;$) {
*isn't = \&isnt;
-#line 411
+#line 415
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -112,7 +112,7 @@ sub like ($$;$) {
return $tb->like(@_);
}
-#line 426
+#line 430
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -120,7 +120,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 471
+#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -128,7 +128,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 506
+#line 511
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -162,67 +162,89 @@ sub can_ok ($@) {
return $ok;
}
-#line 572
+#line 577
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 651
+#line 678
sub new_ok {
my $tb = Test::More->builder;
@@ -231,7 +253,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,23 +261,24 @@ 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 719
+#line 764
-sub subtest($&) {
+sub subtest {
my ($name, $subtests) = @_;
my $tb = Test::More->builder;
return $tb->subtest(@_);
}
-#line 743
+#line 788
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +292,52 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 806
+#line 841
+
+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 935
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -278,6 +345,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 +353,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 +362,8 @@ USE
else {
$code = <<USE;
package $pack;
+
+#line $line $filename
use $module \@{\$args[0]};
1;
USE
@@ -332,51 +404,8 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 875
-sub require_ok ($) {
- my($module) = shift;
- my $tb = Test::More->builder;
-
- my $pack = caller;
-
- # Try to deterine 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 952
+#line 1036
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -476,14 +505,14 @@ sub _type {
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1112
+#line 1196
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +522,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1138
+#line 1222
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1204
+#line 1288
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +556,7 @@ sub skip {
last SKIP;
}
-#line 1288
+#line 1372
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +577,7 @@ sub todo_skip {
last TODO;
}
-#line 1343
+#line 1427
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +586,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1382
+#line 1466
#'#
sub eq_array {
@@ -581,6 +610,8 @@ sub _eq_array {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -591,6 +622,21 @@ sub _eq_array {
return $ok;
}
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
+}
+
sub _deep_check {
my( $e1, $e2 ) = @_;
my $tb = Test::More->builder;
@@ -603,9 +649,6 @@ sub _deep_check {
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -616,7 +659,7 @@ sub _deep_check {
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -683,7 +726,7 @@ WHOA
}
}
-#line 1515
+#line 1613
sub eq_hash {
local @Data_Stack = ();
@@ -706,6 +749,8 @@ sub _eq_hash {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -716,7 +761,7 @@ sub _eq_hash {
return $ok;
}
-#line 1572
+#line 1672
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -741,6 +786,6 @@ sub eq_set {
);
}
-#line 1774
+#line 1911
1;
@@ -188,7 +188,7 @@ This argument is required.
=item * Headers
A reference to a hash containing key-value pairs, where the key is the
-name of the the header and the value the header value. These headers
+name of the header and the value the header value. These headers
are placed at the top of the encoded message in the form C<Header: Value>.
=back
@@ -94,7 +94,7 @@ that PGP uses in its encryption and decryption. The key difference
with PGP CFB is that the CFB state is resynchronized at each
encryption/decryption. This applies both when encrypting secret key
data and in symmetric encryption of standard encrypted data. More
-differences are described in the OpenPGP RFC, in section 12.8
+differences are described in the OpenPGP RFC, in section 13.9
(OpenPGP CFB mode).
Typically you should never need to directly use I<Crypt::OpenPGP::CFB>;
@@ -134,7 +134,7 @@ packets, providing both encryption and decryption functionality. Both
standard encrypted data packets and encrypted-MDC (modification
detection code) packets are supported by this class. In the first case,
the encryption used in the packets is a variant on standard CFB mode,
-and is described in the OpenPGP RFC, in section 12.8 (OpenPGP CFB mode).
+and is described in the OpenPGP RFC, in section 13.9 (OpenPGP CFB mode).
In the second case (encrypted-MDC packets), the encryption is performed
in standard CFB mode, without the special resync used in PGP's CFB.
@@ -30,7 +30,7 @@ sub init {
{ local $/; $ring->{_data} = <FH> }
close FH;
}
- if ($ring->{_data} =~ /-----BEGIN/) {
+ if ($ring->{_data} =~ /^-----BEGIN/) {
require Crypt::OpenPGP::Armour;
my $rec = Crypt::OpenPGP::Armour->unarmour($ring->{_data}) or
return (ref $ring)->error("Unarmour failed: " .
@@ -212,7 +212,7 @@ this class implements.
Creates a new type of S2k-generator of type I<$type>; valid values for
I<$type> are C<Simple>, C<Salted>, and C<Salt_Iter>. These generator
-types are described in the OpenPGP RFC section 3.6.
+types are described in the OpenPGP RFC section 3.7.
Returns the new S2k-generator object.
@@ -59,8 +59,8 @@ sub save {
$buf->put_bytes($key->{key_id}, 8);
$buf->put_int8($key->{pk_alg});
my $c = $key->{C};
- for my $mp (values %$c) {
- $buf->put_mp_int($mp);
+ for my $prop (sort keys %$c) {
+ $buf->put_mp_int($c->{$prop});
}
$buf->bytes;
}
@@ -69,8 +69,9 @@ sub display {
my $key = shift;
my $str = sprintf ":pubkey enc packet: version %d, algo %d, keyid %s\n",
$key->{version}, $key->{pk_alg}, uc unpack('H*', $key->{key_id});
- for my $mp (values %{ $key->{C} }) {
- $str .= sprintf " data: [%d bits]\n", bitsize($mp);
+ my $c = $key->{C};
+ for my $prop (sort keys %$c) {
+ $str .= sprintf " data: [%d bits]\n", bitsize($c->{$prop});
}
$str;
}
@@ -3,7 +3,7 @@ use strict;
use 5.008_001;
use vars qw( $VERSION );
-$VERSION = '1.06';
+$VERSION = '1.07';
use Crypt::OpenPGP::Constants qw( DEFAULT_CIPHER );
use Crypt::OpenPGP::KeyRing;
@@ -399,7 +399,7 @@ sub verify {
## pgp2 and pgp5 do not trim trailing whitespace from "canonical text"
## signatures, only from cleartext signatures. So we first try to verify
-## the signature using proper RFC2440 canonical text, then if that fails,
+## the signature using proper RFC4880 canonical text, then if that fails,
## retry without trimming trailing whitespace.
## See:
## http://cert.uni-stuttgart.de/archive/ietf-openpgp/2000/01/msg00033.html
@@ -1671,7 +1671,7 @@ Trott, cpan@stupidfool.org. All rights reserved.
=over 4
-=item 1 RFC2440 - OpenPGP Message Format (1998). http://www.faqs.org/rfcs/rfc2440.html
+=item 1 RFC4880 - OpenPGP Message Format (2007). http://www.faqs.org/rfcs/rfc4880.html
=back