perl
view release on metacpan or search on metacpan
cpan/CPAN-Meta-Requirements/t/from-hash.t view on Meta::CPAN
is_deeply(
$req->as_string_hash,
$string_hash,
"we can load from a string hash",
);
}
SKIP: {
skip "Can't tell v-strings from strings until 5.8.1", 1
unless $] gt '5.008';
my $string_hash = {
Left => 10,
Shared => '= 2',
Right => 18,
};
dies_ok { CPAN::Meta::Requirements->from_string_hash($string_hash) }
qr/Can't convert/,
"we die when we can't understand a version spec";
}
cpan/CPAN-Meta-Requirements/t/from-hash.t view on Meta::CPAN
is_deeply(
$req->as_string_hash,
{ map { ($_ => 0) } keys(%$undef_hash), keys(%$z_hash) },
"undef/'' requirements treated as '0'",
);
}
SKIP: {
skip "Can't tell v-strings from strings until 5.8.1", 2
unless $] gt '5.008';
my $string_hash = {
Left => 10,
Shared => v50.44.60,
Right => 18,
};
my $warning;
local $SIG{__WARN__} = sub { $warning = join("\n",@_) };
my $req = eval { CPAN::Meta::Requirements->from_string_hash($string_hash); };
cpan/CPAN-Meta-YAML/t/01_compile.t view on Meta::CPAN
use warnings;
use lib 't/lib';
BEGIN {
$| = 1;
}
use Test::More 0.88;
# Check their perl version
ok( $] ge '5.008001', "Your perl is new enough" );
# Does the module load
require_ok( 'CPAN::Meta::YAML' );
require_ok( 'TestUtils' );
require_ok( 'TestBridge' );
require_ok( 'TestML::Tiny' );
done_testing;
cpan/CPAN-Meta/lib/CPAN/Meta.pm view on Meta::CPAN
#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
#pod this is not recommended due to subtle incompatibilities between YAML parsers on
#pod CPAN.
#pod
#pod =cut
sub save {
my ($self, $file, $options) = @_;
my $version = $options->{version} || '2';
my $layer = $] ge '5.008001' ? ':utf8' : '';
if ( $version ge '2' ) {
carp "'$file' should end in '.json'"
unless $file =~ m{\.json$};
}
else {
carp "'$file' should end in '.yml'"
unless $file =~ m{\.yml$};
}
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm view on Meta::CPAN
else {
$request->{headers}{'content-type'} ||= "application/octet-stream";
$request->{headers}{'transfer-encoding'} = 'chunked'
unless exists $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = $args->{content};
}
}
elsif ( length $args->{content} ) {
my $content = $args->{content};
if ( $] ge '5.008' ) {
utf8::downgrade($content, 1)
or die(qq/Wide character in request message body\n/);
}
$request->{headers}{'content-type'} ||= "application/octet-stream";
$request->{headers}{'content-length'} = length $content
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = sub { substr $content, 0, length $content, '' };
}
$request->{trailer_cb} = $args->{trailer_callback}
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm view on Meta::CPAN
# URI escaping adapted from URI::Escape
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
$escapes{' '}="+";
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
sub _uri_escape {
my ($self, $str) = @_;
return "" if !defined $str;
if ( $] ge '5.008' ) {
utf8::encode($str);
}
else {
$str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
if ( length $str == do { use bytes; length $str } );
$str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
}
$str =~ s/($unsafe_char)/$escapes{$1}/g;
return $str;
}
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm view on Meta::CPAN
@_ == 1 || die(q/Usage: $handle->close()/ . "\n");
my ($self) = @_;
CORE::close($self->{fh})
or die(qq/Could not close socket: '$!'\n/);
}
sub write {
@_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
my ($self, $buf) = @_;
if ( $] ge '5.008' ) {
utf8::downgrade($buf, 1)
or die(qq/Wide character in write()\n/);
}
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm view on Meta::CPAN
@_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_content()\n/);
}
$len += $self->write($data);
}
$len == $content_length
or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm view on Meta::CPAN
@_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
my ($self, $request) = @_;
my $len = 0;
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_chunked_body()\n/);
}
$len += length $data;
my $chunk = sprintf '%X', length $data;
$chunk .= "\x0D\x0A";
$chunk .= $data;
$chunk .= "\x0D\x0A";
cpan/Pod-Simple/lib/Pod/Simple.pm view on Meta::CPAN
if(defined &UNICODE) { }
elsif($] >= 5.008) { *UNICODE = sub() {1} }
else { *UNICODE = sub() {''} }
}
if(DEBUG > 2) {
print STDERR "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
print STDERR "# We are under a Unicode-safe Perl.\n";
}
# The NO BREAK SPACE and SOFT HYHPEN are used in several submodules.
if ($] ge 5.007_003) { # On sufficiently modern Perls we can handle any
# character set
$Pod::Simple::nbsp = chr utf8::unicode_to_native(0xA0);
$Pod::Simple::shy = chr utf8::unicode_to_native(0xAD);
}
elsif (Pod::Simple::ASCII) { # Hard code ASCII early Perl
$Pod::Simple::nbsp = "\xA0";
$Pod::Simple::shy = "\xAD";
}
else { # EBCDIC on early Perl. We know what the values are for the code
# pages supported then.
cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm view on Meta::CPAN
sub my_qr ($$) {
# $1 is a pattern to compile and return. Older perls compile any
# syntactically valid property, even if it isn't legal. To cope with
# this, return an empty string unless the compiled pattern also
# successfully matches $2, which the caller furnishes.
my ($input_re, $should_match) = @_;
# XXX could have a third parameter $shouldnt_match for extra safety
my $use_utf8 = ($] le 5.006002) ? 'use utf8;' : "";
my $re = eval "no warnings; $use_utf8 qr/$input_re/";
#print STDERR __LINE__, ": $input_re: $@\n" if $@;
return "" if $@;
my $matches = eval "no warnings; $use_utf8 '$should_match' =~ /$re/";
#print STDERR __LINE__, ": $input_re: $@\n" if $@;
return "" if $@;
#print STDERR __LINE__, ": SUCCESS: $re\n" if $matches;
cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm view on Meta::CPAN
# Latin script code points not in the first release of Unicode
my $later_latin_re = my_qr('[^\P{IsLatin}\p{IsAge=1.1}]', "\x{1F6}");
# If this perl doesn't have the Deprecated property, there's only one code
# point in it that we need be concerned with.
my $deprecated_re = my_qr('\p{IsDeprecated}', "\x{149}");
$deprecated_re = qr/\x{149}/ unless $deprecated_re;
my $utf8_bom;
if (($] ge 5.007_003)) {
$utf8_bom = "\x{FEFF}";
utf8::encode($utf8_bom);
} else {
$utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls.
}
# This is used so that the 'content_seen' method doesn't return true on a
# file that just happens to have a line that matches /^=[a-zA-z]/. Only if
# there is a valid =foo line will we return that content was seen.
my $seen_legal_directive = 0;
cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm view on Meta::CPAN
# correspond to the unused portion of 8859-1 that 1252 mostly takes
# over. That means that there are fewer code points that are
# represented by multi-bytes. But, note that the these controls are
# very unlikely to be in pod text. So if we encounter one of them, it
# means that it is quite likely CP1252 and not UTF-8. The net result is
# the same code below is used for both platforms.
#
# XXX probably if the line has E<foo> that evaluates to illegal CP1252,
# then it is UTF-8. But we haven't processed E<> yet.
goto set_1252 if $] lt 5.006_000; # No UTF-8 on very early perls
my $copy;
no warnings 'utf8';
if ($] ge 5.007_003) {
$copy = $line;
# On perls that have this function, we can use it to easily see if the
# sequence is valid UTF-8 or not; if valid it turns on the UTF-8 flag
# needed below for script run detection
goto set_1252 if ! utf8::decode($copy);
}
elsif (ord("A") != 65) { # Early EBCDIC, assume UTF-8. What's a windows
# code page doing here anyway?
goto set_utf8;
}
else { # ASCII, no decode(): do it ourselves using the fundamental
# characteristics of UTF-8
use if $] le 5.006002, 'utf8';
my $char_ord;
my $needed; # How many continuation bytes to gobble up
# Initialize the translated line with a dummy character that will be
# deleted after everything else is done. This dummy makes sure that
# $copy will be in UTF-8. Doing it now avoids the bugs in early perls
# with upgrading in the middle
$copy = chr(0x100);
cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm view on Meta::CPAN
print {$_[0]{'output_fh'}}
' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
}
return;
}
cpan/Pod-Simple/lib/Pod/Simple/HTML.pm view on Meta::CPAN
return $self->section_url_escape(
$self->section_name_tidy($section)
);
}
sub section_name_tidy {
my($self, $section) = @_;
$section =~ s/^\s+//;
$section =~ s/\s+$//;
$section =~ tr/ /_/;
if ($] ge 5.006) {
$section =~ s/[[:cntrl:][:^ascii:]]//g; # drop crazy characters
} elsif ('A' eq chr(65)) { # But not on early EBCDIC
$section =~ tr/\x00-\x1F\x80-\x9F//d;
}
$section = $self->unicode_escape_url($section);
$section = '_' unless length $section;
return $section;
}
sub section_url_escape { shift->general_url_escape(@_) }
cpan/Pod-Simple/lib/Pod/Simple/HTML.pm view on Meta::CPAN
sub general_url_escape {
my($self, $string) = @_;
$string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
# express Unicode things as urlencode(utf(orig)).
# A pretty conservative escaping, behoovey even for query components
# of a URL (see RFC 2396)
if ($] ge 5.007_003) {
$string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',utf8::native_to_unicode(ord($1)))/eg;
} else { # Is broken for non-ASCII platforms on early perls
$string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
return $string;
}
cpan/Pod-Simple/lib/Pod/Simple/HTML.pm view on Meta::CPAN
return $string;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub esc { # a function.
if(defined wantarray) {
if(wantarray) {
@_ = splice @_; # break aliasing
} else {
my $x = shift;
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
return $x;
}
}
foreach my $x (@_) {
# Escape things very cautiously:
if (defined $x) {
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
}
}
# Leave out "- so that "--" won't make it thru in X-generated comments
# with text in them.
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
cpan/Pod-Simple/lib/Pod/Simple/RTF.pm view on Meta::CPAN
our @ISA;
BEGIN {@ISA = ('Pod::Simple::PullParser')}
use Carp ();
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
sub to_uni ($) { # Convert native code point to Unicode
my $x = shift;
# Broken for early EBCDICs
$x = chr utf8::native_to_unicode(ord $x) if $] ge 5.007_003
&& ord("A") != 65;
return $x;
}
# We escape out 'F' so that we can send RTF files thru the mail without the
# slightest worry that paragraphs beginning with "From" will get munged.
# We also escape '\', '{', '}', and '_'
my $map_to_self = ' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~';
our $WRAP;
cpan/Pod-Simple/lib/Pod/Simple/RTF.pm view on Meta::CPAN
my $question_mark_code_points =
Pod::Simple::BlackBox::my_qr('([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])',
"\x{110000}");
my $plane0 =
Pod::Simple::BlackBox::my_qr('([\x{100}-\x{FFFF}])', "\x{100}");
my $other_unicode =
Pod::Simple::BlackBox::my_qr('([\x{10000}-\x{10FFFF}])', "\x{10000}");
sub esc_uni($) {
use if $] le 5.006002, 'utf8';
my $x = shift;
# The output is expected to be UTF-16. Surrogates and above-Unicode get
# mapped to '?'
$x =~ s/$question_mark_code_points/?/g if $question_mark_code_points;
# Non-surrogate Plane 0 characters get mapped to their code points. But
# the standard calls for a 16bit SIGNED value.
$x =~ s/$plane0/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg
cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm view on Meta::CPAN
print {$_[0]{'output_fh'}} "</", $_[1], ">";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
if ($] ge 5.007_003) {
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
} else { # Is broken for non-ASCII platforms on early perls
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
}
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
}
return;
}
cpan/Pod-Simple/t/ascii_order.pl view on Meta::CPAN
# Helper for some of the .t's in this directory
sub native_to_uni($) { # Convert from platform character set to Unicode
# (which is the same as ASCII)
my $string = shift;
return $string if ord("A") == 65
|| $] lt 5.007_003; # Doesn't work on early EBCDIC Perls
my $output = "";
for my $i (0 .. length($string) - 1) {
$output .= chr(utf8::native_to_unicode(ord(substr($string, $i, 1))));
}
# Preserve utf8ness of input onto the output, even if it didn't need to be
# utf8
utf8::upgrade($output) if utf8::is_utf8($string);
return $output;
}
cpan/Pod-Simple/t/encod04.t view on Meta::CPAN
use Pod::Simple::DumpAsXML;
use Pod::Simple::XMLOutStream;
# Initial, isolated, non-ASCII byte triggers CP1252 guess and later
# multi-byte sequence is not considered by heuristic.
my $x97;
my $x91;
my $dash;
if ($] ge 5.007_003) {
$x97 = chr utf8::unicode_to_native(0x97);
$x91 = chr utf8::unicode_to_native(0x91);
$dash = '—';
}
else { # Tests will fail for early EBCDICs
$x97 = chr 0x97;
$x91 = chr 0x91;
$dash = '--';
}
cpan/Scalar-List-Utils/t/stack-corruption.t view on Meta::CPAN
#!./perl
BEGIN {
if ($] eq "5.008009" or $] eq "5.010000" or $] le "5.006002") {
print "1..0 # Skip: known to fail on $]\n";
exit 0;
}
}
use strict;
use warnings;
use List::Util qw(reduce);
use Test::More tests => 1;
cpan/Scalar-List-Utils/t/sum.t view on Meta::CPAN
}
SKIP: {
skip "IV is not at least 64bit", 4 unless $Config{ivsize} >= 8;
# Sum using NV will only preserve 53 bits of integer precision
my $t = sum(1152921504606846976, 1); # 1<<60, but Perl 5.6 does not compute constant correctly
cmp_ok($t, 'gt', 1152921504606846976, 'sum uses IV where it can'); # string comparison because Perl 5.6 does not compare it numerically correctly
SKIP: {
skip "known to fail on $]", 1 if $] le "5.006002";
$t = sum(1<<60, 1);
cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
}
my $min = -(1<<63);
my $max = 9223372036854775807; # (1<<63)-1, but Perl 5.6 does not compute constant correctly
$t = sum($min, $max);
is($t, -1, 'min + max');
$t = sum($max, $min);
cpan/Scalar-List-Utils/t/uniq.t view on Meta::CPAN
'uniqstr considers undef and empty-string equivalent' );
ok( length $warnings, 'uniqstr on undef yields a warning' );
is_deeply( [ uniqstr undef ],
[ "" ],
'uniqstr on undef coerces to empty-string' );
}
SKIP: {
skip 'Perl 5.007003 with utf8::encode is required', 3 if $] lt "5.007003";
my $warnings = "";
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
my $cafe = "cafe\x{301}";
is_deeply( [ uniqstr $cafe ],
[ $cafe ],
'uniqstr is happy with Unicode strings' );
SKIP: {
cpan/Scalar-List-Utils/t/uniq.t view on Meta::CPAN
'uniqint considers undef and zero equivalent' );
ok( length $warnings, 'uniqint on undef yields a warning' );
is_deeply( [ uniqint undef ],
[ 0 ],
'uniqint on undef coerces to zero' );
}
SKIP: {
skip('UVs are not reliable on this perl version', 2) unless $] ge "5.008000";
my $maxbits = $Config{ivsize} * 8 - 1;
# An integer guaranteed to be a UV
my $uv = 1 << $maxbits;
is_deeply( [ uniqint $uv, $uv + 1 ],
[ $uv, $uv + 1 ],
'uniqint copes with UVs' );
my $nvuv = 2 ** $maxbits;
cpan/Scalar-List-Utils/t/uniq.t view on Meta::CPAN
package main;
my @strs = map { Stringify->new( $_ ) } qw( foo foo bar );
is_deeply( [ map "$_", uniqstr @strs ],
[ map "$_", $strs[0], $strs[2] ],
'uniqstr respects stringify overload' );
}
SKIP: {
skip('int overload requires perl version 5.8.0', 1) unless $] ge "5.008000";
package Googol;
use overload '""' => sub { "1" . ( "0"x100 ) },
'int' => sub { $_[0] },
fallback => 1;
sub new { bless {}, $_[0] }
package main;
cpan/Scalar-List-Utils/t/uniqnum.t view on Meta::CPAN
'uniqnum recognizes 100000000000000016 and 100000000000000016.0 as the same' );
is_deeply( [ uniqnum (-100000000000000016, -100000000000000016.0) ],
[ (-100000000000000016) ],
'uniqnum recognizes -100000000000000016 and -100000000000000016.0 as the same' );
}
# uniqnum not confused by IV'ified floats
SKIP: {
# This fails on 5.6 and isn't fixable without breaking a lot of other tests
skip 'This perl version gets confused by IVNV dualvars', 1 if $] lt '5.008000';
my @nums = ( 2.1, 2.2, 2.3 );
my $dummy = sprintf "%d", $_ for @nums;
# All @nums now have both NOK and IOK but IV=2 in each case
is( scalar( uniqnum @nums ), 3, 'uniqnum not confused by dual IV+NV' );
}
{
package Numify;
cpan/Test-Harness/lib/TAP/Harness.pm view on Meta::CPAN
my ($rulesfile) = defined $self->rulesfile ? $self->rulesfile :
defined($ENV{HARNESS_RULESFILE}) ? $ENV{HARNESS_RULESFILE} :
grep { -r } qw(./testrules.yml t/testrules.yml);
if ( defined $rulesfile && -r $rulesfile ) {
if ( ! eval { require CPAN::Meta::YAML; 1} ) {
warn "CPAN::Meta::YAML required to process $rulesfile" ;
return;
}
my $layer = $] lt "5.008" ? "" : ":encoding(UTF-8)";
open my $fh, "<$layer", $rulesfile
or die "Couldn't open $rulesfile: $!";
my $yaml_text = do { local $/; <$fh> };
my $yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
$self->rules( $yaml->[0] );
}
return;
}
}
cpan/Test-Simple/lib/Test2/API.pm view on Meta::CPAN
}
# See gh #16
{
no warnings;
INIT { eval 'END { test2_set_is_end() }; 1' or die $@ }
}
BEGIN {
no warnings 'once';
if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
*DO_DEPTH_CHECK = sub() { 1 };
}
else {
*DO_DEPTH_CHECK = sub() { 0 };
}
}
use Test2::EventFacet::Trace();
use Test2::Util::Trace(); # Legacy
cpan/Test-Simple/lib/Test2/Formatter/TAP.pm view on Meta::CPAN
_autoflush($out);
_autoflush($err);
return [$out, $err];
}
sub encoding {
my $self = shift;
if ($] ge "5.007003" and @_) {
my ($enc) = @_;
my $handles = $self->{+HANDLES};
# https://rt.perl.org/Public/Bug/Display.html?id=31923
# If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
# order to avoid the thread segfault.
if ($enc =~ m/^utf-?8$/i) {
binmode($_, ":utf8") for @$handles;
}
else {
cpan/Test-Simple/lib/Test2/Tools/Tiny.pm view on Meta::CPAN
package Test2::Tools::Tiny;
use strict;
use warnings;
BEGIN {
if ($] lt "5.008") {
require Test::Builder::IO::Scalar;
}
}
use Scalar::Util qw/blessed/;
use Test2::Util qw/try/;
use Test2::API qw/context run_subtest test2_stack/;
use Test2::Hub::Interceptor();
cpan/Test-Simple/lib/Test2/Tools/Tiny.pm view on Meta::CPAN
my ($err, $out) = ("", "");
my $handles = test2_stack->top->format->handles;
my ($ok, $e);
{
my ($out_fh, $err_fh);
($ok, $e) = try {
# Scalar refs as filehandles were added in 5.8.
if ($] ge "5.008") {
open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
}
# Emulate scalar ref filehandles with a tie.
else {
$out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT";
$err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR";
}
test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
cpan/Test-Simple/t/HashBase.t view on Meta::CPAN
}
my $pkg = 'main::Const::Test';
is($pkg->do_it, 'const', "worked as expected");
{
local $SIG{__WARN__} = sub { };
*main::Const::Test::FOO = sub { 0 };
}
ok(!$pkg->FOO, "overrode const sub");
{
local $TODO = "known to fail on $]" if $] le "5.006002";
is($pkg->do_it, 'const', "worked as expected, const was constant");
}
BEGIN {
$INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__;
package
main::HBase::Wrapped;
use Test2::Util::HashBase qw/foo bar dup/;
cpan/Test-Simple/t/Legacy/Regression/736_use_ok.t view on Meta::CPAN
}
sub capture(&) {
my $warn;
local $SIG{__WARN__} = sub { $warn = shift };
$_[0]->();
return $warn || "";
}
{
local $TODO = "known to fail on $]" if $] le "5.006002";
my $file = __FILE__;
my $line = __LINE__ + 4;
like(
capture {
local $TODO; # localize $TODO to clear previous assignment, as following use_ok test is expected to pass
use_ok 'MyWarner';
},
qr/^Deprecated! run for your lives! at \Q$file\E line $line/,
"Got the warning"
);
cpan/Test-Simple/t/Legacy/overload_threads.t view on Meta::CPAN
chdir 't';
BEGIN {
# There was a bug with overloaded objects and threads.
# See rt.cpan.org 4218
eval { require threads; 'threads'->import; 1; } if CAN_THREAD;
}
use Test::More;
plan skip_all => "known to crash on $]" if $] le "5.006002";
plan tests => 5;
package Overloaded;
use overload
q{""} => sub { $_[0]->{string} };
sub new {
cpan/Test-Simple/t/Legacy_And_Test2/preload_diag_note.t view on Meta::CPAN
use strict;
use warnings;
if ($] lt "5.008") {
print "1..0 # SKIP Test cannot run on perls below 5.8.0\n";
exit 0;
}
BEGIN {
require Test2::API;
Test2::API::test2_start_preload();
}
use Test::More;
cpan/Test-Simple/t/Test2/behavior/init_croak.t view on Meta::CPAN
use Test2::Util::HashBase qw/foo bar baz/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'foo' is a required attribute"
unless $self->{+FOO};
}
}
skip_all("known to fail on $]") if $] le "5.006002";
$@ = "";
my ($file, $line) = (__FILE__, __LINE__ + 1);
eval { my $one = Foo::Bar->new };
my $err = $@;
like(
$err,
qr/^'foo' is a required attribute at \Q$file\E line $line/,
"Croak does not report to HashBase from init"
cpan/Test-Simple/t/Test2/behavior/nested_context_exception.t view on Meta::CPAN
use strict;
use warnings;
BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 }
use Test2::Tools::Tiny;
use Test2::API qw/context/;
skip_all("known to fail on $]") if $] le "5.006002";
sub outer {
my $code = shift;
my $ctx = context();
$ctx->note("outer");
my $out = eval { $code->() };
$ctx->release;
cpan/Test-Simple/t/Test2/modules/API.t view on Meta::CPAN
my $file = __FILE__;
my $line = __LINE__ + 1;
my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') };
my $sub1 = sub {
like(
$warnings->[0],
qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line},
"got warning about adding driver too late"
);
};
if ($] le "5.006002") {
todo("TODO known to fail on $]", $sub1);
} else {
$sub1->();
}
is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list");
ok($CLASS->can('test2_ipc_polling')->(), "Polling is on");
$CLASS->can('test2_ipc_disable_polling')->();
ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off");
cpan/Test-Simple/t/Test2/modules/API/Breakage.t view on Meta::CPAN
use strict;
use warnings;
if ($] lt "5.008") {
print "1..0 # SKIP Test cannot run on perls below 5.8.0 because local doesn't work on hash keys.\n";
exit 0;
}
use Test2::IPC;
use Test2::Tools::Tiny;
use Test2::API::Breakage;
my $CLASS = 'Test2::API::Breakage';
for my $meth (qw/upgrade_suggested upgrade_required known_broken/) {
cpan/Test-Simple/t/Test2/modules/API/Instance.t view on Meta::CPAN
unless($pid) { sleep 20; exit 0 }
kill('TERM', $pid) or die "Failed to send signal";
@warnings = ();
{
local $SIG{__WARN__} = sub { push @warnings => @_ };
is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
}
like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit");
}
if (CAN_THREAD && $] ge '5.010') {
require threads;
my $one = $CLASS->new;
threads->new(sub { 1 });
is(Test2::API::Instance::_ipc_wait, 0, "No errors");
if (threads->can('error')) {
threads->new(sub {
close(STDERR);
close(STDOUT);
cpan/Test-Simple/t/Test2/modules/API/Instance.t view on Meta::CPAN
my @events;
$one->stack->top->filter(sub { push @events => $_[1]; undef});
$one->stack->new_hub;
local $? = 0;
$one->set_exit;
is($?, 255, "errors on exit");
like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag");
}
SKIP: {
last SKIP if $] lt "5.008";
my $one = $CLASS->new;
my $stderr = "";
{
local $INC{'Test/Builder.pm'} = __FILE__;
local $Test2::API::VERSION = '0.002';
local $Test::Builder::VERSION = '0.001';
local *STDERR;
open(STDERR, '>', \$stderr) or print "Failed to open new STDERR";
$one->set_exit;
cpan/Test-Simple/t/Test2/modules/API/Instance.t view on Meta::CPAN
********************************************************************************
Test2::API Version: 0.002
Test::Builder Version: 0.001
This is not a supported configuration, you will have problems.
EOT
}
SKIP: {
last SKIP if $] lt "5.008";
require Test2::API::Breakage;
no warnings qw/redefine once/;
my $ran = 0;
local *Test2::API::Breakage::report = sub { $ran++; return "foo" };
use warnings qw/redefine once/;
my $one = $CLASS->new;
$one->load();
my $stderr = "";
{
cpan/Test-Simple/t/Test2/modules/Hub.t view on Meta::CPAN
ok(!$?, "child exited with success");
$hub->cull();
$do_check->('Fork');
}
else {
$do_send->();
exit 0;
}
}
if (CAN_THREAD && $] ge '5.010') {
require threads;
my $thr = threads->new(sub { $do_send->() });
$thr->join;
$hub->cull();
$do_check->('Threads');
}
$do_send->();
$hub->cull();
$do_check->('no IPC');
( run in 1.667 second using v1.01-cache-2.11-cpan-cc502c75498 )