view release on metacpan or  search on metacpan

t/roundtrip/test.pl  view on Meta::CPAN

sub set_up_inc {
    # Don’t clobber @INC under miniperl
    @INC = () unless is_miniperl;
    unshift @INC, @_;
}

sub _comment {
    return map { /^#/ ? "$_\n" : "# $_\n" }
           map { split /\n/ } @_;
}

sub _have_dynamic_extension {
    my $extension = shift;
    unless (eval {require Config; 1}) {
	warn "test.pl had problems loading Config: $@";
	return 1;
    }
    $extension =~ s!::!/!g;
    return 1 if ($Config::Config{extensions} =~ /\b$extension\b/);
}

sub skip_all {
    if (@_) {
        _print "1..0 # Skip @_\n";
    } else {
	_print "1..0\n";
    }
    exit(0);
}

sub skip_all_if_miniperl {
    skip_all(@_) if is_miniperl();
}

sub skip_all_without_dynamic_extension {
    my ($extension) = @_;
    skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl();
    return if &_have_dynamic_extension;
    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 skip_all_without_unicode_tables { # (but only under miniperl)
    if (is_miniperl()) {
        skip_all_if_miniperl("Unicode tables not built yet")
            unless eval 'require "unicore/Heavy.pl"';
    }
}

sub find_git_or_skip {
    my ($source_dir, $reason);
    if (-d '.git') {
	$source_dir = '.';
    } 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
	    if (exists $ENV{GIT_DIR}) {
		diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it");
	    } else {
		note("Found source tree at $where, setting \$ENV{GIT_DIR}");
		$ENV{GIT_DIR} = "$where/.git";
	    }
	    $source_dir = $where;
	}
    } elsif (exists $ENV{GIT_DIR}) {
	my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1';
	my $out = `git rev-parse --verify --quiet '$commit^{commit}'`;
	chomp $out;
	if($out eq $commit) {
	    $source_dir = '.'
	}
    }
    if ($source_dir) {
	my $version_string = `git --version`;
	if (defined $version_string
	      && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
	    return $source_dir 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 BAIL_OUT {
    my ($reason) = @_;
    _print("Bail out!  $reason\n");
    exit 255;
}

sub _ok {
    my ($pass, $where, $name, @mess) = @_;
    # Do not try to microoptimize by factoring out the "not ".
    # VMS will avenge.