view release on metacpan or  search on metacpan

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

	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.
    my $out;
    if ($name) {
        # escape out '#' or it will interfere with '# skip' and such
        $name =~ s/#/\\#/g;
	$out = $pass ? "ok $test - $name" : "not ok $test - $name";
    } else {
	$out = $pass ? "ok $test" : "not ok $test";
    }

    if ($TODO) {
	$out = $out . " # TODO $TODO";
    } else {
	$Tests_Are_Passing = 0 unless $pass;
    }

    _print "$out\n";

    if ($pass) {
	note @mess; # Ensure that the message is properly escaped.
    }
    else {
	my $msg = "# Failed test $test - ";
	$msg.= "$name " if $name;
	$msg .= "$where\n";
	_diag $msg;
	_diag @mess;
    }

    $test = $test + 1; # don't use ++

    return $pass;
}

sub _where {
    my @caller = caller($Level);
    return "at $caller[1] line $caller[2]";
}

# DON'T use this for matches. Use like() instead.
sub ok ($@) {
    my ($pass, $name, @mess) = @_;
    _ok($pass, _where(), $name, @mess);
}

sub _q {
    my $x = shift;
    return 'undef' unless defined $x;
    my $q = $x;
    $q =~ s/\\/\\\\/g;
    $q =~ s/'/\\'/g;
    return "'$q'";
}

sub _qq {
    my $x = shift;
    return defined $x ? '"' . display ($x) . '"' : 'undef';
};

# keys are the codes \n etc map to, values are 2 char strings such as \n
my %backslash_escape;
foreach my $x (split //, 'nrtfa\\\'"') {
    $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
}
# A way to display scalars containing control characters and Unicode.
# Trying to avoid setting $_, or relying on local $_ to work.
sub display {
    my @result;
    foreach my $x (@_) {
        if (defined $x and not ref $x) {
            my $y = '';
            foreach my $c (unpack("W*", $x)) {
                if ($c > 255) {
                    $y = $y . sprintf "\\x{%x}", $c;
                } elsif ($backslash_escape{$c}) {
                    $y = $y . $backslash_escape{$c};
                } else {
                    my $z = chr $c; # Maybe we can get away with a literal...

                    if ($z !~ /[^[:^print:][:^ascii:]]/) {
                        # The pattern above is equivalent (by de Morgan's
                        # laws) to:
                        #     $z !~ /(?[ [:print:] & [:ascii:] ])/
                        # or, $z is not an ascii printable character

                        # Use octal for characters with small ordinals that
                        # are traditionally expressed as octal: the controls
                        # below space, which on EBCDIC are almost all the
                        # controls, but on ASCII don't include DEL nor the C1
                        # controls.
                        if ($c < ord " ") {
                            $z = sprintf "\\%03o", $c;
                        } else {
                            $z = sprintf "\\x{%x}", $c;
                        }
                    }