Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: nqp-p6
Fetching contributors…

Cannot retrieve contributors at this time

252 lines (190 sloc) 6.338 kb
#! perl
# Copyright (C) 2009-2010, Parrot Foundation.
=head1 NAME
t/tools/pbc_dump.t - test the Parrot Bytecode (PBC) Dumper
=head1 SYNOPSIS
% prove t/tools/pbc_dump.t
=head1 DESCRIPTION
Tests the C<pbc_dump> tool by providing it with a number of source
files, and running through it with various commands.
We never actually check the I<full> output of pbc_dump. We simply check
several smaller components to avoid a test file that is far too unwieldy.
=head1 REQUIREMENTS
This test script requires you to build pbc_dump, by typing
"make parrot_utils" (using a suitable make tool for your platform).
If this requirement has not been met, all tests will be skipped.
=cut
use strict;
use warnings;
use lib qw(lib);
use Test::More;
use Parrot::Config;
use Parrot::Test;
use File::Spec;
use Parrot::Test::Util 'create_tempfile';
my ($path, $exefile);
my $PARROT = ".$PConfig{slash}parrot$PConfig{exe}";
BEGIN {
$path = File::Spec->catfile( ".", "pbc_dump" );
$exefile = $path . $PConfig{exe};
unless ( -f $exefile ) {
plan skip_all => "pbc_dump hasn't been built. Run make parrot_utils";
exit(0);
}
plan tests => 25;
}
dump_output_like( <<PIR, "pir", [qr/CONSTANT_t/, qr/BYTECODE_t/], 'pbc_dump basic sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/HEADER\s*=>\s*\[.*wordsize.*byteorder.*floattype.*parrot-version.*bytecode-version.*UUID.*\]/ms, 'pbc_dump HEADER sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/DIRECTORY\s*=>\s*\[.*offs.*op_count.*itype.*id.*size.*segments/ms, 'pbc_dump DIRECTORY sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/BYTECODE_t.*=>.*\[.*offs.*op_count.*itype.*id.*size.*mappings/ms, 'pbc_dump BYTECODE sanity');
.sub main :main
\$I0 = 42
.end
PIR
for my $enc ( qw(binary iso-8859-1 utf8 utf16 ucs2 ucs4) ) {
dump_output_like( <<PIR, "pir", qr/ENCODING.*=>.*$enc/ms, "pbc_dump $enc encoding");
.sub main :main
\$S0 = $enc:"abc"
.end
PIR
}
my $longcode = ".sub main :main\n";
for (0 ... 10000) {
$longcode .= "\$I0 = \$I0 + 1234\n";
}
$longcode .= ".end";
dump_output_like( $longcode, "pir", qr/BYTECODE.*_DB.*=>/,
"large pir program doesn't mess up pbc_dump");
open my $INC1, '>', "inc_a.pir";
print $INC1 <<'EOF';
.sub does :vtable
.param string provides
.end
EOF
close $INC1;
open my $INC2, '>', "inc_b.pir";
print $INC2 <<'EOF';
.namespace [ 'TclConst' ]
.sub class_init :anon :load
$P0 = get_class 'String'
.end
EOF
close $INC2;
open my $INC3, '>', "inc_c.pir";
print $INC3 <<'EOF';
.namespace [ 'TclDict' ]
.sub class_init :anon :load :main
say "wut"
.end
EOF
close $INC3;
#test known-good hard-coded values. These values come from looking at
#pbc_dump's #output and sanity checking with the locations of the various subs.
dump_output_like( <<PIR, "pir", qr/BYTECODE.*_DB.*OFFSET => 0,.*OFFSET => 7.*OFFSET => 13/ms, 'debug segments contain accurate offsets');
.include 'inc_a.pir'
.include 'inc_b.pir'
.include 'inc_c.pir'
PIR
unlink('inc_a.pir');
unlink('inc_b.pir');
unlink('inc_c.pir');
my $annotated_pir = <<'PIR';
.sub 'main' :main
.annotate 'line', 1
.annotate 'hello', 'world'
.local int i
i = 123
.annotate 'hello', 'dragon'
.annotate 'line', 441
dec i
.annotate 'goodbye', 'cactus'
.end
PIR
dump_output_like($annotated_pir, "pir", qr/_ANN/s, 'dump output contains annotations segments');
dump_output_like($annotated_pir, "pir", qr/NAME => line.*NAME => hello.*NAME => goodbye/s, 'annotation names are present');
dump_output_like($annotated_pir, "pir", qr/dragon/s, 'annotation values are present');
## Test pbc_dump tool
# Test help
my $helpregex = <<OUTPUT;
/pbc_dump - dump or convert parrot bytecode/
OUTPUT
dump_raw_output_like( "--help", $helpregex, "pbc_dump help message --help");
# Run it without params should also trigger the help
dump_raw_output_like( "", $helpregex, "pbc_dump help message (not enough params)");
# Create sample files
my ($pir_i, $pir_file) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 );
my (undef, $pbc_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
my (undef, $pbcpack_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
print $pir_i <<'EOF';
.sub main :main
.const 'String' s = "Hello World"
print s
.end
EOF
close $pir_i;
# Compile them
system($PARROT, '-o', $pbc_file, $pir_file);
# Test -n option
dump_raw_output_like("-n " . $pbc_file, qr/0003: returncc/s, "pbc_dump -n command");
# Test -t option
dump_raw_output_like("-t " . $pbc_file, qr/HEADER.*DIRECTORY.*BYTECODE.*CONSTANT/s, "pbc_dump -t command");
# Test -h option
dump_raw_output_like("-h " . $pbc_file, qr/HEADER/s, "pbc_dump -h command");
# Test -d option
dump_raw_output_like("-d " . $pbc_file, qr/HEADER.*DIRECTORY.*BYTECODE/s, "pbc_dump -d command");
# Test -o option
dump_raw_output_like("-o " . $pbcpack_file . " " . $pbc_file, qr//s, "pbc_dump -o command");
# Test if the generated pbc file really works
my $output = `$PARROT $pbc_file 2>&1`;
is($output, "Hello World", "pbc_dump -o created a file that works");
# Test PackFile_Constant_dump_pmc on packdump.c
($pir_i, $pir_file) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 );
(undef, $pbc_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
print $pir_i <<'EOF';
.sub main :main
$P0 = new ['Hash']
$P0['key';0] = 2
$I0 = 1
$S0 = 'new_key'
$P0[$I0; $S0] = 'value'
print "Hallo Welt"
.end
EOF
close $pir_i;
system($PARROT, '-o', $pbc_file, $pir_file);
dump_raw_output_like("" . $pbc_file, qr/I REGISTER.*S REGISTER/s, "pbc_dump packdump.c");
=head1 HELPER SUBROUTINES
=head2 dump_output_like
dump_output_like(<<PASM, "pasm", "some output", "running $file");
Takes 3-4 arguments: a file to run,
the filename-extension of the file (probably "pir" or "pasm"),
an arrayref or single regex string to match within pbc_dump's output,
and the optional test diagnostic.
=cut
sub dump_output_like {
pbc_postprocess_output_like($path, @_ );
}
sub dump_raw_output_like {
my ($options, $snippet, $desc) = @_;
my $out = `$exefile $options 2>&1`;
like( $out, $snippet, $desc );
return;
}
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
Jump to Line
Something went wrong with that request. Please try again.