my $noplan;
my $Perl; # Safer version of $^X set by which_perl()
+# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
+$::IS_ASCII = ord 'A' == 65;
+$::IS_EBCDIC = ord 'A' == 193;
+
$TODO = 0;
$NO_ENDING = 0;
$Tests_Are_Passing = 1;
skip_all(@_) if is_miniperl();
}
+sub skip_all_without_dynamic_extension {
+ my $extension = shift;
+ skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl();
+ unless (eval {require Config; 1}) {
+ warn "test.pl had problems loading Config: $@";
+ return;
+ }
+ $extension =~ s!::!/!g;
+ return if ($Config::Config{extensions} =~ /\b$extension\b/);
+ skip_all("$extension was not built");
+}
+
+sub skip_all_without_perlio {
+ skip_all('no PerlIO') unless PerlIO::Layer->find('perlio');
+}
+
+sub skip_all_without_config {
+ unless (eval {require Config; 1}) {
+ warn "test.pl had problems loading Config: $@";
+ return;
+ }
+ foreach (@_) {
+ next if $Config::Config{$_};
+ my $key = $_; # Need to copy, before trying to modify.
+ $key =~ s/^use//;
+ $key =~ s/^d_//;
+ skip_all("no $key");
+ }
+}
+
+sub find_git_or_skip {
+ my ($found_dir, $reason);
+ if (-d '.git') {
+ $found_dir = 1;
+ } elsif (-l 'MANIFEST' && -l 'AUTHORS') {
+ my $where = readlink 'MANIFEST';
+ die "Can't readling MANIFEST: $!" unless defined $where;
+ die "Confusing symlink target for MANIFEST, '$where'"
+ unless $where =~ s!/MANIFEST\z!!;
+ if (-d "$where/.git") {
+ # Looks like we are in a symlink tree
+ chdir $where or die "Can't chdir '$where': $!";
+ note("Found source tree at $where");
+ $found_dir = 1;
+ }
+ }
+ if ($found_dir) {
+ my $version_string = `git --version`;
+ if (defined $version_string
+ && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
+ return if eval "v$1 ge v1.5.0";
+ # If you have earlier than 1.5.0 and it works, change this test
+ $reason = "in git checkout, but git version '$1$2' too old";
+ } else {
+ $reason = "in git checkout, but cannot run git";
+ }
+ } else {
+ $reason = 'not being run from a git checkout';
+ }
+ skip_all($reason) if $_[0] && $_[0] eq 'all';
+ skip($reason, @_);
+}
+
sub _ok {
my ($pass, $where, $name, @mess) = @_;
# Do not try to microoptimize by factoring out the "not ".
sub unlike ($$@) { like_yn (1,@_) }; # 1 for un-
sub like_yn ($$$@) {
- my ($flip, $got, $expected, $name, @mess) = @_;
+ my ($flip, undef, $expected, $name, @mess) = @_;
my $pass;
- $pass = $got =~ /$expected/ if !$flip;
- $pass = $got !~ /$expected/ if $flip;
+ $pass = $_[1] =~ /$expected/ if !$flip;
+ $pass = $_[1] !~ /$expected/ if $flip;
unless ($pass) {
- unshift(@mess, "# got '$got'\n",
+ unshift(@mess, "# got '$_[1]'\n",
$flip
? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
}
# run a fresh perl, so we'll brute force launder everything for you
my $sep;
- if (! eval 'require Config; 1') {
+ if (! eval {require Config; 1}) {
warn "test.pl had problems loading Config: $@";
$sep = ':';
} else {
return $Perl if $is_vms;
my $exe;
- if (! eval 'require Config; 1') {
+ if (! eval {require Config; 1}) {
warn "test.pl had problems loading Config: $@";
$exe = '';
} else {
if ($Perl =~ /^perl\Q$exe\E$/i) {
my $perl = "perl$exe";
- if (! eval 'require File::Spec; 1') {
+ if (! eval {require File::Spec; 1}) {
warn "test.pl had problems loading File::Spec: $@";
$Perl = "./$perl";
} else {
_ok( !$diag, _where(), $name );
}
+# Purposefully avoiding a closure.
+sub __capture {
+ push @::__capture, join "", @_;
+}
+
+sub capture_warnings {
+ my $code = shift;
+
+ local @::__capture;
+ local $SIG {__WARN__} = \&__capture;
+ &$code;
+ return @::__capture;
+}
+
+# This will generate a variable number of tests.
+# Use done_testing() instead of a fixed plan.
+sub warnings_like {
+ my ($code, $expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ my @w = capture_warnings($code);
+
+ cmp_ok(scalar @w, '==', scalar @$expect, $name);
+ foreach my $e (@$expect) {
+ if (ref $e) {
+ like(shift @w, $e, $name);
+ } else {
+ is(shift @w, $e, $name);
+ }
+ }
+ if (@w) {
+ diag("Saw these additional warnings:");
+ diag($_) foreach @w;
+ }
+}
+
+sub _fail_excess_warnings {
+ my($expect, $got, $name) = @_;
+ local $Level = $Level + 1;
+ # This will fail, and produce diagnostics
+ is($expect, scalar @$got, $name);
+ diag("Saw these warnings:");
+ diag($_) foreach @$got;
+}
+
+sub warning_is {
+ my ($code, $expect, $name) = @_;
+ die sprintf "Expect must be a string or undef, not a %s reference", ref $expect
+ if ref $expect;
+ local $Level = $Level + 1;
+ my @w = capture_warnings($code);
+ if (@w > 1) {
+ _fail_excess_warnings(0 + defined $expect, \@w, $name);
+ } else {
+ is($w[0], $expect, $name);
+ }
+}
+
+sub warning_like {
+ my ($code, $expect, $name) = @_;
+ die sprintf "Expect must be a regexp object"
+ unless ref $expect eq 'Regexp';
+ local $Level = $Level + 1;
+ my @w = capture_warnings($code);
+ if (@w > 1) {
+ _fail_excess_warnings(0 + defined $expect, \@w, $name);
+ } else {
+ like($w[0], $expect, $name);
+ }
+}
+
# Set a watchdog to timeout the entire test file
# NOTE: If the test file uses 'threads', then call the watchdog() function
# _AFTER_ the 'threads' module is loaded.
# Use a watchdog thread because either 'threads' is loaded,
# or fork() failed
- if (eval 'require threads; 1') {
+ if (eval {require threads; 1}) {
'threads'->create(sub {
# Load POSIX if available
eval { require POSIX; };
https://perl5.git.perl.org / perl5.git / blobdiff