Index: tools/build/ops2c.pl =================================================================== --- tools/build/ops2c.pl (revision 17419) +++ tools/build/ops2c.pl (working copy) @@ -1,7 +1,42 @@ #! perl # Copyright (C) 2001-2006, The Perl Foundation. # $Id$ +use warnings; +use strict; +use lib 'lib'; +use Parrot::Ops2c::Auxiliary qw( Usage getoptions ); +use Parrot::Ops2c::Utils; +my $flagref = getoptions(); +if ( + (not defined $flagref) or + $flagref->{help} or + (not @ARGV) + ) { + Usage(); + exit 1; +} + +my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => $flagref, + script => $0, +} ); +if (not defined $self) { + Usage(); + exit 1; +} + +$self->print_c_header_file(); + +my $SOURCE = $self->print_c_source_top(); + +my $c_source_final = $self->print_c_source_bottom($SOURCE); + +exit 0; + +#################### DOCUMENTATION #################### + =head1 NAME tools/build/ops2c.pl - Parser for .ops files @@ -78,6 +113,30 @@ =back +=head1 NOTE + +Most of the functionality in F has been extracted into +methods and subroutines found in Parrot::Ops2c::Utils and +Parrot::Ops2c::Auxiliary. This refactoring facilitates unit testing and +coverage analysis of that functionality. A test suite has been provided in +F. It is recommended that future refactoring of this +functionality proceed in a test-driven manner, I tests should be +written reflecting any changes to interface or functionality; the code should +be written which implements the revisions; the code should be tested; and +coverage analysis should be performed with Devel::Cover to measure the extent +to which the tests exercise the code. + +=head1 AUTHORS + +Based on the commit logs, the following members of the Parrot project have +contributed to this program: + + ambs bernhard boemmels brentdax chip + coke dan gregor grunblatt jgoff + jkeenan jonathan josh jrieks leo + mikescott mrjoltcola nicholas particle paultcochrane + petdance rgrjr robert simon + =head1 SEE ALSO =over 4 @@ -102,662 +161,18 @@ =item C +=item C + +=item C + =back =cut -use warnings; -use strict; -use lib 'lib'; - -use Pod::Usage; -use Getopt::Long qw(:config permute); - -use Parrot::OpsFile; -use Parrot::OpLib::core; -use Parrot::Config; - -my %arg_dir_mapping = ( - '' => 'PARROT_ARGDIR_IGNORED', - 'i' => 'PARROT_ARGDIR_IN', - 'o' => 'PARROT_ARGDIR_OUT', - 'io' => 'PARROT_ARGDIR_INOUT' -); - -# -# Look at the command line options -# -sub Usage { - return pod2usage( -exitval => 1, -verbose => 0, -output => \*STDERR ); -} - -my ( $nolines_flag, $help_flag, $dynamic_flag, $core_flag ); -GetOptions( - "no-lines" => \$nolines_flag, - "help" => \$help_flag, - "dynamic|d" => \$dynamic_flag, - "core" => \$core_flag, -) || Usage(); - -Usage() if $help_flag; -Usage() unless @ARGV; - -my $class_name = shift @ARGV; -my %is_allowed = map { $_ => 1 } qw(C CGoto CGP CSwitch CPrederef); -Usage() unless $is_allowed{$class_name}; -my $trans_class = "Parrot::OpTrans::" . $class_name; - -eval "require $trans_class"; - -my $trans = $trans_class->new(); - -# Not used -my $prefix = $trans->prefix(); -my $suffix = $trans->suffix(); - -# Used as ${defines} -my $defines = $trans->defines(); -my $opsarraytype = $trans->opsarraytype(); -my $core_type = $trans->core_type(); - -my $file = $core_flag ? 'core.ops' : shift @ARGV; - -my $base = $file; -$base =~ s/\.ops$//; - -my $incdir = "include/parrot/oplib"; -my $include = "parrot/oplib/${base}_ops${suffix}.h"; -my $header = "include/$include"; - -# SOURCE is closed and reread, which confuses make -j -# create a temp file and rename it -my $source = "src/ops/${base}_ops${suffix}.c.temp"; - -if ( $base =~ m!^src/dynoplibs/! || $dynamic_flag ) { - $source =~ s!src/ops/!!; - $header = "${base}_ops${suffix}.h"; - $base =~ s!^.*[/\\]!!; - $include = "${base}_ops${suffix}.h"; - $dynamic_flag = 1; -} - -my $sym_export = $dynamic_flag ? 'PARROT_DYNEXT_EXPORT' : 'PARROT_API'; - -my %hashed_ops; - -# -# Read the input files: -# - -my $ops; -if ($core_flag) { - $ops = Parrot::OpsFile->new( ["src/ops/$file"], $nolines_flag ); - $ops->{OPS} = $Parrot::OpLib::core::ops; - $ops->{PREAMBLE} = $Parrot::OpLib::core::preamble; -} -else { - my %opsfiles; - my @opsfiles; - - foreach my $opsfile ( $file, @ARGV ) { - if ( $opsfiles{$opsfile} ) { - print STDERR "$0: Ops file '$opsfile' mentioned more than once!\n"; - next; - } - - $opsfiles{$opsfile} = 1; - push @opsfiles, $opsfile; - - die "$0: Could not read ops file '$opsfile'!\n" unless -r $opsfile; - } - - $ops = Parrot::OpsFile->new( \@opsfiles, $nolines_flag ); - - my $cur_code = 0; - for ( @{ $ops->{OPS} } ) { - $_->{CODE} = $cur_code++; - } -} - -my $version = $ops->version; -my $major_version = $ops->major_version; -my $minor_version = $ops->minor_version; -my $patch_version = $ops->patch_version; -my $num_ops = scalar $ops->ops; -my $num_entries = $num_ops + 1; # For trailing NULL - -# -# Open the output files: -# - -if ( !$dynamic_flag && !-d $incdir ) { - mkdir( $incdir, 0755 ) or die "ops2c.pl: Could not mkdir $incdir $!!\n"; -} - -open my $HEADER, '>', $header - or die "ops2c.pl: Cannot open header file '$header' for writing: $!!\n"; - -open my $SOURCE, '>', $source - or die "ops2c.pl: Cannot open source file '$source' for writing: $!!\n"; - -# -# Print the preamble for the HEADER and SOURCE files: -# - -my $preamble = <core_prefix . $base; - -if ( $trans->can("run_core_func_decl") ) { - my $run_core_func = $trans->run_core_func_decl($base); - print $HEADER "$run_core_func;\n"; -} -my $bs = "${base}${suffix}_"; - -# append the C code coda -print $HEADER <preamble($trans); -$text =~ s/\bops_addr\b/${bs}ops_addr/g; -print $SOURCE $text; - -if ( $trans->can("ops_addr_decl") ) { - print $SOURCE $trans->ops_addr_decl($bs); -} -if ( $trans->can("run_core_func_decl") ) { - print $SOURCE $trans->run_core_func_decl($base); - print $SOURCE "\n{\n"; - print $SOURCE $trans->run_core_func_start; -} - -# -# Iterate over the ops, appending HEADER and SOURCE fragments: -# - -my @op_funcs; -my @op_func_table; -my @cg_jump_table; -my $index = 0; -my ( $prev_src, $prev_index ); - -$prev_src = ''; -foreach my $op ( $ops->ops ) { - my $func_name = $op->func_name($trans); - my $arg_types = "$opsarraytype *, Interp *"; - my $prototype = "$sym_export $opsarraytype * $func_name ($arg_types)"; - my $args = "$opsarraytype *cur_opcode, Interp *interp"; - my $definition; - my $comment = ''; - my $one_op = ""; - - if ( $suffix =~ /cg/ ) { - $definition = "PC_$index:"; - $comment = "/* " . $op->full_name() . " */"; - } - elsif ( $suffix =~ /switch/ ) { - $definition = "case $index:"; - $comment = "/* " . $op->full_name() . " */"; - } - else { - $definition = "$prototype;\n$opsarraytype *\n$func_name ($args)"; - } - - my $src = $op->source($trans); - $src =~ s/\bop_lib\b/${bs}op_lib/g; - $src =~ s/\bops_addr\b/${bs}ops_addr/g; - - if ( $suffix =~ /cg/ ) { - if ( $prev_src eq $src ) { - push @cg_jump_table, " &&PC_$prev_index,\n"; - } - else { - push @cg_jump_table, " &&PC_$index,\n"; - } - } - elsif ( $suffix eq '' ) { - push @op_func_table, sprintf( " %-50s /* %6ld */\n", "$func_name,", $index ); - } - if ( $prev_src eq $src ) { - push @op_funcs, "$comment\n"; - } - else { - $one_op .= "$definition $comment {\n$src}\n\n"; - push @op_funcs, $one_op; - $prev_src = $src if ( $suffix eq '_cgp' || $suffix eq '_switch' ); - $prev_index = $index; - } - $index++; -} - -if ( $suffix =~ /cg/ ) { - print $SOURCE @cg_jump_table; - print $SOURCE <run_core_after_addr_table($bs); -} - -if ( $suffix =~ /cgp/ ) { - print $SOURCE <ctx.bp.regs_i; - goto **cur_opcode; - -END_C -} -elsif ( $suffix =~ /cg/ ) { - print $SOURCE <can("run_core_split") ) { - print $SOURCE $trans->run_core_split($base); - } - print $SOURCE $op_funcs[$i]; -} - -if ( $trans->can("run_core_finish") ) { - print $SOURCE $trans->run_core_finish($base); -} - -# -# reset #line in the SOURCE file. -# - -close($SOURCE); -open( $SOURCE, '<', $source ) || die "Error re-reading $source: $!\n"; -my $line = 0; -while (<$SOURCE>) { $line++; } -$line += 2; -close($SOURCE); -open( $SOURCE, '>>', $source ) || die "Error appending to $source: $!\n"; -unless ($nolines_flag) { - my $source_escaped = $source; - $source_escaped =~ s|\.temp||; - $source_escaped =~ s|(\\)|$1$1|g; # escape backslashes - print $SOURCE qq{#line $line "$source_escaped"\n}; -} - -# -# write op_func_func -# - -my ( $op_info, $op_func, $getop ); -$op_info = $op_func = 'NULL'; -$getop = '( int (*)(const char *, int) )NULL'; - -if ( $suffix eq '' ) { - $op_func = "${bs}op_func_table"; - print $SOURCE <ops ) { - my $type = sprintf( "PARROT_%s_OP", uc $op->type ); - my $name = $op->name; - $names{$name} = 1; - my $full_name = $op->full_name; - my $func_name = $op->func_name($trans); - my $body = $op->body; - my $jump = $op->jump || 0; - my $arg_count = $op->size; - - ## 0 inserted if arrays are empty to prevent msvc compiler errors - my $arg_types = "{ " - . join( ", ", - scalar $op->arg_types - ? map { sprintf( "PARROT_ARG_%s", uc $_ ) } $op->arg_types - : 0 ) - . " }"; - my $arg_dirs = "{ " - . join( - ", ", scalar $op->arg_dirs - ? map { $arg_dir_mapping{$_} } $op->arg_dirs - : 0 - ) . " }"; - my $labels = "{ " - . join( - ", ", scalar $op->labels - ? $op->labels - : 0 - ) . " }"; - my $flags = 0; - - print $SOURCE < ", $tot * 1.2, "\n"; - } - print $SOURCE <op_lib->op_code("set", 0) - * interp->op_lib->op_code("set_i_i", 1) - * - * returns >= 0 (found idx into info_table), -1 if not - */ - -static int get_op(const char * name, int full); - -static size_t hash_str(const char * str) { - size_t key = 0; - const char * s; - for(s=str; *s; s++) - key = key * 65599 + *s; - return key; -} - -static void store_op(op_info_t *info, int full) { - HOP * const p = mem_sys_allocate(sizeof(HOP)); - const size_t hidx = - hash_str(full ? info->full_name : info->name) % OP_HASH_SIZE; - p->info = info; - p->next = hop[hidx]; - hop[hidx] = p; -} -static int get_op(const char * name, int full) { - HOP * p; - const size_t hidx = hash_str(name) % OP_HASH_SIZE; - if (!hop) { - hop = mem_sys_allocate_zeroed(OP_HASH_SIZE * sizeof(HOP*)); - hop_init(); - } - for (p = hop[hidx]; p; p = p->next) { - if(!strcmp(name, full ? p->info->full_name : p->info->name)) - return p->info - ${bs}op_lib.op_info_table; - } - return -1; -} -static void hop_init() { - size_t i; - op_info_t * info = ${bs}op_lib.op_info_table; - /* store full names */ - for (i = 0; i < ${bs}op_lib.op_count; i++) - store_op(info + i, 1); - /* plus one short name */ - for (i = 0; i < ${bs}op_lib.op_count; i++) - if (get_op(info[i].name, 0) == -1) - store_op(info + i, 0); -} -static void hop_deinit(void) -{ - HOP *p, *next; - if (hop) { - size_t i; - for (i = 0; i < OP_HASH_SIZE; i++) - for (p = hop[i]; p; ) { - next = p->next; - free(p); - p = next; - } - free(hop); - } - hop = 0; -} - -END_C - -} -else { - print $SOURCE <can("init_func_init1") ) { - $init1_code = $trans->init_func_init1($base); -} - -my $init_set_dispatch = ""; -if ( $trans->can("init_set_dispatch") ) { - $init_set_dispatch = $trans->init_set_dispatch($bs); -} - -print $SOURCE < \$flags{nolines}, + "help" => \$flags{help}, + "dynamic|d" => \$flags{dynamic}, + "core" => \$flags{core}, + ); + return \%flags; +} + +1; + +#################### DOCUMENTATION #################### + +=head1 NAME + +Parrot::Ops2c::Auxiliary - Non-method subroutines holding functionality for +F. + +=head1 SYNOPSIS + + use Parrot::Ops2c::Auxiliary qw( Usage getoptions ); + + Usage(); + + $flagref = getoptions(); + +=cut + +=head1 DESCRIPTION + +Parrot::Ops2c::Auxiliary provides subroutines called by F, a +program which is called at various points in the Parrot F process. +This package is intended to hold subroutines used by that program I the object-oriented methods provided by Parrot::Ops2c::Utils. + +Extraction of the subroutines exported by this package from +F facilitates the testing of their functionality by the +tests in F. + +=head1 SUBROUTINES + +=head2 C + +=over 4 + +=item * Purpose + +Display a short description of how to use F on +standard output. + + usage: tools/build/ops2pm.pl [--help] [--no-lines] input.ops [input2.ops ...] + +=item * Arguments + +None. + +=item * Return Value + +Implicitly returns true upon successful printing. + +=back + +=head2 C + +=over 4 + +=item * Purpose + +Process arguments provided on command-line to F. + +=item * Arguments + +None. + +=item * Return Value + +Hash reference where any of the following keys may or may not be defined. + + no-lines + help + renum + +=item * Comment + +A wrapper around Getopt::Long::GetOptions() designed to assure testability. + +=back + +=head1 AUTHOR + +Jim Keenan (refactoring code originally found in F). + +=head1 SEE ALSO + +=over 4 + +=item * Parrot::Ops2c::Utils. + +=item * F. + +=back + +=cut + Index: lib/Parrot/Ops2c/Utils.pm =================================================================== --- lib/Parrot/Ops2c/Utils.pm (revision 0) +++ lib/Parrot/Ops2c/Utils.pm (revision 0) @@ -0,0 +1,1024 @@ +# Copyright (C) 2007, The Perl Foundation. +# $Id: Utils.pm 17373 2007-03-07 00:58:56Z jkeenan $ +package Parrot::Ops2c::Utils; +use strict; +use lib ("lib/"); +use Parrot::OpLib::core; +use Parrot::OpsFile; + +=head1 NAME + +Parrot::Ops2c::Utils - Methods holding functionality for F. + +=head1 SYNOPSIS + + $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => Parrot::Ops2c::Auxiliary::getoptions(), + script => $0, + } ); + + $c_header = $self->print_c_header_file(); + + $SOURCE = $self->print_c_source_top(); + + $c_source = $self->print_c_source_bottom($SOURCE); + +=head1 DESCRIPTION + +Parrot::Ops2c::Utils provides methods called by F, a +program which is called at various points in the Parrot F process. +The program's function is to create a pair of C header (F<*.h>) and +implementation (F<*.c>) files from the operation definitions found in +one or more F<*.ops> files. + +The functionality originally found in F has been +extracted into this package's methods in order to support component-focused +testing and future refactoring. + +=head1 METHODS + +=head2 C + +=over 4 + +=item * Purpose + +Process command-line arguments provided to F; construct +and initialize a Parrot::Ops2c::Utils object. + +=item * Arguments + +Hash reference with the following elements: + + argv : reference to @ARGV + flag : hash reference which is the return value of + Parrot::Ops2c::Utils::getoptions(); + hash will have keys such as 'core', 'dynamic' or 'nolines' + script : name of the script to be executed by 'make' + (generally, $0 or tools/build/ops2c.pl) + +=item * Return Value + +Parrot::Ops2c::Utils object. At this point, the caller is ready to open a +handle to the C-header file and write to it. + +=item * Comment + +Arguments for the constructor have been selected so as to provide +subsequent methods with all information needed to execute properly and to be +testable. + +=back + +=cut + +sub new { + my ($class, $argsref) = @_; + unless (defined $argsref->{flag}) { + print STDERR "Parrot::Ops2c::Utils::new() requires reference to hash of command-line options: $!"; + return; + } + my $flagref = $argsref->{flag}; + my @argv = @{$argsref->{argv}}; + $argsref->{script} ||= "tools/build/ops2c.pl"; + unless (@argv) { + print STDERR "Parrot::Ops2c::Utils::new() requires 'trans' options: $!"; + return; + }; + my $class_name = shift @argv; + my %is_allowed = map { $_ => 1 } qw(C CGoto CGP CSwitch CPrederef); + unless ($is_allowed{$class_name}) { + print STDERR "Parrot::Ops2c::Utils::new() requires C, CGoto, CGP, CSwitch and/or CPrederef: $!"; + return; + }; + + my $trans_class = "Parrot::OpTrans::" . $class_name; + eval "require $trans_class"; + my $trans = $trans_class->new(); + # Don't yet know how to test the following. + unless (defined $trans) { + print STDERR "Unable to construct $trans object: $!"; + return; + }; + + my $suffix = $trans->suffix(); # Invoked (sometimes) as ${suffix} + + my $file = $flagref->{core} ? 'core.ops' : shift @argv; + my $base = $file; # Invoked (sometimes) as ${base} + $base =~ s/\.ops$//; + my $base_ops_stub = $base . q{_ops} . $suffix; + my $base_ops_h = $base_ops_stub . q{.h}; + + my $incdir = "include/parrot/oplib"; + my $include = "parrot/oplib/$base_ops_h"; + my $header = "include/$include"; + + # SOURCE is closed and reread, which confuses make -j + # create a temp file and rename it + my $source = "src/ops/$base_ops_stub.c.temp"; + + if ( $flagref->{dynamic} ) { + $source =~ s!src/ops/!!; + $header = $base_ops_h; + $base =~ s!^.*[/\\]!!; + $include = $base_ops_h; + $flagref->{dynamic} = 1; + } + + my $sym_export = $flagref->{dynamic} + ? 'PARROT_DYNEXT_EXPORT' + : 'PARROT_API'; + + my $ops; + if ($flagref->{core}) { + $ops = _prepare_core( { + file => $file, + flag => $flagref, + } ); + } + else { + $ops = _prepare_non_core( { + file => $file, + argv => [ @argv ], + flag => $flagref, + script => $argsref->{script}, + } ); + } + + my %versions = ( + major => $ops->major_version, + minor => $ops->minor_version, + patch => $ops->patch_version, + ); + my $num_ops = scalar $ops->ops; + my $num_entries = $num_ops + 1; # For trailing NULL + + if ( ! $flagref->{dynamic} && ! -d $incdir ) { + mkdir( $incdir, 0755 ) + or die "ops2c.pl: Could not mkdir $incdir $!!\n"; + } + + my $preamble = _compose_preamble($file, $argsref->{script}); + + my $init_func = join q{_}, ( + q{Parrot}, + q{DynOp}, + $base . $suffix, + @versions{ qw(major minor patch) }, + ); + + ##### Populate the object ##### + $argsref->{argv} = \@argv; + $argsref->{trans} = $trans; + $argsref->{suffix} = $suffix; + + $argsref->{file} = $file; + $argsref->{base} = $base; + $argsref->{incdir} = $incdir; + $argsref->{include} = $include; + $argsref->{header} = $header; + $argsref->{source} = $source; + $argsref->{sym_export} = $sym_export; + + $argsref->{ops} = $ops; + $argsref->{versions} = \%versions; + $argsref->{num_ops} = $num_ops; + $argsref->{num_entries} = $num_entries; + + $argsref->{preamble} = $preamble; + $argsref->{init_func} = $init_func; + + $argsref->{flag} = $flagref; + return bless $argsref, $class; +} + +sub _prepare_core { + my $argsref = shift; + my $ops = Parrot::OpsFile->new( + [ qq|src/ops/$argsref->{file}| ], + $argsref->{flag}->{nolines}, + ); + $ops->{OPS} = $Parrot::OpLib::core::ops; + $ops->{PREAMBLE} = $Parrot::OpLib::core::preamble; + return $ops; +} + +sub _prepare_non_core { + my $argsref = shift; + my %opsfiles; + my @opsfiles; + + foreach my $f ( $argsref->{file}, @{$argsref->{argv}} ) { + if ( $opsfiles{$f} ) { + print STDERR "$argsref->{script}: Ops file '$f' mentioned more than once!\n"; + next; + } + + $opsfiles{$f} = 1; + push @opsfiles, $f; + + die "$argsref->{script}: Could not read ops file '$f'!\n" unless -r $f; + } + + my $ops = Parrot::OpsFile->new( \@opsfiles, $argsref->{flag}->{nolines} ); + + my $cur_code = 0; + for my $el ( @{ $ops->{OPS} } ) { + $el->{CODE} = $cur_code++; + } + return $ops; +} + +sub _compose_preamble { + my ($file, $script) = @_; + my $preamble = < + +=over 4 + +=item * Purpose + +Creates a C-header file corresponding to a particular op. Such files will +have names like these: + + include/parrot/oplib/core_ops.h + include/parrot/oplib/myops_ops_switch.h + +=item * Arguments + +None. (All data needed is already in the object.) + +=item * Return Value + +Returns the name of the C-header file created. You do not need to capture or +make use of this return value during production, but it has proven useful in +testing. + +=item * Comment + +=back + +=cut + +sub print_c_header_file { + my $self = shift; + + open my $HEADER, '>', $self->{header} + or die "ops2c.pl: Cannot open header file '$self->{header}' for writing: $!!\n"; + + $self->_print_preamble_header($HEADER); + + $self->_print_run_core_func_decl_header($HEADER); + + _print_coda($HEADER); + + close $HEADER or die "Unable to close handle to $self->{header}: $!"; + (-e $self->{header}) or die "$self->{header} not created: $!"; + (-s $self->{header}) or die "$self->{header} has 0 size: $!"; + return $self->{header}; +} + +sub _print_preamble_header { + my ($self, $fh) = @_; + + print $fh $self->{preamble}; + if ($self->{flag}->{dynamic}) { + print $fh "#define PARROT_IN_EXTENSION\n"; + } + print $fh <{sym_export} extern op_lib_t *$self->{init_func}(long init); + +END_C +} + +sub _print_run_core_func_decl_header { + my ($self, $fh) = @_; + + if ( $self->{trans}->can("run_core_func_decl") ) { + my $run_core_func = + $self->{trans}->run_core_func_decl($self->{base}); + print $fh "$run_core_func;\n"; + } else { + return; + } +} + +sub _print_coda { + my $fh = shift; + print $fh < + +=over 4 + +=item * Purpose + +Writes the top half of a C-source file corresponding to a particular op. +Such files will have names like these: + + src/ops/core_ops.c + src/ops/myops_ops_switch.c + +=item * Arguments + +None. (All data needed is already in the object.) + +=item * Return Value + +Returns a still-open filehandle to the C-source file. + +=item * Comment + +B Why does this method write only the top-half of the C-source file +rather than the whole thing? + +B Mainly for convenience in maintenance and testing. +Internally, a handle is opened to the file, the file is written to, and the +handle is closed and returned. That same handle is then re-opened, a line +count on the file so far is taken, the handle is closed, then opened again for +writing the bottom half of the source file. There are quite a few private +methods implementing the first and last of these steps. It made sense to +group these private methods into two public methods corresponding to the two +points where the filehandle is opened and the C-source file is written to. + +B Why return a filehandle? + +B It is re-used as an argument to the next method. + +=back + +=cut + +sub print_c_source_top { + my $self = shift; + $self->{defines} = $self->{trans}->defines(); # Invoked as: ${defines} + $self->{bs} = "$self->{base}$self->{suffix}_"; # Also invoked as ${bs} + $self->{opsarraytype} = $self->{trans}->opsarraytype(); + + ##### BEGIN printing to $SOURCE ##### + open my $SOURCE, '>', $self->{source} + or die "ops2c.pl: Cannot open source file '$self->{source}' for writing: $!!\n"; + + $self->_print_preamble_source($SOURCE); + + $self->_print_ops_addr_decl($SOURCE); + + $self->_print_run_core_func_decl_source($SOURCE); + + # Iterate over the ops, appending HEADER and SOURCE fragments: + $self->_iterate_over_ops(); + + $self->_print_cg_jump_table($SOURCE); + + $self->_print_goto_opcode($SOURCE); + + $self->_print_op_function_definitions($SOURCE); + + return $SOURCE; +} + +sub _print_preamble_source { + my ($self, $fh) = @_; + + print $fh $self->{preamble}; + print $fh <{include}" + +$self->{defines} +static op_lib_t $self->{bs}op_lib; + +END_C + + my $text = $self->{ops}->preamble($self->{trans}); + $text =~ s/\bops_addr\b/$self->{bs}ops_addr/g; + print $fh $text; +} + +sub _print_ops_addr_decl { + my ($self, $fh) = @_; + + if ( $self->{trans}->can("ops_addr_decl") ) { + print $fh $self->{trans}->ops_addr_decl($self->{bs}); + } else { + return; + } +} + +sub _print_run_core_func_decl_source { + my ($self, $fh) = @_; + + if ( $self->{trans}->can("run_core_func_decl") ) { + print $fh $self->{trans}->run_core_func_decl($self->{base}); + print $fh "\n{\n"; + print $fh $self->{trans}->run_core_func_start; + } else { + return; + } +} + +sub _iterate_over_ops { + my $self = shift; + my @op_funcs; + my @op_func_table; + my @cg_jump_table; + my $index = 0; + my ( $prev_src, $prev_index ); + + $prev_src = ''; + foreach my $op ( $self->{ops}->ops ) { + my $func_name = $op->func_name($self->{trans}); + my $arg_types = "$self->{opsarraytype} *, Interp *"; + my $prototype = "$self->{sym_export} $self->{opsarraytype} * $func_name ($arg_types)"; + my $args = "$self->{opsarraytype} *cur_opcode, Interp *interp"; + my $definition; + my $comment = ''; + my $one_op = ""; + + if ( $self->{suffix} =~ /cg/ ) { + $definition = "PC_$index:"; + $comment = "/* " . $op->full_name() . " */"; + } + elsif ( $self->{suffix} =~ /switch/ ) { + $definition = "case $index:"; + $comment = "/* " . $op->full_name() . " */"; + } + else { + $definition = "$prototype;\n$self->{opsarraytype} *\n$func_name ($args)"; + } + + my $src = $op->source($self->{trans}); + $src =~ s/\bop_lib\b/$self->{bs}op_lib/g; + $src =~ s/\bops_addr\b/$self->{bs}ops_addr/g; + + if ( $self->{suffix} =~ /cg/ ) { + if ( $prev_src eq $src ) { + push @cg_jump_table, " &&PC_$prev_index,\n"; + } + else { + push @cg_jump_table, " &&PC_$index,\n"; + } + } + elsif ( $self->{suffix} eq '' ) { + push @op_func_table, sprintf( " %-50s /* %6ld */\n", "$func_name,", $index ); + } + if ( $prev_src eq $src ) { + push @op_funcs, "$comment\n"; + } + else { + $one_op .= "$definition $comment {\n$src}\n\n"; + push @op_funcs, $one_op; + $prev_src = $src if ( $self->{suffix} eq '_cgp' || $self->{suffix} eq '_switch' ); + $prev_index = $index; + } + $index++; + } + $self->{index} = $index; + $self->{op_funcs} = \@op_funcs; + $self->{op_func_table} = \@op_func_table; + $self->{cg_jump_table} = \@cg_jump_table; +} + +sub _print_cg_jump_table { + my ($self, $fh) = @_; + + my @cg_jump_table = @{$self->{cg_jump_table}}; + + if ( $self->{suffix} =~ /cg/ ) { + print $fh @cg_jump_table; + print $fh <{trans}->run_core_after_addr_table($self->{bs}); + } +} + +sub _print_goto_opcode { + my ($self, $fh) = @_; + + if ( $self->{suffix} =~ /cgp/ ) { + print $fh <ctx.bp.regs_i; + goto **cur_opcode; + +END_C + } + elsif ( $self->{suffix} =~ /cg/ ) { + print $fh <{bs}ops_addr[*cur_opcode]; + +END_C + } + return 1; +} + +sub _print_op_function_definitions { + my ($self, $fh) = @_; + + my @op_funcs = @{$self->{op_funcs}}; + print $fh <{trans}->can("run_core_split") ) + { + print $fh $self->{trans}->run_core_split($self->{base}); + } + print $fh $op_funcs[$i]; + } + + if ( $self->{trans}->can("run_core_finish") ) { + print $fh $self->{trans}->run_core_finish($self->{base}); + } + close($fh) || die "Unable to close after writing: $!"; +} + +=head2 C + +=over 4 + +=item * Purpose + +Writes the bottom half of a C-source file corresponding to a particular op. + +=item * Arguments + +One argument: the filehandle returned by C. + +=item * Return Value + +Returns the name of the C-source file created. You do not need to capture or +make use of this return value during production, but it has proven useful in +testing. + +=item * Comment + +=back + +=cut + +sub print_c_source_bottom { + my ($self, $SOURCE) = @_; + my @op_func_table = @{$self->{op_func_table}}; + my $bs = $self->{bs}; + my $index = $self->{index}; + + $SOURCE = $self->_reset_line_number($SOURCE); + + $self->_op_func_table($SOURCE); + + $self->{names} = {}; + $self->_op_info_table($SOURCE); + + $self->_op_lookup($SOURCE); + + $self->_print_op_lib_descriptor($SOURCE); + + $self->_generate_init_func($SOURCE); + + $self->_print_dynamic_lib_load($SOURCE); + + _print_coda($SOURCE); + + close $SOURCE or die "Unable to close handle to $self->{source}: $!"; + + my $c_source_final = $self->_rename_source(); + return $c_source_final; +} + +sub _reset_line_number { + my ($self, $fh) = @_; + + my $source = $self->{source}; + my $line = 0; + open( $fh, '<', $source ) || die "Error re-reading $source: $!\n"; + while (<$fh>) { $line++; } + $line += 2; + close($fh) || die "Error closing $source: $!"; + open( $fh, '>>', $source ) || die "Error appending to $source: $!\n"; + unless ($self->{flag}->{nolines}) { + my $source_escaped = $source; + $source_escaped =~ s|\.temp||; + $source_escaped =~ s|(\\)|$1$1|g; # escape backslashes + print $fh qq{#line $line "$source_escaped"\n}; + } + return $fh; # filehandle remains open +} + +sub _op_func_table { + my ($self, $fh) = @_; + + my ( $op_info, $op_func, $getop ); + $op_info = $op_func = 'NULL'; + $getop = '( int (*)(const char *, int) )NULL'; + + if ( $self->{suffix} eq '' ) { + $op_func = $self->{bs} . q{op_func_table}; + print $fh <{bs}numops$self->{suffix} = $self->{num_ops}; + +/* +** Op Function Table: +*/ + +static op_func$self->{suffix}_t ${op_func}\[$self->{num_entries}] = { +END_C + + print $fh @{$self->{op_func_table}}; + + print $fh <{suffix}_t)0 /* NULL function pointer */ +}; + + +END_C + } + $self->{op_info} = $op_info; + $self->{op_func} = $op_func; + $self->{getop} = $getop; +} + +sub _op_info_table { + my ($self, $fh) = @_; + + my %names = %{$self->{names}}; + my %arg_dir_mapping = ( + '' => 'PARROT_ARGDIR_IGNORED', + 'i' => 'PARROT_ARGDIR_IN', + 'o' => 'PARROT_ARGDIR_OUT', + 'io' => 'PARROT_ARGDIR_INOUT' + ); + + if ( $self->{suffix} eq '' ) { + $self->{op_info} = "$self->{bs}op_info_table"; + + # + # Op Info Table: + # + print $fh <{op_info}\[$self->{num_entries}] = { +END_C + + $self->{index} = 0; + + foreach my $op ( $self->{ops}->ops ) { + my $type = sprintf( "PARROT_%s_OP", uc $op->type ); + my $name = $op->name; + $names{$name} = 1; + my $full_name = $op->full_name; + my $func_name = $op->func_name($self->{trans}); + my $body = $op->body; + my $jump = $op->jump || 0; + my $arg_count = $op->size; + + ## 0 inserted if arrays are empty to prevent msvc compiler errors + my $arg_types = "{ " + . join( ", ", + scalar $op->arg_types + ? map { sprintf( "PARROT_ARG_%s", uc $_ ) } $op->arg_types + : 0 ) + . " }"; + my $arg_dirs = "{ " + . join( + ", ", scalar $op->arg_dirs + ? map { $arg_dir_mapping{$_} } $op->arg_dirs + : 0 + ) . " }"; + my $labels = "{ " + . join( + ", ", scalar $op->labels + ? $op->labels + : 0 + ) . " }"; + my $flags = 0; + + print $fh <{index} */ + /* type $type, */ + "$name", + "$full_name", + "$func_name", + /* "", body */ + $jump, + $arg_count, + $arg_types, + $arg_dirs, + $labels, + $flags + }, +END_C + + $self->{index}++; + } + print $fh <{suffix} eq '' && !$self->{flag}->{dynamic} ) { + $self->{getop} = 'get_op'; + my $hash_size = 3041; + my $tot = $self->{index} + scalar keys(%{$self->{names}}); + if ( $hash_size < $tot * 1.2 ) { + print STDERR "please increase hash_size ($hash_size) in lib/Parrot/Ops2c/Utils.pm " + . "to a prime number > ", $tot * 1.2, "\n"; + } + print $fh <{num_ops} + +#define OP_HASH_SIZE $hash_size + +/* we could calculate a prime somewhat bigger than + * n of fullnames + n of names + * for now this should be ok + * + * look up an op_code: at first call to op_code() a hash + * of short and full opcode names is created + * hash functions are from imcc, thanks to Melvin. + */ + + +typedef struct hop { + op_info_t * info; + struct hop *next; +} HOP; +static HOP **hop; + +static void hop_init(void); +static size_t hash_str(const char * str); +static void store_op(op_info_t *info, int full); + +/* XXX on changing interpreters, this should be called, + through a hook */ + +static void hop_deinit(void); + +/* + * find a short or full opcode + * usage: + * + * interp->op_lib->op_code("set", 0) + * interp->op_lib->op_code("set_i_i", 1) + * + * returns >= 0 (found idx into info_table), -1 if not + */ + +static int get_op(const char * name, int full); + +static size_t hash_str(const char * str) { + size_t key = 0; + const char * s; + for(s=str; *s; s++) + key = key * 65599 + *s; + return key; +} + +static void store_op(op_info_t *info, int full) { + HOP * const p = mem_sys_allocate(sizeof(HOP)); + const size_t hidx = + hash_str(full ? info->full_name : info->name) % OP_HASH_SIZE; + p->info = info; + p->next = hop[hidx]; + hop[hidx] = p; +} +static int get_op(const char * name, int full) { + HOP * p; + const size_t hidx = hash_str(name) % OP_HASH_SIZE; + if (!hop) { + hop = mem_sys_allocate_zeroed(OP_HASH_SIZE * sizeof(HOP*)); + hop_init(); + } + for (p = hop[hidx]; p; p = p->next) { + if(!strcmp(name, full ? p->info->full_name : p->info->name)) + return p->info - $self->{bs}op_lib.op_info_table; + } + return -1; +} +static void hop_init() { + size_t i; + op_info_t * info = $self->{bs}op_lib.op_info_table; + /* store full names */ + for (i = 0; i < $self->{bs}op_lib.op_count; i++) + store_op(info + i, 1); + /* plus one short name */ + for (i = 0; i < $self->{bs}op_lib.op_count; i++) + if (get_op(info[i].name, 0) == -1) + store_op(info + i, 0); +} +static void hop_deinit(void) +{ + HOP *p, *next; + if (hop) { + size_t i; + for (i = 0; i < OP_HASH_SIZE; i++) + for (p = hop[i]; p; ) { + next = p->next; + free(p); + p = next; + } + free(hop); + } + hop = 0; +} + +END_C + } else { + print $fh <{trans}->core_type(); + print $fh <{bs}op_lib = { + "$self->{base}", /* name */ + "$self->{suffix}", /* suffix */ + $core_type, /* core_type = PARROT_XX_CORE */ + 0, /* flags */ + $self->{versions}->{major}, /* major_version */ + $self->{versions}->{minor}, /* minor_version */ + $self->{versions}->{patch}, /* patch_version */ + $self->{num_ops}, /* op_count */ + $self->{op_info}, /* op_info_table */ + $self->{op_func}, /* op_func_table */ + $self->{getop} /* op_code() */ +}; + +END_C +} + +sub _generate_init_func { + my ($self, $fh) = @_; + + my $init1_code = ""; + if ( $self->{trans}->can("init_func_init1") ) { + $init1_code = $self->{trans}->init_func_init1($self->{base}); + } + + my $init_set_dispatch = ""; + if ( $self->{trans}->can("init_set_dispatch") ) { + $init_set_dispatch + = $self->{trans}->init_set_dispatch($self->{bs}); + } + + print $fh <{init_func}(long init) { + /* initialize and return op_lib ptr */ + if (init == 1) { +$init1_code + return &$self->{bs}op_lib; + } + /* set op_lib to the passed ptr (in init) */ + else if (init) { +$init_set_dispatch + } + /* deinit - free resources */ + else { + hop_deinit(); + } + return NULL; +} + +END_C +} + +sub _print_dynamic_lib_load { + my ($self, $fh) = @_; + + if ($self->{flag}->{dynamic}) { + my $load_func = join q{_}, ( + q{Parrot}, + q{lib}, + $self->{base}, + (q{ops} . $self->{suffix}), + q{load}, + ); + print $fh <{sym_export} PMC* +$load_func(Parrot_Interp interp) +{ + PMC *lib = pmc_new(interp, enum_class_ParrotLibrary); + PMC_struct_val(lib) = (void *) $self->{init_func}; + dynop_register(interp, lib); + return lib; +} +END_C + } +} + +sub _rename_source { + my $self = shift; + + my $final = $self->{source}; + $final =~ s/\.temp//; + rename $self->{source}, $final + or die "Unable to rename $self->{source} to $final: $!"; + return $final; +} + +1; + +=head1 DEPENDENCIES + +=over 4 + +=item * Parrot::OpsFile + +=item * Parrot::OpLib::core + +This package is not part of the Parrot distribution. It is created during +Parrot's F process before the first invocation of F. + +=back + +=head1 AUTHOR + +See F for a list of the Parrot hackers who, over a +period of several years, developed the functionality now found in the methods +of Parrot::Ops2c::Utils. Jim Keenan extracted that functionality and placed +it in this package's methods. + +=head1 SEE ALSO + +=over 4 + +=item * F + +=item * Parrot::OpsFile + +=item * Parrot::Ops2c::Auxiliary + +=back + +=cut Index: lib/Parrot/IO/Capture/Mini.pm =================================================================== --- lib/Parrot/IO/Capture/Mini.pm (revision 0) +++ lib/Parrot/IO/Capture/Mini.pm (revision 0) @@ -0,0 +1,70 @@ +# Copyright (C) 2007, The Perl Foundation. +# $Id: Mini.pm 17373 2007-03-07 00:58:56Z jkeenan $ +package Parrot::IO::Capture::Mini; +use strict; + +sub TIEHANDLE { + my $class = shift; + bless [], $class; +} + +sub PRINT { + my $self = shift; + push @$self, join '',@_; +} + +sub READLINE { + my $self = shift; + return wantarray ? @$self : shift @$self; +} + +1; + +################### DOCUMENTATION ################### + +=head1 NAME + +Parrot::IO::Capture::Mini - capture messages printed to STDOUT or STDERR during Parrot testing + +=head1 SYNOPSIS + + use Parrot::IO::Capture::Mini; + +Tie C or C. + + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" or croak "Unable to tie"; + +Call a function which is likely to generate a warning or error message. + + $self = Parrot::Ops2c::Utils->new( { + argv => [ qw( CSwitch dan.ops dan.ops ) ], + flag => { dynamic => 1 }, + } ); + +Store what was captured in a variable, then C. + + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + +Use that variable in a test. + + like($msg, + qr/Ops file 'dan\.ops' mentioned more than once!/, + "Got expected error message about mentioning same file twice"); + +=head1 DESCRIPTION + +This package provides the bare minimum level of functionality needed to +capture messages printed to C or C by Parrot build tools +written in Perl 5. + +=head1 AUTHOR + +Adapted by Jim Keenan from CPAN module IO::Capture::Tie_STDx. Thanks as +always to the authors of IO::Capture, Mark Reynolds and Jon Morgan! + +=head1 SEE ALSO + +IO::Capture (L). + +=cut Index: t/tools/ops2cutils/04-print_c_source_top.t =================================================================== --- t/tools/ops2cutils/04-print_c_source_top.t (revision 0) +++ t/tools/ops2cutils/04-print_c_source_top.t (revision 0) @@ -0,0 +1,117 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 04-print_c_source_top.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 04-print_c_source_top.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 27; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + test_print_c_source_top( [ qw( C ) ] ); + test_print_c_source_top( [ qw( CGoto ) ] ); + test_print_c_source_top( [ qw( CGP ) ] ); + test_print_c_source_top( [ qw( CSwitch ) ] ); + test_print_c_source_top( [ qw( C CGoto CGP CSwitch CPrederef ) ] ); + + ok(chdir($cwd), "returned to starting directory"); +} + +sub test_print_c_source_top { + my $local_argv_ref = shift; + { + my $self = Parrot::Ops2c::Utils->new( { + argv => $local_argv_ref, + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided with argument(s): @{$local_argv_ref}"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + } +} + +pass("Completed all tests in $0"); + +################### DOCUMENTATION ################### + +=head1 NAME + +04-print_c_source_top.t - test C + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/04-print_c_source_top.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<04-print_c_source_top.t> tests whether +C work properly. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + Index: t/tools/ops2cutils/09-dynamic_nolines.t =================================================================== --- t/tools/ops2cutils/09-dynamic_nolines.t (revision 0) +++ t/tools/ops2cutils/09-dynamic_nolines.t (revision 0) @@ -0,0 +1,134 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 09-dynamic_nolines.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 09-dynamic_nolines.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 63; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; +my @dynopsfiles = qw( src/dynoplibs/dan.ops src/dynoplibs/myops.ops ); + + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + foreach my $f (@dynopsfiles) { + copy (qq{$cwd/$f}, qq{$tdir/$f}); + } + chdir "src/dynoplibs" or croak "Unable to change to src/dynoplibs: $!"; + + test_dynops_nolines( [ qw( CGoto myops.ops ) ] ); + test_dynops_nolines( [ qw( CGP myops.ops ) ] ); + test_dynops_nolines( [ qw( C myops.ops ) ] ); + test_dynops_nolines( [ qw( CSwitch myops.ops ) ] ); + test_dynops_nolines( [ qw( CGoto dan.ops ) ] ); + test_dynops_nolines( [ qw( CGP dan.ops ) ] ); + test_dynops_nolines( [ qw( C dan.ops ) ] ); + test_dynops_nolines( [ qw( CSwitch dan.ops ) ] ); + + ok(chdir($cwd), "returned to starting directory"); +} + +pass("Completed all tests in $0"); + +sub test_dynops_nolines { + my $local_argv_ref = shift; + { + my $self = Parrot::Ops2c::Utils->new( { + argv => $local_argv_ref, + flag => { dynamic => 1, nolines => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + + my $c_source_final; + ok($c_source_final = $self->print_c_source_bottom($SOURCE), + "print_c_source_bottom() returned successfully"); + ok(-e $c_source_final, "$c_source_final created"); + ok(-s $c_source_final, "$c_source_final has non-zero size"); + } +} + +################### DOCUMENTATION ################### + +=head1 NAME + +09-dynamic_nolines.t - test C<--nolines> option to F. + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/09-dynamic_nolines.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<09-dynamic_nolines.t> tests whether +C work properly when the C<--nolines> and +C<--dynamic> options are passed to F. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + Index: t/tools/ops2cutils/02-usage.t =================================================================== --- t/tools/ops2cutils/02-usage.t (revision 0) +++ t/tools/ops2cutils/02-usage.t (revision 0) @@ -0,0 +1,138 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 02-usage.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 02-usage.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 30; +use Carp; +use Cwd; +use_ok( "Parrot::IO::Capture::Mini" ); +use_ok( 'Parrot::Ops2c::Auxiliary', qw| Usage getoptions | ); + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); +my ($msg, $tie, @lines); +{ + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" + or croak "Unable to tie"; + my $rv = Usage(); + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + is($rv, 1, "Usage() returned"); + like($msg, + qr|^ + \s*%\sperl\stools\/build\/ops2c\.pl\strans.* + trans\s:=.* + For\sexample.* + core.* + dynamic.* + |msx, + "Got expected usage message"); +} + +{ + local @ARGV = qw( --no-lines ); + my $flagsref = getoptions(); + ok($flagsref->{nolines}, "no-lines option detected"); + ok(! defined $flagsref->{help}, "help option not defined"); + ok(! defined $flagsref->{dynamic}, "dynamic option not defined"); + ok(! defined $flagsref->{core}, "core option not defined"); +} + +{ + local @ARGV = (); + my $flagsref = getoptions(); + ok(! defined $flagsref->{nolines}, "no-lines option not defined"); + ok(! defined $flagsref->{help}, "help option not defined"); + ok(! defined $flagsref->{dynamic}, "dynamic option not defined"); + ok(! defined $flagsref->{core}, "core option not defined"); +} + +{ + local @ARGV = qw( --no-lines --help --core ); + my $flagsref = getoptions(); + ok($flagsref->{nolines}, "no-lines option detected"); + ok($flagsref->{help}, "help option detected"); + ok(! defined $flagsref->{dynamic}, "dynamic option not defined"); + ok($flagsref->{core}, "core option detected"); +} + +{ + local @ARGV = qw( --dynamic ); + my $flagsref = getoptions(); + ok(! defined $flagsref->{nolines}, "no-lines option not defined"); + ok(! defined $flagsref->{help}, "help option not defined"); + ok(defined $flagsref->{dynamic}, "dynamic option defined"); + ok(! defined $flagsref->{core}, "core option not defined"); +} + +{ + local @ARGV = qw( --d ); + my $flagsref = getoptions(); + ok(! defined $flagsref->{nolines}, "no-lines option not defined"); + ok(! defined $flagsref->{help}, "help option not defined"); + ok(defined $flagsref->{dynamic}, "dynamic option defined"); + ok(! defined $flagsref->{core}, "core option not defined"); +} + +{ + local @ARGV = qw( --no-lines --help --core --d ); + my $flagsref = getoptions(); + ok($flagsref->{nolines}, "no-lines option detected"); + ok($flagsref->{help}, "help option detected"); + ok(defined $flagsref->{dynamic}, "dynamic option defined"); + ok($flagsref->{core}, "core option detected"); +} + +pass("Completed all tests in $0"); + +################### DOCUMENTATION ################### + +=head1 NAME + +02-usage.t - test C and + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/02-usage.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<02-usage.t> tests whether C +and F work properly. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut Index: t/tools/ops2cutils/testlib/GenerateCore.pm =================================================================== --- t/tools/ops2cutils/testlib/GenerateCore.pm (revision 0) +++ t/tools/ops2cutils/testlib/GenerateCore.pm (revision 0) @@ -0,0 +1,170 @@ +# Copyright (C) 2007, The Perl Foundation. +# $Id: GenerateCore.pm 17373 2007-03-07 00:58:56Z jkeenan $ +package GenerateCore; +use strict; +our (@ISA, @EXPORT_OK); +@ISA = qw(Exporter); +@EXPORT_OK = qw( + generate_core +); +use Carp; +use File::Copy; +use lib ( "./lib" ); +use Parrot::Ops2pm::Utils; + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +sub generate_core { + my ($cwd, $tdir, $srcopsref, $num_file, $skip_file) = @_; + my @srcopsfiles = @$srcopsref; + mkdir qq{$tdir/src}; + mkdir qq{$tdir/src/ops}; + mkdir qq{$tdir/src/dynoplibs}; + + foreach my $f (@srcopsfiles) { + copy(qq{$cwd/$f}, qq{$tdir/$f}); + } + copy(qq{$cwd/$num}, qq{$tdir/$num}); + copy(qq{$cwd/$skip}, qq{$tdir/$skip}); + my @opsfiles = glob("./src/ops/*.ops"); + + mkdir qq{$tdir/lib}; + mkdir qq{$tdir/lib/Parrot}; + mkdir qq{$tdir/lib/Parrot/Ops2c}; + mkdir qq{$tdir/include}; + mkdir qq{$tdir/include/parrot}; + mkdir qq{$tdir/include/parrot/oplib}; + + my $o2p = Parrot::Ops2pm::Utils->new( { + argv => [ @opsfiles ], + script => "tools/build/ops2pm.pl", + moddir => "lib/Parrot/OpLib", + module => "core.pm", + } ); + + $o2p->prepare_ops(); + $o2p->load_op_map_files(); + $o2p->sort_ops(); + $o2p->prepare_real_ops(); + $o2p->print_module(); + + croak "Temporary core.pm file not written" + unless (-f qq|$tdir/$o2p->{moddir}/$o2p->{module}|); + return qq{$tdir/lib}; +} + +1; + +################### DOCUMENTATION ################### + +=head1 NAME + +GenerateCore - functionality used in testing Parrot::Ops2c::Utils + +=head1 SYNOPSIS + + use lib ("t/tools/ops2cutils/testlib"); + use GenerateCore qw| generate_core |; + + @srcopsfiles = qw( + src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops + src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops + src/ops/math.ops src/ops/object.ops src/ops/pic.ops + src/ops/pmc.ops src/ops/set.ops src/ops/stack.ops + src/ops/stm.ops src/ops/string.ops src/ops/sys.ops + src/ops/var.ops + ); + + $num = "src/ops/ops.num"; + $skip = "src/ops/ops.skip"; + + $cwd = cwd(); + $tdir = tempdir( CLEANUP => 1 ); + + $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + +=head1 DESCRIPTION + +=head2 Purpose + +The test suite found in F tests the methods of +Parrot::Ops2c::Utils. Those methods are invoked by Parrot build tool +F, which in turn is invoked several times by F. +Parrot::Ops2c::Utils has as a prerequisite Parrot::OpLib::core. But +Parrot::OpLib::core is not part of the Parrot distribution, nor does it exist +at the point F is called. Rather, it is created +during the Parrot build process prior to the first call to F. + +To test Parrot::Ops2c::Utils therefore requires a module which does not exist +'pre-F'. The tests in this suite, however, are designed to be run when +your filesystem is in a 'post-F, pre-F' state. The +solution to this conundrum is to create a copy of Parrot::OpLib::core which +exists only for the duration of a single test file. + +This package, GenerateCore, exports upon request a single subroutine, +C, which (a) creates subdirectories needed underneath a +temporary directory created solely for testing purposes; then +(b) creates a temporary copy of Parrot::OpLib::core such that +C can successfully execute. + +=head2 C + +=over 4 + +=item * B (See above.) + +=item * B Five scalar arguments, in this order: + + cwd : String with full path of directory from which + tests are invoked (generally, the top-level + Parrot directory). + tdir : String holding full path of temporary + directory into which you have changed for + testing. + \@srcopsfiles : Reference to an array of F<.ops> files + (generally, the list of arguments to ops2c.pl + as invoked by make). + $num : Path to ops.num file. + $skip : Path to ops.skip file. + +=item * B String holding full path to a directory F +found one level underneath the temporary directory denoted by F above. +(This is the directory underneath which the temporary copy of +Parrot::OpLib::core is created.) The return value may be used in testing as a +marker for the creation of all the needed temporary subdirectories and the +temporary copy of Parrot::OpLib::core. + +=back + +=head1 DEPENDENCIES + +=over 4 + +=item * File::Copy + +=item * Parrot::Ops2c::Utils + +=back + +=head1 AUTHOR + +James E Keenan (jkeenan@cpan.org). + +=head1 SEE ALSO + +=over 4 + +=item * Parrot::Ops2c::Utils + +=item * F + +=back + +=cut Index: t/tools/ops2cutils/05-print_c_source_bottom.t =================================================================== --- t/tools/ops2cutils/05-print_c_source_bottom.t (revision 0) +++ t/tools/ops2cutils/05-print_c_source_bottom.t (revision 0) @@ -0,0 +1,126 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 05-print_c_source_bottom.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 05-print_c_source_bottom.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 42; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); +my ($msg, $tie); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + test_print_c_source_bottom( [ qw( C ) ] ); + test_print_c_source_bottom( [ qw( CGoto ) ] ); + test_print_c_source_bottom( [ qw( CGP ) ] ); + test_print_c_source_bottom( [ qw( CSwitch ) ] ); + test_print_c_source_bottom( [ qw( C CGoto CGP CSwitch CPrederef ) ] ); + + ok(chdir($cwd), "returned to starting directory"); +} + + +pass("Completed all tests in $0"); + +sub test_print_c_source_bottom { + my $local_argv_ref = shift; + { + my $self = Parrot::Ops2c::Utils->new( { + argv => $local_argv_ref, + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided with argument(s): @{$local_argv_ref}"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + + my $c_source_final; + ok($c_source_final = $self->print_c_source_bottom($SOURCE), + "print_c_source_bottom() returned successfully"); + ok(-e $c_source_final, "$c_source_final created"); + ok(-s $c_source_final, "$c_source_final has non-zero size"); + } +} + +################### DOCUMENTATION ################### + +=head1 NAME + +05-print_c_source_bottom.t - test +C + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/05-print_c_source_bottom.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<05-print_c_source_bottom.t> tests whether +C work properly. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + Index: t/tools/ops2cutils/03-print_c_header_file.t =================================================================== --- t/tools/ops2cutils/03-print_c_header_file.t (revision 0) +++ t/tools/ops2cutils/03-print_c_header_file.t (revision 0) @@ -0,0 +1,130 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 03-print_c_header_file.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 03-print_c_header_file.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 25; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + + test_single_trans_and_header(q{C}); + test_single_trans_and_header(q{CGoto}); + test_single_trans_and_header(q{CGP}); + test_single_trans_and_header(q{CSwitch}); + test_single_trans_and_header(q{CPrederef}); + + { + local @ARGV = qw( C CGoto CGP CSwitch CPrederef ); + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + } + + ok(chdir($cwd), "returned to starting directory"); +} + + +pass("Completed all tests in $0"); + +sub test_single_trans_and_header { + my $trans = shift; + my %available = map {$_, 1} qw( C CGoto CGP CSwitch CPrederef ); + croak "Bad argument $trans to test_single_trans()" + unless $available{$trans}; + + my $self = Parrot::Ops2c::Utils->new( { + argv => [ $trans ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correct when provided with single argument $trans"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); +} + +################### DOCUMENTATION ################### + +=head1 NAME + +03-print_c_header_file.t - test C + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/03-print_c_header_file.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<03-print_c_header_file.t> tests whether +C works properly. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut Index: t/tools/ops2cutils/01-new.t =================================================================== --- t/tools/ops2cutils/01-new.t (revision 0) +++ t/tools/ops2cutils/01-new.t (revision 0) @@ -0,0 +1,201 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 01-new.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 01-new.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 21; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "Parrot::IO::Capture::Mini" ); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); +my ($msg, $tie); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + { + local @ARGV = qw(); + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" + or croak "Unable to tie"; + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => {}, + } ); + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + ok(! defined $self, + "Constructor correctly returned undef due to lack of command-line arguments"); + like($msg, + qr/^Parrot::Ops2c::Utils::new\(\) requires 'trans' options/, + "Error message is correct"); + } + + { + local @ARGV = qw( gobbledygook ); + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" + or croak "Unable to tie"; + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => {}, + } ); + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + ok(! defined $self, + "Constructor correctly returned undef due to bad class name command-line argument"); + like($msg, + qr/Parrot::Ops2c::Utils::new\(\) requires C, CGoto, CGP, CSwitch and\/or CPrederef/, + "Got correct error message"); + } + + test_single_trans(q{C}); + test_single_trans(q{CGoto}); + test_single_trans(q{CGP}); + test_single_trans(q{CSwitch}); + test_single_trans(q{CPrederef}); + + { + local @ARGV = qw( C CGoto CGP CSwitch CPrederef ); + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + } + + { + local @ARGV = qw( C CGoto CGP CSwitch CPrederef ); + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => { core => 1 }, + script => "tools/build/ops2c.pl", + } ); + ok(defined $self, + "Constructor correctly returned when provided with explicit 'script' argument"); + } + + { + local @ARGV = qw( C ); + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" + or croak "Unable to tie"; + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + } ); + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + ok(! defined $self, + "Constructor correctly returned undef when lacking reference to options"); + like($msg, + qr/^Parrot::Ops2c::Utils::new\(\) requires reference to hash of command-line options/, + "Error message correctly returned"); + } + + ok(chdir($cwd), "returned to starting directory"); +} + +pass("Completed all tests in $0"); + +sub test_single_trans { + my $trans = shift; + my %available = map {$_, 1} qw( C CGoto CGP CSwitch CPrederef ); + croak "Bad argument $trans to test_single_trans()" + unless $available{$trans}; + + my $self = Parrot::Ops2c::Utils->new( { + argv => [ $trans ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correct when provided with single argument $trans"); +} + +################### DOCUMENTATION ################### + +=head1 NAME + +01-new.t - test C + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/01-new.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<01-new.t> tests whether C +works properly. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + +__END__ + +#$VAR1 = []; +#$VAR2 = bless( { +# 'split_count' => 0 +# }, 'Parrot::OpTrans::CSwitch' ); +#$VAR3 = '_switch'; +#/usr/local/bin/perl tools/build/vtable_extend.pl +#/usr/local/bin/perl tools/build/ops2c.pl CGoto --core +#$VAR1 = []; +#$VAR2 = bless( {}, 'Parrot::OpTrans::CGoto' ); +#$VAR3 = '_cg'; +#/usr/local/bin/perl tools/build/ops2c.pl CGP --core +#$VAR1 = []; +#$VAR2 = bless( {}, 'Parrot::OpTrans::CGP' ); +#$VAR3 = '_cgp'; Index: t/tools/ops2cutils/06-dynamic.t =================================================================== --- t/tools/ops2cutils/06-dynamic.t (revision 0) +++ t/tools/ops2cutils/06-dynamic.t (revision 0) @@ -0,0 +1,165 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 06-dynamic.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 06-dynamic.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 72; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use_ok( 'Parrot::IO::Capture::Mini' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; +my @dynopsfiles = qw( src/dynoplibs/dan.ops src/dynoplibs/myops.ops ); + + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); +my ($msg, $tie); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + foreach my $f (@dynopsfiles) { + copy (qq{$cwd/$f}, qq{$tdir/$f}); + } + chdir "src/dynoplibs" or croak "Unable to change to src/dynoplibs: $!"; + + test_dynops( [ qw( CGoto myops.ops ) ] ); + test_dynops( [ qw( CGP myops.ops ) ] ); + test_dynops( [ qw( C myops.ops ) ] ); + test_dynops( [ qw( CSwitch myops.ops ) ] ); + test_dynops( [ qw( CGoto dan.ops ) ] ); + test_dynops( [ qw( CGP dan.ops ) ] ); + test_dynops( [ qw( C dan.ops ) ] ); + test_dynops( [ qw( CSwitch dan.ops ) ] ); + + { + $tie = tie *STDERR, "Parrot::IO::Capture::Mini" + or croak "Unable to tie"; + my $self = Parrot::Ops2c::Utils->new( { + argv => [ qw( CSwitch dan.ops dan.ops ) ], + flag => { dynamic => 1 }, + } ); + $msg = $tie->READLINE; + untie *STDERR or croak "Unable to untie"; + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + like($msg, + qr/Ops file 'dan\.ops' mentioned more than once!/, + "Error message is correct"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + + my $c_source_final; + ok($c_source_final = $self->print_c_source_bottom($SOURCE), + "print_c_source_bottom() returned successfully"); + ok(-e $c_source_final, "$c_source_final created"); + ok(-s $c_source_final, "$c_source_final has non-zero size"); + } + + ok(chdir($cwd), "returned to starting directory"); +} + +sub test_dynops { + my $local_argv_ref = shift; + { + my $self = Parrot::Ops2c::Utils->new( { + argv => $local_argv_ref, + flag => { dynamic => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + + my $c_source_final; + ok($c_source_final = $self->print_c_source_bottom($SOURCE), + "print_c_source_bottom() returned successfully"); + ok(-e $c_source_final, "$c_source_final created"); + ok(-s $c_source_final, "$c_source_final has non-zero size"); + } +} + +pass("Completed all tests in $0"); + + +################### DOCUMENTATION ################### + +=head1 NAME + +06-dynamic.t - test C<--dynamic> flag to F + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/06-dynamic.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<06-dynamic.t> tests how well +C works when the C<--dynamic> flag is passed to +F. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut Index: t/tools/ops2cutils/07-make_incdir.t =================================================================== --- t/tools/ops2cutils/07-make_incdir.t (revision 0) +++ t/tools/ops2cutils/07-make_incdir.t (revision 0) @@ -0,0 +1,146 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 07-make_incdir.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 07-make_incdir.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 7; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib", "./lib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + mkdir qq{$tdir/src}; + mkdir qq{$tdir/src/ops}; + mkdir qq{$tdir/src/dynoplibs}; + + foreach my $f (@srcopsfiles) { + copy(qq{$cwd/$f}, qq{$tdir/$f}); + } + copy(qq{$cwd/$num}, qq{$tdir/$num}); + copy(qq{$cwd/$skip}, qq{$tdir/$skip}); + my @opsfiles = glob("./src/ops/*.ops"); + + mkdir qq{$tdir/lib}; + mkdir qq{$tdir/lib/Parrot}; + mkdir qq{$tdir/lib/Parrot/Ops2c}; + mkdir qq{$tdir/include}; + mkdir qq{$tdir/include/parrot}; +# mkdir qq{$tdir/include/parrot/oplib}; + + my $o2p = Parrot::Ops2pm::Utils->new( { + argv => [ @opsfiles ], + script => "tools/build/ops2pm.pl", + moddir => "lib/Parrot/OpLib", + module => "core.pm", + } ); + + $o2p->prepare_ops(); + $o2p->load_op_map_files(); + $o2p->sort_ops(); + $o2p->prepare_real_ops(); + $o2p->print_module(); + + croak "Temporary core.pm file not written" + unless (-f qq|$tdir/$o2p->{moddir}/$o2p->{module}|); + + my $tlib = qq{$tdir/lib}; + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + { + local @ARGV = qw( C CGoto CGP CSwitch CPrederef ); + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned even though include/parrot/oplib had to be created"); + } +} + +pass("Completed all tests in $0"); + +sub test_single_trans { + my $trans = shift; + my %available = map {$_, 1} qw( C CGoto CGP CSwitch CPrederef ); + croak "Bad argument $trans to test_single_trans()" + unless $available{$trans}; + + my $self = Parrot::Ops2c::Utils->new( { + argv => [ $trans ], + flag => { core => 1 }, + } ); + ok(defined $self, + "Constructor correct when provided with single argument $trans"); +} + +################### DOCUMENTATION ################### + +=head1 NAME + +07-make_incdir.t - test C + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/07-make_incdir.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<07-make_incdir.t> tests whether C +works properly when F was not previously created.. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + Index: t/tools/ops2cutils/08-nolines.t =================================================================== --- t/tools/ops2cutils/08-nolines.t (revision 0) +++ t/tools/ops2cutils/08-nolines.t (revision 0) @@ -0,0 +1,116 @@ +#! perl +# Copyright (C) 2007, The Perl Foundation. +# $Id: 08-nolines.t 17373 2007-03-07 00:58:56Z jkeenan $ +# 08-nolines.t + +use strict; +use warnings; +BEGIN { + use FindBin qw($Bin); + use Cwd qw(cwd realpath); + realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; + our $topdir = $1; + if (defined $topdir) { + print "\nOK: Parrot top directory located\n"; + } else { + $topdir = realpath($Bin) . "/../../.."; + } + unshift @INC, qq{$topdir/lib}; +} +use Test::More tests => 14; +use Carp; +use Cwd; +use File::Copy; +use File::Temp (qw| tempdir |); +use_ok( 'Parrot::Ops2pm::Utils' ); +use lib ("$main::topdir/t/tools/ops2cutils/testlib"); +use_ok( "GenerateCore", qw| generate_core | ); + +my @srcopsfiles = qw( src/ops/core.ops src/ops/bit.ops src/ops/cmp.ops +src/ops/debug.ops src/ops/experimental.ops src/ops/io.ops src/ops/math.ops +src/ops/object.ops src/ops/pic.ops src/ops/pmc.ops src/ops/set.ops +src/ops/stack.ops src/ops/stm.ops src/ops/string.ops src/ops/sys.ops +src/ops/var.ops ); +my $num = "src/ops/ops.num"; +my $skip = "src/ops/ops.skip"; + +ok(chdir $main::topdir, "Positioned at top-level Parrot directory"); +my $cwd = cwd(); + +{ + my $tdir = tempdir( CLEANUP => 1 ); + ok(chdir $tdir, 'changed to temp directory for testing'); + + my $tlib = generate_core( + $cwd, $tdir, \@srcopsfiles, $num, $skip); + + ok(-d $tlib, "lib directory created under tempdir"); + unshift @INC, $tlib; + require Parrot::Ops2c::Utils; + + { + local @ARGV = qw( C CGoto CGP CSwitch CPrederef ); + my $self = Parrot::Ops2c::Utils->new( { + argv => [ @ARGV ], + flag => { core => 1, nolines => 1 }, + } ); + ok(defined $self, + "Constructor correctly returned when provided >= 1 arguments"); + + my $c_header_file = $self->print_c_header_file(); + ok(-e $c_header_file, "$c_header_file created"); + ok(-s $c_header_file, "$c_header_file has non-zero size"); + + my $SOURCE = $self->print_c_source_top(); + is(ref($SOURCE), q{GLOB}, "Argument type is filehandle (typeglob)"); + + my $c_source_final; + ok($c_source_final = $self->print_c_source_bottom($SOURCE), + "print_c_source_bottom() returned successfully"); + ok(-e $c_source_final, "$c_source_final created"); + ok(-s $c_source_final, "$c_source_final has non-zero size"); + } + + ok(chdir($cwd), "returned to starting directory"); +} + +pass("Completed all tests in $0"); + +################### DOCUMENTATION ################### + +=head1 NAME + +08-nolines.t - test C<--nolines> option to F. + +=head1 SYNOPSIS + + % prove t/tools/ops2cutils/08-nolines.t + +=head1 DESCRIPTION + +The files in this directory test the publicly callable subroutines of +F and F. +By doing so, they test the functionality of the F utility. +That functionality has largely been extracted +into the methods of F. + +All the files in this directory are intended to be run B +F has been run but before F has been called. Hence, they +are B part of the test suite run by F. Once you have run +F, however, you may run these tests as part of F. + +F<08-nolines.t> tests whether +C work properly when C<--nolines> option +is passed to F. + +=head1 AUTHOR + +James E Keenan + +=head1 SEE ALSO + +Parrot::Ops2c::Auxiliary, F. + +=cut + Index: config/gen/makefiles/root.in =================================================================== --- config/gen/makefiles/root.in (revision 17419) +++ config/gen/makefiles/root.in (working copy) @@ -1359,6 +1359,7 @@ t/tools/*.t PMC2CUTILS_DIR = t/tools/pmc2cutils OPS2PMUTILS_DIR = t/tools/ops2pmutils +OPS2CUTILS_DIR = t/tools/ops2cutils BUILDTOOLS_TEST_FILES = \ $(PMC2CUTILS_DIR)/00-qualify.t \ $(PMC2CUTILS_DIR)/01-pmc2cutils.t \ @@ -1379,7 +1380,16 @@ $(OPS2PMUTILS_DIR)/08-sort_ops.t \ $(OPS2PMUTILS_DIR)/09-prepare_real_ops.t \ $(OPS2PMUTILS_DIR)/10-print_module.t \ - $(OPS2PMUTILS_DIR)/11-print_h.t + $(OPS2PMUTILS_DIR)/11-print_h.t \ + $(OPS2CUTILS_DIR)/01-new.t \ + $(OPS2CUTILS_DIR)/02-usage.t \ + $(OPS2CUTILS_DIR)/03-print_c_header_file.t \ + $(OPS2CUTILS_DIR)/04-print_c_source_top.t \ + $(OPS2CUTILS_DIR)/05-print_c_source_bottom.t \ + $(OPS2CUTILS_DIR)/06-dynamic.t \ + $(OPS2CUTILS_DIR)/07-make_incdir.t \ + $(OPS2CUTILS_DIR)/08-nolines.t \ + $(OPS2CUTILS_DIR)/09-dynamic_nolines.t # Common prep for all test targets. # We probably need a complete build before running the tests.