diff options
Diffstat (limited to 'Examples/test-suite/perl5')
67 files changed, 5959 insertions, 0 deletions
diff --git a/Examples/test-suite/perl5/Makefile.in b/Examples/test-suite/perl5/Makefile.in new file mode 100644 index 0000000..67eaf5c --- /dev/null +++ b/Examples/test-suite/perl5/Makefile.in @@ -0,0 +1,61 @@ +####################################################################### +# Makefile for perl5 test-suite +####################################################################### + +LANGUAGE = perl5 +PERL = @PERL@ +SCRIPTSUFFIX = _runme.pl +TEST_RUNNER = run-perl-test.pl +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +top_builddir = @top_builddir@ + +CPP_TEST_CASES += \ + primitive_types \ + li_cdata \ + li_cstring \ + li_cdata_carrays \ + li_reference \ + +C_TEST_CASES += \ + li_cdata \ + li_cstring \ + li_cdata_carrays \ + +include $(srcdir)/../common.mk + +# Overridden variables here +# none! + +# Custom tests - tests with additional commandline options +# none! + +# Rules for the different types of tests +%.cpptest: + $(setup) + +$(swig_and_compile_cpp) + $(run_testcase) + +%.ctest: + $(setup) + +$(swig_and_compile_c) + $(run_testcase) + +%.multicpptest: + $(setup) + +$(swig_and_compile_multi_cpp) + $(run_testcase) + +# Runs the testcase. A testcase is only run if +# a file is found which has _runme.pl appended after the testcase name. +run_testcase = \ + if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ]; then \ + env LD_LIBRARY_PATH=.:$$LD_LIBRARY_PATH $(RUNTOOL) $(PERL) $(TEST_RUNNER) $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX); \ + fi + +# Clean: remove the generated .pm file +%.clean: + @rm -f $*.pm; + +clean: + $(MAKE) -f $(top_builddir)/$(EXAMPLES)/Makefile perl5_clean diff --git a/Examples/test-suite/perl5/README b/Examples/test-suite/perl5/README new file mode 100644 index 0000000..14eb527 --- /dev/null +++ b/Examples/test-suite/perl5/README @@ -0,0 +1,32 @@ +See ../README for common README file. + +Any testcases which have _runme.pl appended after the testcase name will be detected and run. + +Test::More Support +== + +Test::More and Test::Harness are two of the standard perl test harness +tools. Support has been added for these modules as of 1.3.28. If +adding a new test to this suite, please use Test::More. + +Currently converted test cases include: + +* operator_overload +* operator_overload_break +* package +* overload_simple +* apply_strings +* char_strings +* default_args +* enum_thorough +* global_vars +* import_nomodule +* inherit +* li_cdata_carrays +* li_std_string +* member_pointer +* multiple_inheritance +* primitive_ref +* template_default_arg +* unions +* voidtest diff --git a/Examples/test-suite/perl5/Test/Builder.pm b/Examples/test-suite/perl5/Test/Builder.pm new file mode 100644 index 0000000..9f6a3a4 --- /dev/null +++ b/Examples/test-suite/perl5/Test/Builder.pm @@ -0,0 +1,1591 @@ +package Test::Builder; + +use 5.004; + +# $^C was only introduced in 5.005-ish. We do this to prevent +# use of uninitialized value warnings in older perls. +$^C ||= 0; + +use strict; +use vars qw($VERSION); +$VERSION = '0.22'; +$VERSION = eval $VERSION; # make the alpha version come out as a number + +# Make Test::Builder thread-safe for ithreads. +BEGIN { + use Config; + # Load threads::shared when threads are turned on + if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { + require threads::shared; + + # Hack around YET ANOTHER threads::shared bug. It would + # occassionally forget the contents of the variable when sharing it. + # So we first copy the data, then share, then put our copy back. + *share = sub (\[$@%]) { + my $type = ref $_[0]; + my $data; + + if( $type eq 'HASH' ) { + %$data = %{$_[0]}; + } + elsif( $type eq 'ARRAY' ) { + @$data = @{$_[0]}; + } + elsif( $type eq 'SCALAR' ) { + $$data = ${$_[0]}; + } + else { + die "Unknown type: ".$type; + } + + $_[0] = &threads::shared::share($_[0]); + + if( $type eq 'HASH' ) { + %{$_[0]} = %$data; + } + elsif( $type eq 'ARRAY' ) { + @{$_[0]} = @$data; + } + elsif( $type eq 'SCALAR' ) { + ${$_[0]} = $$data; + } + else { + die "Unknown type: ".$type; + } + + return $_[0]; + }; + } + # 5.8.0's threads::shared is busted when threads are off. + # We emulate it here. + else { + *share = sub { return $_[0] }; + *lock = sub { 0 }; + } +} + + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use Test::Builder; + require Exporter; + @ISA = qw(Exporter); + @EXPORT = qw(ok); + + my $Test = Test::Builder->new; + $Test->output('my_logfile'); + + sub import { + my($self) = shift; + my $pack = caller; + + $Test->exported_to($pack); + $Test->plan(@_); + + $self->export_to_level(1, $self, 'ok'); + } + + sub ok { + my($test, $name) = @_; + + $Test->ok($test, $name); + } + + +=head1 DESCRIPTION + +Test::Simple and Test::More have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides the a +building block upon which to write your own test libraries I<which can +work together>. + +=head2 Construction + +=over 4 + +=item B<new> + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program, there is B<one and only one> +Test::Builder object. No matter how many times you call new(), you're +getting the same object. (This is called a singleton). + +=cut + +my $Test = Test::Builder->new; +sub new { + my($class) = shift; + $Test ||= bless ['Move along, nothing to see here'], $class; + return $Test; +} + +=item B<reset> + + $Test->reset; + +Reinitializes the Test::Builder singleton to its original state. +Mostly useful for tests run in persistent environments where the same +test might be run multiple times in the same process. + +=cut + +my $Test_Died; +my $Have_Plan; +my $No_Plan; +my $Curr_Test; share($Curr_Test); +use vars qw($Level); +my $Original_Pid; +my @Test_Results; share(@Test_Results); + +my $Exported_To; +my $Expected_Tests; + +my $Skip_All; + +my $Use_Nums; + +my($No_Header, $No_Ending); + +$Test->reset; + +sub reset { + my ($self) = @_; + + $Test_Died = 0; + $Have_Plan = 0; + $No_Plan = 0; + $Curr_Test = 0; + $Level = 1; + $Original_Pid = $$; + @Test_Results = (); + + $Exported_To = undef; + $Expected_Tests = 0; + + $Skip_All = 0; + + $Use_Nums = 1; + + ($No_Header, $No_Ending) = (0,0); + + $self->_dup_stdhandles unless $^C; + + return undef; +} + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B<exported_to> + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. +This is important for getting TODO tests right. + +=cut + +sub exported_to { + my($self, $pack) = @_; + + if( defined $pack ) { + $Exported_To = $pack; + } + return $Exported_To; +} + +=item B<plan> + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call plan(), don't call any of the other methods below. + +=cut + +sub plan { + my($self, $cmd, $arg) = @_; + + return unless $cmd; + + if( $Have_Plan ) { + die sprintf "You tried to plan twice! Second plan at %s line %d\n", + ($self->caller)[1,2]; + } + + if( $cmd eq 'no_plan' ) { + $self->no_plan; + } + elsif( $cmd eq 'skip_all' ) { + return $self->skip_all($arg); + } + elsif( $cmd eq 'tests' ) { + if( $arg ) { + return $self->expected_tests($arg); + } + elsif( !defined $arg ) { + die "Got an undefined number of tests. Looks like you tried to ". + "say how many tests you plan to run but made a mistake.\n"; + } + elsif( !$arg ) { + die "You said to run 0 tests! You've got to run something.\n"; + } + } + else { + require Carp; + my @args = grep { defined } ($cmd, $arg); + Carp::croak("plan() doesn't understand @args"); + } + + return 1; +} + +=item B<expected_tests> + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the # of tests we expect this test to run and prints out +the appropriate headers. + +=cut + +sub expected_tests { + my $self = shift; + my($max) = @_; + + if( @_ ) { + die "Number of tests must be a postive integer. You gave it '$max'.\n" + unless $max =~ /^\+?\d+$/ and $max > 0; + + $Expected_Tests = $max; + $Have_Plan = 1; + + $self->_print("1..$max\n") unless $self->no_header; + } + return $Expected_Tests; +} + + +=item B<no_plan> + + $Test->no_plan; + +Declares that this test will run an indeterminate # of tests. + +=cut + +sub no_plan { + $No_Plan = 1; + $Have_Plan = 1; +} + +=item B<has_plan> + + $plan = $Test->has_plan + +Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests). + +=cut + +sub has_plan { + return($Expected_Tests) if $Expected_Tests; + return('no_plan') if $No_Plan; + return(undef); +}; + + +=item B<skip_all> + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given $reason. Exits immediately with 0. + +=cut + +sub skip_all { + my($self, $reason) = @_; + + my $out = "1..0"; + $out .= " # Skip $reason" if $reason; + $out .= "\n"; + + $Skip_All = 1; + + $self->_print($out) unless $self->no_header; + exit(0); +} + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in +Test::More. + +$name is always optional. + +=over 4 + +=item B<ok> + + $Test->ok($test, $name); + +Your basic test. Pass if $test is true, fail if $test is false. Just +like Test::Simple's ok(). + +=cut + +sub ok { + my($self, $test, $name) = @_; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run a test without a plan! Gotta have a plan."); + } + + lock $Curr_Test; + $Curr_Test++; + + # In case $name is a string overloaded object, force it to stringify. + $self->_unoverload(\$name); + + $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/; + You named your test '$name'. You shouldn't use numbers for your test names. + Very confusing. +ERR + + my($pack, $file, $line) = $self->caller; + + my $todo = $self->todo($pack); + $self->_unoverload(\$todo); + + my $out; + my $result = &share({}); + + unless( $test ) { + $out .= "not "; + @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } + + $out .= "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if( $todo ) { + $out .= " # TODO $todo"; + $result->{reason} = $todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $Test_Results[$Curr_Test-1] = $result; + $out .= "\n"; + + $self->_print($out); + + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; + $self->diag(" $msg test ($file at line $line)\n"); + } + + return $test ? 1 : 0; +} + + +sub _unoverload { + my $self = shift; + + local($@,$!); + + eval { require overload } || return; + + foreach my $thing (@_) { + eval { + if( defined $$thing ) { + if( my $string_meth = overload::Method($$thing, '""') ) { + $$thing = $$thing->$string_meth(); + } + } + }; + } +} + + +=item B<is_eq> + + $Test->is_eq($got, $expected, $name); + +Like Test::More's is(). Checks if $got eq $expected. This is the +string version. + +=item B<is_num> + + $Test->is_num($got, $expected, $name); + +Like Test::More's is(). Checks if $got == $expected. This is the +numeric version. + +=cut + +sub is_eq { + my($self, $got, $expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok($test, $name); + $self->_is_diag($got, 'eq', $expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, 'eq', $expect, $name); +} + +sub is_num { + my($self, $got, $expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok($test, $name); + $self->_is_diag($got, '==', $expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, '==', $expect, $name); +} + +sub _is_diag { + my($self, $got, $type, $expect) = @_; + + foreach my $val (\$got, \$expect) { + if( defined $$val ) { + if( $type eq 'eq' ) { + # quote and force string context + $$val = "'$$val'" + } + else { + # force numeric context + $$val = $$val+0; + } + } + else { + $$val = 'undef'; + } + } + + return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); + got: %s + expected: %s +DIAGNOSTIC + +} + +=item B<isnt_eq> + + $Test->isnt_eq($got, $dont_expect, $name); + +Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +the string version. + +=item B<isnt_num> + + $Test->is_num($got, $dont_expect, $name); + +Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +the numeric version. + +=cut + +sub isnt_eq { + my($self, $got, $dont_expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok($test, $name); + $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, 'ne', $dont_expect, $name); +} + +sub isnt_num { + my($self, $got, $dont_expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok($test, $name); + $self->_cmp_diag($got, '!=', $dont_expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, '!=', $dont_expect, $name); +} + + +=item B<like> + + $Test->like($this, qr/$regex/, $name); + $Test->like($this, '/$regex/', $name); + +Like Test::More's like(). Checks if $this matches the given $regex. + +You'll want to avoid qr// if you want your tests to work before 5.005. + +=item B<unlike> + + $Test->unlike($this, qr/$regex/, $name); + $Test->unlike($this, '/$regex/', $name); + +Like Test::More's unlike(). Checks if $this B<does not match> the +given $regex. + +=cut + +sub like { + my($self, $this, $regex, $name) = @_; + + local $Level = $Level + 1; + $self->_regex_ok($this, $regex, '=~', $name); +} + +sub unlike { + my($self, $this, $regex, $name) = @_; + + local $Level = $Level + 1; + $self->_regex_ok($this, $regex, '!~', $name); +} + +=item B<maybe_regex> + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +Convenience method for building testing functions that take regular +expressions as arguments, but need to work before perl 5.005. + +Takes a quoted regular expression produced by qr//, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or undef if it's argument is not recognised. + +For example, a version of like(), sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ m/$usable_regex/, $name); + } + +=cut + + +sub maybe_regex { + my ($self, $regex) = @_; + my $usable_regex = undef; + + return $usable_regex unless defined $regex; + + my($re, $opts); + + # Check for qr/foo/ + if( ref $regex eq 'Regexp' ) { + $usable_regex = $regex; + } + # Check for '/foo/' or 'm,foo,' + elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or + (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx + ) + { + $usable_regex = length $opts ? "(?$opts)$re" : $re; + } + + return $usable_regex; +}; + +sub _regex_ok { + my($self, $this, $regex, $cmp, $name) = @_; + + local $Level = $Level + 1; + + my $ok = 0; + my $usable_regex = $self->maybe_regex($regex); + unless (defined $usable_regex) { + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); + return $ok; + } + + { + local $^W = 0; + my $test = $this =~ /$usable_regex/ ? 1 : 0; + $test = !$test if $cmp eq '!~'; + $ok = $self->ok( $test, $name ); + } + + unless( $ok ) { + $this = defined $this ? "'$this'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex); + %s + %13s '%s' +DIAGNOSTIC + + } + + return $ok; +} + +=item B<cmp_ok> + + $Test->cmp_ok($this, $type, $that, $name); + +Works just like Test::More's cmp_ok(). + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=cut + +sub cmp_ok { + my($self, $got, $type, $expect, $name) = @_; + + my $test; + { + local $^W = 0; + local($@,$!); # don't interfere with $@ + # eval() sometimes resets $! + $test = eval "\$got $type \$expect"; + } + local $Level = $Level + 1; + my $ok = $self->ok($test, $name); + + unless( $ok ) { + if( $type =~ /^(eq|==)$/ ) { + $self->_is_diag($got, $type, $expect); + } + else { + $self->_cmp_diag($got, $type, $expect); + } + } + return $ok; +} + +sub _cmp_diag { + my($self, $got, $type, $expect) = @_; + + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); + %s + %s + %s +DIAGNOSTIC +} + +=item B<BAILOUT> + + $Test->BAILOUT($reason); + +Indicates to the Test::Harness that things are going so badly all +testing should terminate. This includes running any additional test +scripts. + +It will exit with 255. + +=cut + +sub BAILOUT { + my($self, $reason) = @_; + + $self->_print("Bail out! $reason"); + exit 255; +} + +=item B<skip> + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting $why. + +=cut + +sub skip { + my($self, $why) = @_; + $why ||= ''; + $self->_unoverload(\$why); + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); + } + + lock($Curr_Test); + $Curr_Test++; + + $Test_Results[$Curr_Test-1] = &share({ + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + }); + + my $out = "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + $out .= " # skip"; + $out .= " $why" if length $why; + $out .= "\n"; + + $Test->_print($out); + + return 1; +} + + +=item B<todo_skip> + + $Test->todo_skip; + $Test->todo_skip($why); + +Like skip(), only it will declare the test as failing and TODO. Similar +to + + print "not ok $tnum # TODO $why\n"; + +=cut + +sub todo_skip { + my($self, $why) = @_; + $why ||= ''; + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); + } + + lock($Curr_Test); + $Curr_Test++; + + $Test_Results[$Curr_Test-1] = &share({ + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + }); + + my $out = "not ok"; + $out .= " $Curr_Test" if $self->use_numbers; + $out .= " # TODO & SKIP $why\n"; + + $Test->_print($out); + + return 1; +} + + +=begin _unimplemented + +=item B<skip_rest> + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like skip(), only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under no_plan, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test style + +=over 4 + +=item B<level> + + $Test->level($how_high); + +How far up the call stack should $Test look when reporting where the +test failed. + +Defaults to 1. + +Setting $Test::Builder::Level overrides. This is typically useful +localized: + + { + local $Test::Builder::Level = 2; + $Test->ok($test); + } + +=cut + +sub level { + my($self, $level) = @_; + + if( defined $level ) { + $Level = $level; + } + return $Level; +} + + +=item B<use_numbers> + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Test::Harness will accept either, but avoid mixing the two styles. + +Defaults to on. + +=cut + +sub use_numbers { + my($self, $use_nums) = @_; + + if( defined $use_nums ) { + $Use_Nums = $use_nums; + } + return $Use_Nums; +} + +=item B<no_header> + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=item B<no_ending> + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described below. + +If this is true, none of that will be done. + +=cut + +sub no_header { + my($self, $no_header) = @_; + + if( defined $no_header ) { + $No_Header = $no_header; + } + return $No_Header; +} + +sub no_ending { + my($self, $no_ending) = @_; + + if( defined $no_ending ) { + $No_Ending = $no_ending; + } + return $No_Ending; +} + + +=back + +=head2 Output + +Controlling where the test output goes. + +It's ok for your test to change where STDOUT and STDERR point to, +Test::Builder's default output settings will not be affected. + +=over 4 + +=item B<diag> + + $Test->diag(@msgs); + +Prints out the given @msgs. Like C<print>, arguments are simply +appended together. + +Normally, it uses the failure_output() handle, but if this is for a +TODO test, the todo_output() handle is used. + +Output will be indented and marked with a # so as not to interfere +with test output. A newline will be put on the end if there isn't one +already. + +We encourage using this rather than calling print directly. + +Returns false. Why? Because diag() is often used in conjunction with +a failing test (C<ok() || diag()>) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler <mark@twoshortplanks.com> + +=cut + +sub diag { + my($self, @msgs) = @_; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + # Smash args together like print does. + # Convert undef to 'undef' so its readable. + my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; + + # Escape each line with a #. + $msg =~ s/^/# /gm; + + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\Z/; + + local $Level = $Level + 1; + $self->_print_diag($msg); + + return 0; +} + +=begin _private + +=item B<_print> + + $Test->_print(@msgs); + +Prints to the output() filehandle. + +=end _private + +=cut + +sub _print { + my($self, @msgs) = @_; + + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; + + my $msg = join '', @msgs; + + local($\, $", $,) = (undef, ' ', ''); + my $fh = $self->output; + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + $msg =~ s/\n(.)/\n# $1/sg; + + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\Z/; + + print $fh $msg; +} + + +=item B<_print_diag> + + $Test->_print_diag(@msg); + +Like _print, but prints to the current diagnostic filehandle. + +=cut + +sub _print_diag { + my $self = shift; + + local($\, $", $,) = (undef, ' ', ''); + my $fh = $self->todo ? $self->todo_output : $self->failure_output; + print $fh @_; +} + +=item B<output> + + $Test->output($fh); + $Test->output($file); + +Where normal "ok/not ok" test output should go. + +Defaults to STDOUT. + +=item B<failure_output> + + $Test->failure_output($fh); + $Test->failure_output($file); + +Where diagnostic output on test failures and diag() should go. + +Defaults to STDERR. + +=item B<todo_output> + + $Test->todo_output($fh); + $Test->todo_output($file); + +Where diagnostics about todo test failures and diag() should go. + +Defaults to STDOUT. + +=cut + +my($Out_FH, $Fail_FH, $Todo_FH); +sub output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Out_FH = _new_fh($fh); + } + return $Out_FH; +} + +sub failure_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Fail_FH = _new_fh($fh); + } + return $Fail_FH; +} + +sub todo_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Todo_FH = _new_fh($fh); + } + return $Todo_FH; +} + + +sub _new_fh { + my($file_or_fh) = shift; + + my $fh; + if( _is_fh($file_or_fh) ) { + $fh = $file_or_fh; + } + else { + $fh = do { local *FH }; + open $fh, ">$file_or_fh" or + die "Can't open test output log $file_or_fh: $!"; + } + + return $fh; +} + + +sub _is_fh { + my $maybe_fh = shift; + + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return UNIVERSAL::isa($maybe_fh, 'GLOB') || + UNIVERSAL::isa($maybe_fh, 'IO::Handle') || + + # 5.5.4's tied() and can() doesn't like getting undef + UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE'); +} + + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + + +my $Opened_Testhandles = 0; +sub _dup_stdhandles { + my $self = shift; + + $self->_open_testhandles unless $Opened_Testhandles; + + # Set everything to unbuffered else plain prints to STDOUT will + # come out in the wrong order from our own prints. + _autoflush(\*TESTOUT); + _autoflush(\*STDOUT); + _autoflush(\*TESTERR); + _autoflush(\*STDERR); + + $Test->output(\*TESTOUT); + $Test->failure_output(\*TESTERR); + $Test->todo_output(\*TESTOUT); +} + +sub _open_testhandles { + # We dup STDOUT and STDERR so people can change them in their + # test suites while still getting normal test output. + open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; + open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; + $Opened_Testhandles = 1; +} + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B<current_test> + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test number we're on. You usually shouldn't +have to set this. + +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. + +=cut + +sub current_test { + my($self, $num) = @_; + + lock($Curr_Test); + if( defined $num ) { + unless( $Have_Plan ) { + require Carp; + Carp::croak("Can't change the current test number without a plan!"); + } + + $Curr_Test = $num; + + # If the test counter is being pushed forward fill in the details. + if( $num > @Test_Results ) { + my $start = @Test_Results ? $#Test_Results + 1 : 0; + for ($start..$num-1) { + $Test_Results[$_] = &share({ + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + }); + } + } + # If backward, wipe history. Its their funeral. + elsif( $num < @Test_Results ) { + $#Test_Results = $num - 1; + } + } + return $Curr_Test; +} + + +=item B<summary> + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + +=cut + +sub summary { + my($self) = shift; + + return map { $_->{'ok'} } @Test_Results; +} + +=item B<details> + + my @tests = $Test->details; + +Like summary(), but with a lot more detail. + + $tests[$test_num - 1] = + { 'ok' => is the test considered a pass? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => type of test (if any, see below). + reason => reason for the above (if any) + }; + +'ok' is true if Test::Harness will consider the test to be a pass. + +'actual_ok' is a reflection of whether or not the test literally +printed 'ok' or 'not ok'. This is for examining the result of 'todo' +tests. + +'name' is the name of the test. + +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: + + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below + +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when current_test() is changed. +In these cases, Test::Builder doesn't know the result of the test, so +it's type is 'unkown'. These details for these tests are filled in. +They are considered ok, but the name and actual_ok is left undef. + +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: + + $tests[22] = # 23 - 1, since arrays start from 0. + { ok => 1, # logically, the test passed since it's todo + actual_ok => 0, # in absolute terms, it failed + name => 'hole count', + type => 'todo', + reason => 'insufficient donuts' + }; + +=cut + +sub details { + return @Test_Results; +} + +=item B<todo> + + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); + +todo() looks for a $TODO variable in your tests. If set, all tests +will be considered 'todo' (see Test::More and Test::Harness for +details). Returns the reason (ie. the value of $TODO) if running as +todo tests, false otherwise. + +todo() is pretty part about finding the right package to look for +$TODO in. It uses the exported_to() package to find it. If that's +not set, it's pretty good at guessing the right package to look at. + +Sometimes there is some confusion about where todo() should be looking +for the $TODO variable. If you want to be sure, tell it explicitly +what $pack to use. + +=cut + +sub todo { + my($self, $pack) = @_; + + $pack = $pack || $self->exported_to || $self->caller(1); + + no strict 'refs'; + return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} + : 0; +} + +=item B<caller> + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal caller(), except it reports according to your level(). + +=cut + +sub caller { + my($self, $height) = @_; + $height ||= 0; + + my @caller = CORE::caller($self->level + $height + 1); + return wantarray ? @caller : $caller[0]; +} + +=back + +=cut + +=begin _private + +=over 4 + +=item B<_sanity_check> + + _sanity_check(); + +Runs a bunch of end of test sanity checks to make sure reality came +through ok. If anything is wrong it will die with a fairly friendly +error message. + +=cut + +#'# +sub _sanity_check { + _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); + _whoa(!$Have_Plan and $Curr_Test, + 'Somehow your tests ran without a plan!'); + _whoa($Curr_Test != @Test_Results, + 'Somehow you got a different number of results than tests ran!'); +} + +=item B<_whoa> + + _whoa($check, $description); + +A sanity check, similar to assert(). If the $check is true, something +has gone horribly wrong. It will die with the given $description and +a note to contact the author. + +=cut + +sub _whoa { + my($check, $desc) = @_; + if( $check ) { + die <<WHOA; +WHOA! $desc +This should never happen! Please contact the author immediately! +WHOA + } +} + +=item B<_my_exit> + + _my_exit($exit_num); + +Perl seems to have some trouble with exiting inside an END block. 5.005_03 +and 5.6.1 both seem to do odd things. Instead, this function edits $? +directly. It should ONLY be called from inside an END block. It +doesn't actually exit, that's your job. + +=cut + +sub _my_exit { + $? = $_[0]; + + return 1; +} + + +=back + +=end _private + +=cut + +$SIG{__DIE__} = sub { + # We don't want to muck with death in an eval, but $^S isn't + # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing + # with it. Instead, we use caller. This also means it runs under + # 5.004! + my $in_eval = 0; + for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { + $in_eval = 1 if $sub =~ /^\(eval\)/; + } + $Test_Died = 1 unless $in_eval; +}; + +sub _ending { + my $self = shift; + + _sanity_check(); + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + do{ _my_exit($?) && return } if $Original_Pid != $$; + + # Bailout if plan() was never called. This is so + # "require Test::Simple" doesn't puke. + do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; + + # Figure out if we passed or failed and print helpful messages. + if( @Test_Results ) { + # The plan? We have no plan. + if( $No_Plan ) { + $self->_print("1..$Curr_Test\n") unless $self->no_header; + $Expected_Tests = $Curr_Test; + } + + # Auto-extended arrays and elements which aren't explicitly + # filled in with a shared reference will puke under 5.8.0 + # ithreads. So we have to fill them in by hand. :( + my $empty_result = &share({}); + for my $idx ( 0..$Expected_Tests-1 ) { + $Test_Results[$idx] = $empty_result + unless defined $Test_Results[$idx]; + } + + my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; + $num_failed += abs($Expected_Tests - @Test_Results); + + if( $Curr_Test < $Expected_Tests ) { + my $s = $Expected_Tests == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you planned $Expected_Tests test$s but only ran $Curr_Test. +FAIL + } + elsif( $Curr_Test > $Expected_Tests ) { + my $num_extra = $Curr_Test - $Expected_Tests; + my $s = $Expected_Tests == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you planned $Expected_Tests test$s but ran $num_extra extra. +FAIL + } + elsif ( $num_failed ) { + my $s = $num_failed == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you failed $num_failed test$s of $Expected_Tests. +FAIL + } + + if( $Test_Died ) { + $self->diag(<<"FAIL"); +Looks like your test died just after $Curr_Test. +FAIL + + _my_exit( 255 ) && return; + } + + _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; + } + elsif ( $Skip_All ) { + _my_exit( 0 ) && return; + } + elsif ( $Test_Died ) { + $self->diag(<<'FAIL'); +Looks like your test died before it could output anything. +FAIL + _my_exit( 255 ) && return; + } + else { + $self->diag("No tests run!\n"); + _my_exit( 255 ) && return; + } +} + +END { + $Test->_ending if defined $Test and !$Test->no_ending; +} + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + + +=head1 THREADS + +In perl 5.8.0 and later, Test::Builder is thread-safe. The test +number is shared amongst all threads. This means if one thread sets +the test number using current_test() they will all be effected. + +Test::Builder is only thread-aware if threads.pm is loaded I<before> +Test::Builder. + +=head1 EXAMPLES + +CPAN can provide the best examples. Test::Simple, Test::More, +Test::Exception and Test::Differences all use Test::Builder. + +=head1 SEE ALSO + +Test::Simple, Test::More, Test::Harness + +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +E<lt>schwern@pobox.comE<gt> + +=head1 COPYRIGHT + +Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and + Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut + +1; diff --git a/Examples/test-suite/perl5/Test/More.pm b/Examples/test-suite/perl5/Test/More.pm new file mode 100644 index 0000000..aa02808 --- /dev/null +++ b/Examples/test-suite/perl5/Test/More.pm @@ -0,0 +1,1448 @@ +package Test::More; + +use 5.004; + +use strict; +use Test::Builder; + + +# Can't use Carp because it might cause use_ok() to accidentally succeed +# even though the module being used forgot to use Carp. Yes, this +# actually happened. +sub _carp { + my($file, $line) = (caller(1))[1,2]; + warn @_, " at $file line $line\n"; +} + + + +require Exporter; +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = '0.54'; +$VERSION = eval $VERSION; # make the alpha version come out as a number + +@ISA = qw(Exporter); +@EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + can_ok isa_ok + diag + ); + +my $Test = Test::Builder->new; +my $Show_Diag = 1; + + +# 5.004's Exporter doesn't have export_to_level. +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + # or + use Test::More qw(no_plan); + # or + use Test::More skip_all => $reason; + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($this eq $that, $test_name); + + is ($this, $that, $test_name); + isnt($this, $that, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($this, qr/that/, $test_name); + unlike($this, qr/that/, $test_name); + + cmp_ok($this, '==', $that, $test_name); + + is_deeply($complex_structure1, $complex_structure2, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + # Utility comparison functions. + eq_array(\@this, \@that); + eq_hash(\%this, \%that); + eq_set(\@this, \@that); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + # UNIMPLEMENTED!!! + BAIL_OUT($why); + + +=head1 DESCRIPTION + +B<STOP!> If you're just getting started writing tests, have a look at +Test::Simple first. This is a drop in replacement for Test::Simple +which you can switch to once you get the hang of basic testing. + +The purpose of this module is to provide a wide range of testing +utilities. Various ways to say "ok" with better diagnostics, +facilities to skip tests, test future features and compare complicated +data structures. While you can do almost anything with a simple +C<ok()> function, it doesn't provide good diagnostic output. + + +=head2 I love it when a plan comes together + +Before anything else, you need a testing plan. This basically declares +how many tests your script is going to run to protect against premature +failure. + +The preferred way to do this is to declare a plan when you C<use Test::More>. + + use Test::More tests => $Num_Tests; + +There are rare cases when you will not know beforehand how many tests +your script is going to run. In this case, you can declare that you +have no plan. (Try to avoid using this as it weakens your test.) + + use Test::More qw(no_plan); + +B<NOTE>: using no_plan requires a Test::Harness upgrade else it will +think everything has failed. See L<BUGS and CAVEATS>) + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More skip_all => $skip_reason; + +Your script will declare a skip with the reason why you skipped and +exit immediately with a zero (success). See L<Test::Harness> for +details. + +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the plan() function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevant on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my(@plan) = @_; + + my $idx = 0; + my @cleaned_plan; + while( $idx <= $#plan ) { + my $item = $plan[$idx]; + + if( $item eq 'no_diag' ) { + $Show_Diag = 0; + } + else { + push @cleaned_plan, $item; + } + + $idx++; + } + + $Test->plan(@cleaned_plan); +} + +sub import { + my($class) = shift; + + my $caller = caller; + + $Test->exported_to($caller); + + my $idx = 0; + my @plan; + my @imports; + while( $idx <= $#_ ) { + my $item = $_[$idx]; + + if( $item eq 'import' ) { + push @imports, @{$_[$idx+1]}; + $idx++; + } + else { + push @plan, $item; + } + + $idx++; + } + + plan(@plan); + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, it's often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. It's optional, but highly +suggested that you use it. + + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B<ok> + + ok($this eq $that, $test_name); + +This simply evaluates any expression (C<$this eq $that> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep !defined $_, @items, 'items populated' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B<very> strongly encourage its use. + +Should an ok() fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 18 (foo.t at line 42) + +This is actually Test::Simple's ok() routine. + +=cut + +sub ok ($;$) { + my($test, $name) = @_; + $Test->ok($test, $name); +} + +=item B<is> + +=item B<isnt> + + is ( $this, $that, $test_name ); + isnt( $this, $that, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments +with C<eq> and C<ne> respectively and use the result of that to +determine if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. ok() +cannot know what you are testing for (beyond the name), but is() and +isnt() know what the test was and why it failed. For example this +test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test (foo.t at line 139) + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use is() and isnt() over ok() where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! + is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); + +This does not check if C<exists $brooklyn{tree}> is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use ok(). + + ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); + +For those grammatical pedants out there, there's an C<isn't()> +function which is an alias of isnt(). + +=cut + +sub is ($$;$) { + $Test->is_eq(@_); +} + +sub isnt ($$;$) { + $Test->isnt_eq(@_); +} + +*isn't = \&isnt; + + +=item B<like> + + like( $this, qr/that/, $test_name ); + +Similar to ok(), like() matches $this against the regex C<qr/that/>. + +So this: + + like($this, qr/that/, 'this is like that'); + +is similar to: + + ok( $this =~ /that/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (i.e. C<qr//>) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $this, '/that/', 'this is like that' ); + +Regex options may be placed on the end (C<'/that/i'>). + +Its advantages over ok() are similar to that of is() and isnt(). Better +diagnostics on failure. + +=cut + +sub like ($$;$) { + $Test->like(@_); +} + + +=item B<unlike> + + unlike( $this, qr/that/, $test_name ); + +Works exactly as like(), only it checks if $this B<does not> match the +given pattern. + +=cut + +sub unlike ($$;$) { + $Test->unlike(@_); +} + + +=item B<cmp_ok> + + cmp_ok( $this, $op, $that, $test_name ); + +Halfway between ok() and is() lies cmp_ok(). This allows you to +compare two arguments using any binary perl operator. + + # ok( $this eq $that ); + cmp_ok( $this, 'eq', $that, 'this eq that' ); + + # ok( $this == $that ); + cmp_ok( $this, '==', $that, 'this == that' ); + + # ok( $this && $that ); + cmp_ok( $this, '&&', $that, 'this && that' ); + ...etc... + +Its advantage over ok() is when the test fails you'll know what $this +and $that were: + + not ok 1 + # Failed test (foo.t at line 12) + # '23' + # && + # undef + +It's also useful in those cases where you are comparing numbers and +is()'s use of C<eq> will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +=cut + +sub cmp_ok($$$;$) { + $Test->cmp_ok(@_); +} + + +=item B<can_ok> + + can_ok($module, @methods); + can_ok($object, @methods); + +Checks to make sure the $module or $object can do these @methods +(works with functions, too). + + can_ok('Foo', qw(this that whatever)); + +is almost exactly like saying: + + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') + ); + +only without all the typing and with a better interface. Handy for +quickly testing an interface. + +No matter how many @methods you check, a single can_ok() call counts +as one test. If you desire otherwise, use: + + foreach my $meth (@methods) { + can_ok('Foo', $meth); + } + +=cut + +sub can_ok ($@) { + my($proto, @methods) = @_; + my $class = ref $proto || $proto; + + unless( @methods ) { + my $ok = $Test->ok( 0, "$class->can(...)" ); + $Test->diag(' can_ok() called with no methods'); + return $ok; + } + + my @nok = (); + foreach my $method (@methods) { + local($!, $@); # don't interfere with caller's $@ + # eval sometimes resets $! + eval { $proto->can($method) } || push @nok, $method; + } + + my $name; + $name = @methods == 1 ? "$class->can('$methods[0]')" + : "$class->can(...)"; + + my $ok = $Test->ok( !@nok, $name ); + + $Test->diag(map " $class->can('$_') failed\n", @nok); + + return $ok; +} + +=item B<isa_ok> + + isa_ok($object, $class, $object_name); + isa_ok($ref, $type, $ref_name); + +Checks to see if the given C<< $object->isa($class) >>. Also checks to make +sure the object was defined in the first place. Handy for this sort +of thing: + + my $obj = Some::Module->new; + isa_ok( $obj, 'Some::Module' ); + +where you'd otherwise have to write + + my $obj = Some::Module->new; + ok( defined $obj && $obj->isa('Some::Module') ); + +to safeguard against your test script blowing up. + +It works on references, too: + + isa_ok( $array_ref, 'ARRAY' ); + +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + +=cut + +sub isa_ok ($$;$) { + my($object, $class, $obj_name) = @_; + + my $diag; + $obj_name = 'The object' unless defined $obj_name; + my $name = "$obj_name isa $class"; + if( !defined $object ) { + $diag = "$obj_name isn't defined"; + } + elsif( !ref $object ) { + $diag = "$obj_name isn't a reference"; + } + else { + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + local($@, $!); # eval sometimes resets $! + my $rslt = eval { $object->isa($class) }; + if( $@ ) { + if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { + if( !UNIVERSAL::isa($object, $class) ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } else { + die <<WHOA; +WHOA! I tried to call ->isa on your object and got some weird error. +This should never happen. Please contact the author immediately. +Here's the error. +$@ +WHOA + } + } + elsif( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + + + + my $ok; + if( $diag ) { + $ok = $Test->ok( 0, $name ); + $Test->diag(" $diag\n"); + } + else { + $ok = $Test->ok( 1, $name ); + } + + return $ok; +} + + +=item B<pass> + +=item B<fail> + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an ok(). In this case, you can simply use pass() (to +declare the test ok) or fail (for not ok). They are synonyms for +ok(1) and ok(0). + +Use these very, very, very sparingly. + +=cut + +sub pass (;$) { + $Test->ok(1, @_); +} + +sub fail (;$) { + $Test->ok(0, @_); +} + +=back + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C<print STDERR>. + +=over 4 + +=item B<diag> + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C<print> @diagnostic_message is simply concatinated +together. + +Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test (foo.t at line 52) + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C<ok() or diag()> with the mnemonic C<open() or +die()>. + +All diag()s can be made silent by passing the "no_diag" option to +Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful +if you have diagnostics for personal testing but then wish to make +them silent for release without commenting out each individual +statement. + +B<NOTE> The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it it won't +interfere with the test. + +=cut + +sub diag { + return unless $Show_Diag; + $Test->diag(@_); +} + + +=back + +=head2 Module tests + +You usually want to test if the module you're testing loads ok, rather +than just vomiting if its load fails. For such purposes we have +C<use_ok> and C<require_ok>. + +=over 4 + +=item B<use_ok> + + BEGIN { use_ok($module); } + BEGIN { use_ok($module, @imports); } + +These simply use the given $module and test to make sure the load +happened ok. It's recommended that you run use_ok() inside a BEGIN +block so its functions are exported at compile-time and prototypes are +properly honored. + +If @imports are given, they are passed through to the use. So this: + + BEGIN { use_ok('Some::Module', qw(foo bar)) } + +is like doing this: + + use Some::Module qw(foo bar); + +Version numbers can be checked like so: + + # Just like "use Some::Module 1.02" + BEGIN { use_ok('Some::Module', 1.02) } + +Don't try to do this: + + BEGIN { + use_ok('Some::Module'); + + ...some code that depends on the use... + ...happening at compile time... + } + +because the notion of "compile-time" is relative. Instead, you want: + + BEGIN { use_ok('Some::Module') } + BEGIN { ...some code that depends on the use... } + + +=cut + +sub use_ok ($;@) { + my($module, @imports) = @_; + @imports = () unless @imports; + + my($pack,$filename,$line) = caller; + + local($@,$!); # eval sometimes interferes with $! + + if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { + # probably a version check. Perl needs to see the bare number + # for it to work with non-Exporter based modules. + eval <<USE; +package $pack; +use $module $imports[0]; +USE + } + else { + eval <<USE; +package $pack; +use $module \@imports; +USE + } + + my $ok = $Test->ok( !$@, "use $module;" ); + + unless( $ok ) { + chomp $@; + $@ =~ s{^BEGIN failed--compilation aborted at .*$} + {BEGIN failed--compilation aborted at $filename line $line.}m; + $Test->diag(<<DIAGNOSTIC); + Tried to use '$module'. + Error: $@ +DIAGNOSTIC + + } + + return $ok; +} + +=item B<require_ok> + + require_ok($module); + require_ok($file); + +Like use_ok(), except it requires the $module or $file. + +=cut + +sub require_ok ($) { + my($module) = shift; + + my $pack = caller; + + # Try to deterine if we've been given a module name or file. + # Module names must be barewords, files not. + $module = qq['$module'] unless _is_module_name($module); + + local($!, $@); # eval sometimes interferes with $! + eval <<REQUIRE; +package $pack; +require $module; +REQUIRE + + my $ok = $Test->ok( !$@, "require $module;" ); + + unless( $ok ) { + chomp $@; + $Test->diag(<<DIAGNOSTIC); + Tried to require '$module'. + Error: $@ +DIAGNOSTIC + + } + + return $ok; +} + + +sub _is_module_name { + my $module = shift; + + # Module names start with a letter. + # End with an alphanumeric. + # The rest is an alphanumeric or :: + $module =~ s/\b::\b//g; + $module =~ /^[a-zA-Z]\w+$/; +} + +=back + +=head2 Conditional tests + +Sometimes running a test under certain conditions will cause the +test script to die. A certain function or method isn't implemented +(such as fork() on MacOS), some resource isn't available (like a +net connection) or a module isn't available. In these cases it's +necessary to skip tests, or declare that they are supposed to fail +but will work in the future (a todo test). + +For more details on the mechanics of skip and todo tests see +L<Test::Harness>. + +The way Test::More handles this is with a named block. Basically, a +block of tests which can be skipped over or made todo. It's best if I +just show you... + +=over 4 + +=item B<SKIP: BLOCK> + + SKIP: { + skip $why, $how_many if $condition; + + ...normal testing code goes here... + } + +This declares a block of tests that might be skipped, $how_many tests +there are, $why and under what $condition to skip them. An example is +the easiest way to illustrate: + + SKIP: { + eval { require HTML::Lint }; + + skip "HTML::Lint not installed", 2 if $@; + + my $lint = new HTML::Lint; + isa_ok( $lint, "HTML::Lint" ); + + $lint->parse( $html ); + is( $lint->errors, 0, "No errors found in HTML" ); + } + +If the user does not have HTML::Lint installed, the whole block of +code I<won't be run at all>. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. + +It's important that $how_many accurately reflects the number of tests +in the SKIP block so the # of tests run will match up with your plan. +If your plan is C<no_plan> $how_many is optional and will default to 1. + +It's perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C<SKIP>, or Test::More can't work its magic. + +You don't skip tests which are failing because there's a bug in your +program, or for which you don't yet have code written. For that you +use TODO. Read on. + +=cut + +#'# +sub skip { + my($why, $how_many) = @_; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "skip() needs to know \$how_many tests are in the block" + unless $Test->has_plan eq 'no_plan'; + $how_many = 1; + } + + for( 1..$how_many ) { + $Test->skip($why); + } + + local $^W = 0; + last SKIP; +} + + +=item B<TODO: BLOCK> + + TODO: { + local $TODO = $why if $condition; + + ...normal testing code goes here... + } + +Declares a block of tests you expect to fail and $why. Perhaps it's +because you haven't fixed a bug or haven't finished a new feature: + + TODO: { + local $TODO = "URI::Geller not finished"; + + my $card = "Eight of clubs"; + is( URI::Geller->your_card, $card, 'Is THIS your card?' ); + + my $spoon; + URI::Geller->bend_spoon; + is( $spoon, 'bent', "Spoon bending, that's original" ); + } + +With a todo block, the tests inside are expected to fail. Test::More +will run the tests normally, but print out special flags indicating +they are "todo". Test::Harness will interpret failures as being ok. +Should anything succeed, it will report it as an unexpected success. +You then know the thing you had todo is done and can remove the +TODO flag. + +The nice part about todo tests, as opposed to simply commenting out a +block of tests, is it's like having a programmatic todo list. You know +how much work is left to be done, you're aware of what bugs there are, +and you'll know immediately when they're fixed. + +Once a todo test starts succeeding, simply move it outside the block. +When the block is empty, delete it. + +B<NOTE>: TODO tests require a Test::Harness upgrade else it will +treat it as a normal failure. See L<BUGS and CAVEATS>) + + +=item B<todo_skip> + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, it's best to have the tests actually run. That way +you'll know when they start passing. Sometimes this isn't possible. +Often a failing test will cause the whole program to die or hang, even +inside an C<eval BLOCK> with and using C<alarm>. In these extreme +cases you have no choice but to skip over the broken tests entirely. + +The syntax and behavior is similar to a C<SKIP: BLOCK> except the +tests will be marked as failing but todo. Test::Harness will +interpret them as passing. + +=cut + +sub todo_skip { + my($why, $how_many) = @_; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "todo_skip() needs to know \$how_many tests are in the block" + unless $Test->has_plan eq 'no_plan'; + $how_many = 1; + } + + for( 1..$how_many ) { + $Test->todo_skip($why); + } + + local $^W = 0; + last TODO; +} + +=item When do I use SKIP vs. TODO? + +B<If it's something the user might not be able to do>, use SKIP. +This includes optional modules that aren't installed, running under +an OS that doesn't have some feature (like fork() or symlinks), or maybe +you need an Internet connection and one isn't available. + +B<If it's something the programmer hasn't done yet>, use TODO. This +is for any code you haven't written yet, or bugs you have yet to fix, +but want to put tests in your testing script (always a good idea). + + +=back + +=head2 Comparison functions + +Not everything is a simple eq check or regex. There are times you +need to see if two arrays are equivalent, for instance. For these +instances, Test::More provides a handful of useful functions. + +B<NOTE> I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B<is_deeply> + + is_deeply( $this, $that, $test_name ); + +Similar to is(), except that if $this and $that are hash or array +references, it does a deep comparison walking each data structure to +see if they are equivalent. If the two structures are different, it +will display the place where they start differing. + +Test::Differences and Test::Deep provide more in-depth functionality +along these lines. + +=cut + +use vars qw(@Data_Stack %Refs_Seen); +my $DNE = bless [], 'Does::Not::Exist'; +sub is_deeply { + unless( @_ == 2 or @_ == 3 ) { + my $msg = <<WARNING; +is_deeply() takes two or three args, you gave %d. +This usually means you passed an array or hash instead +of a reference to it +WARNING + chop $msg; # clip off newline so carp() will put in line/file + + _carp sprintf $msg, scalar @_; + } + + my($this, $that, $name) = @_; + + my $ok; + if( !ref $this xor !ref $that ) { # one's a reference, one isn't + $ok = 0; + } + if( !ref $this and !ref $that ) { + $ok = $Test->is_eq($this, $that, $name); + } + else { + local @Data_Stack = (); + local %Refs_Seen = (); + if( _deep_check($this, $that) ) { + $ok = $Test->ok(1, $name); + } + else { + $ok = $Test->ok(0, $name); + $ok = $Test->diag(_format_stack(@Data_Stack)); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vars = (); + ($vars[0] = $var) =~ s/\$FOO/ \$got/; + ($vars[1] = $var) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx (0..$#vals) { + my $val = $vals[$idx]; + $vals[$idx] = !defined $val ? 'undef' : + $val eq $DNE ? "Does not exist" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + $out =~ s/^/ /msg; + return $out; +} + + +sub _type { + my $thing = shift; + + return '' if !ref $thing; + + for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) { + return $type if UNIVERSAL::isa($thing, $type); + } + + return ''; +} + + +=item B<eq_array> + + eq_array(\@this, \@that); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +sub eq_array { + local @Data_Stack; + local %Refs_Seen; + _eq_array(@_); +} + +sub _eq_array { + my($a1, $a2) = @_; + + if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { + warn "eq_array passed a non-array ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + if($Refs_Seen{$a1}) { + return $Refs_Seen{$a1} eq $a2; + } + else { + $Refs_Seen{$a1} = "$a2"; + } + + my $ok = 1; + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for (0..$max) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; + $ok = _deep_check($e1,$e2); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +sub _deep_check { + my($e1, $e2) = @_; + my $ok = 0; + + { + # Quiet uninitialized value warnings when comparing undefs. + local $^W = 0; + + $Test->_unoverload(\$e1, \$e2); + + # Either they're both references or both not. + my $same_ref = !(!ref $e1 xor !ref $e2); + + if( defined $e1 xor defined $e2 ) { + $ok = 0; + } + elsif ( $e1 == $DNE xor $e2 == $DNE ) { + $ok = 0; + } + elsif ( $same_ref and ($e1 eq $e2) ) { + $ok = 1; + } + else { + my $type = _type($e1); + $type = '' unless _type($e2) eq $type; + + if( !$type ) { + push @Data_Stack, { vals => [$e1, $e2] }; + $ok = 0; + } + elsif( $type eq 'ARRAY' ) { + $ok = _eq_array($e1, $e2); + } + elsif( $type eq 'HASH' ) { + $ok = _eq_hash($e1, $e2); + } + elsif( $type eq 'REF' ) { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + elsif( $type eq 'SCALAR' ) { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + } + } + + return $ok; +} + + +=item B<eq_hash> + + eq_hash(\%this, \%that); + +Determines if the two hashes contain the same keys and values. This +is a deep check. + +=cut + +sub eq_hash { + local @Data_Stack; + local %Refs_Seen; + return _eq_hash(@_); +} + +sub _eq_hash { + my($a1, $a2) = @_; + + if( grep !_type($_) eq 'HASH', $a1, $a2 ) { + warn "eq_hash passed a non-hash ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + if( $Refs_Seen{$a1} ) { + return $Refs_Seen{$a1} eq $a2; + } + else { + $Refs_Seen{$a1} = "$a2"; + } + + my $ok = 1; + my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; + foreach my $k (keys %$bigger) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + + push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; + $ok = _deep_check($e1, $e2); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +=item B<eq_set> + + eq_set(\@this, \@that); + +Similar to eq_array(), except the order of the elements is B<not> +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + +B<NOTE> By historical accident, this is not a true set comparision. +While the order of elements does not matter, duplicate elements do. + +=cut + +sub eq_set { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + + # There's faster ways to do this, but this is easiest. + local $^W = 0; + + # We must make sure that references are treated neutrally. It really + # doesn't matter how we sort them, as long as both arrays are sorted + # with the same algorithm. + # Have to inline the sort routine due to a threading/sort bug. + # See [rt.cpan.org 6782] + return eq_array( + [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1], + [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2] + ); +} + +=back + + +=head2 Extending and Embedding Test::More + +Sometimes the Test::More interface isn't quite enough. Fortunately, +Test::More is built on top of Test::Builder which provides a single, +unified backend for any test library to use. This means two test +libraries which both use Test::Builder B<can be used together in the +same program>. + +If you simply want to do a little tweaking of how the tests behave, +you can access the underlying Test::Builder object like so: + +=over 4 + +=item B<builder> + + my $test_builder = Test::More->builder; + +Returns the Test::Builder object underlying Test::More for you to play +with. + +=cut + +sub builder { + return Test::Builder->new; +} + +=back + + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + + +=head1 CAVEATS and NOTES + +=over 4 + +=item Backwards compatibility + +Test::More works with Perls as old as 5.004_05. + + +=item Overloaded objects + +String overloaded objects are compared B<as strings>. This prevents +Test::More from piercing an object's interface allowing better blackbox +testing. So if a function starts returning overloaded objects instead of +bare strings your tests won't notice the difference. This is good. + +However, it does mean that functions like is_deeply() cannot be used to +test the internals of string overloaded objects. In this case I would +suggest Test::Deep which contains more flexible testing functions for +complex data structures. + + +=item Threads + +Test::More will only be aware of threads if "use threads" has been done +I<before> Test::More is loaded. This is ok: + + use threads; + use Test::More; + +This may cause problems: + + use Test::More + use threads; + + +=item Test::Harness upgrade + +no_plan and todo depend on new Test::Harness features and fixes. If +you're going to distribute tests that use no_plan or todo your +end-users will have to upgrade Test::Harness to the latest one on +CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness +will work fine. + +Installing Test::More should also upgrade Test::Harness. + +=back + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's Test +module. I was largely unaware of its existence when I'd first +written my own ok() routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +L<Test::Simple> if all this confuses you and you just want to write +some tests. You can upgrade to Test::More later (it's forward +compatible). + +L<Test> is the old testing module. Its main benefit is that it has +been distributed with Perl since 5.004_05. + +L<Test::Harness> for details on how your test results are interpreted +by Perl. + +L<Test::Differences> for more ways to test complex data structures. +And it plays well with Test::More. + +L<Test::Class> is like XUnit but more perlish. + +L<Test::Deep> gives you more powerful complex data structure testing. + +L<Test::Unit> is XUnit style testing. + +L<Test::Inline> shows the idea of embedded testing. + +L<Bundle::Test> installs a whole bunch of useful test modules. + + +=head1 AUTHORS + +Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration +from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and +the perl-qa gang. + + +=head1 BUGS + +See F<http://rt.cpan.org> to report and view bugs. + + +=head1 COPYRIGHT + +Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut + +1; diff --git a/Examples/test-suite/perl5/aggregate_runme.pl b/Examples/test-suite/perl5/aggregate_runme.pl new file mode 100644 index 0000000..148ec94 --- /dev/null +++ b/Examples/test-suite/perl5/aggregate_runme.pl @@ -0,0 +1,22 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 7; +BEGIN { use_ok('aggregate') } +require_ok('aggregate'); + +# adapted from ../java/aggregate_runme.java + +# Confirm that move() returns correct results under normal use +is(aggregate::move($aggregate::UP), $aggregate::UP, "UP"); + +is(aggregate::move($aggregate::DOWN), $aggregate::DOWN, "DOWN"); + +is(aggregate::move($aggregate::LEFT), $aggregate::LEFT, "LEFT"); + +is(aggregate::move($aggregate::RIGHT), $aggregate::RIGHT, "RIGHT"); + +# Confirm that move() raises an exception when the contract is violated +eval { aggregate::move(0) }; +like($@, qr/\bRuntimeError\b/); + diff --git a/Examples/test-suite/perl5/apply_signed_char_runme.pl b/Examples/test-suite/perl5/apply_signed_char_runme.pl new file mode 100644 index 0000000..d39e4c3 --- /dev/null +++ b/Examples/test-suite/perl5/apply_signed_char_runme.pl @@ -0,0 +1,26 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 12; +BEGIN { use_ok('apply_signed_char') } +require_ok('apply_signed_char'); + +# adapted from ../java/apply_signed_char_runme.java + +my $smallnum = -127; +is(apply_signed_char::CharValFunction($smallnum), $smallnum); +is(apply_signed_char::CCharValFunction($smallnum), $smallnum); +is(apply_signed_char::CCharRefFunction($smallnum), $smallnum); + +$apply_signed_char::globalchar = $smallnum; +is($apply_signed_char::globalchar, $smallnum); +is($apply_signed_char::globalconstchar, -110); + +my $d = new apply_signed_char::DirectorTest(); +is($d->CharValFunction($smallnum), $smallnum); +is($d->CCharValFunction($smallnum), $smallnum); +is($d->CCharRefFunction($smallnum), $smallnum); + +$d->{memberchar} = $smallnum; +is($d->{memberchar}, $smallnum); +is($d->{memberconstchar}, -112); diff --git a/Examples/test-suite/perl5/apply_strings_runme.pl b/Examples/test-suite/perl5/apply_strings_runme.pl new file mode 100644 index 0000000..2cb54d1 --- /dev/null +++ b/Examples/test-suite/perl5/apply_strings_runme.pl @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('apply_strings') } +require_ok('apply_strings'); + +my $TEST_MESSAGE = "A message from target language to the C++ world and back again."; + +is(apply_strings::UCharFunction($TEST_MESSAGE), $TEST_MESSAGE, "UCharFunction"); + +is(apply_strings::SCharFunction($TEST_MESSAGE), $TEST_MESSAGE, "SCharFunction"); diff --git a/Examples/test-suite/perl5/array_member_runme.pl b/Examples/test-suite/perl5/array_member_runme.pl new file mode 100644 index 0000000..77d28fe --- /dev/null +++ b/Examples/test-suite/perl5/array_member_runme.pl @@ -0,0 +1,28 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 18; +BEGIN { use_ok('array_member') } +require_ok('array_member'); + +my $f = array_member::Foo->new(); +$f->{data} = $array_member::global_data; + +for(my $i=0; $i<8; $i++) { + is( array_member::get_value($f->{data},$i), + array_member::get_value($array_member::global_data,$i), + "array assignment"); +} + +for(my $i=0; $i<8; $i++) { + array_member::set_value($f->{data},$i,-$i); +} + +$array_member::global_data = $f->{data}; + +for(my $i=0; $i<8; $i++) { + is(array_member::get_value($f->{data},$i), + array_member::get_value($array_member::global_data,$i), + "array assignment"); +} + diff --git a/Examples/test-suite/perl5/char_strings_runme.pl b/Examples/test-suite/perl5/char_strings_runme.pl new file mode 100644 index 0000000..c457373 --- /dev/null +++ b/Examples/test-suite/perl5/char_strings_runme.pl @@ -0,0 +1,15 @@ +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('char_strings') } +require_ok('char_strings'); + +my $val1 = "100"; +is(char_strings::CharPingPong($val1), "100", 'cstr1'); + +my $val2 = "greetings"; +is(char_strings::CharPingPong($val2), "greetings", 'cstr2'); + +# SF#2564192 +"this is a test" =~ /(\w+)$/; +is(char_strings::CharPingPong($1), "test", "handles Magical"); diff --git a/Examples/test-suite/perl5/class_ignore_runme.pl b/Examples/test-suite/perl5/class_ignore_runme.pl new file mode 100755 index 0000000..989150c --- /dev/null +++ b/Examples/test-suite/perl5/class_ignore_runme.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('class_ignore') } +require_ok('class_ignore'); + +# adapted from ../python/class_ignore_runme.py + +my $a = class_ignore::Bar->new(); + +is(class_ignore::do_blah($a), "Bar::blah"); diff --git a/Examples/test-suite/perl5/contract_runme.pl b/Examples/test-suite/perl5/contract_runme.pl new file mode 100755 index 0000000..fb162e6 --- /dev/null +++ b/Examples/test-suite/perl5/contract_runme.pl @@ -0,0 +1,78 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 32; +BEGIN { use_ok('contract') } +require_ok('contract'); + +# adapted from ../python/contract_runme.py +{ + ok(contract::test_preassert(1,2), "good preassertion"); + eval { contract::test_preassert(-1) }; + like($@, qr/\bRuntimeError\b/, "bad preassertion"); + + ok(contract::test_postassert(3), "good postassertion"); + eval { contract::test_postassert(-3) }; + like($@, qr/\bRuntimeError\b/, "bad postassertion"); + + ok(contract::test_prepost(2,3), "good prepost"); + ok(contract::test_prepost(5,-4), "good prepost"); + eval { contract::test_prepost(-3,4); }; + like($@, qr/\bRuntimeError\b/, "bad preassertion"); + eval { contract::test_prepost(4,-10) }; + like($@, qr/\bRuntimeError\b/, "bad postassertion"); +} +{ + my $f = contract::Foo->new(); + ok($f->test_preassert(4,5), "method pre"); + eval { $f->test_preassert(-2,3) }; + like($@, qr/\bRuntimeError\b/, "method pre bad"); + + ok($f->test_postassert(4), "method post"); + eval { $f->test_postassert(-4) }; + like($@, qr/\bRuntimeError\b/, "method post bad"); + + ok($f->test_prepost(3,4), "method prepost"); + ok($f->test_prepost(4,-3), "method prepost"); + eval { $f->test_prepost(-4,2) }; + like($@, qr/\bRuntimeError\b/, "method pre bad"); + eval { $f->test_prepost(4,-10) }; + like($@, qr/\bRuntimeError\b/, "method post bad"); +} +{ + ok(contract::Foo::stest_prepost(4,0), "static method prepost"); + eval { contract::Foo::stest_prepost(-4,2) }; + like($@, qr/\bRuntimeError\b/, "static method pre bad"); + eval { contract::Foo::stest_prepost(4,-10) }; + like($@, qr/\bRuntimeError\b/, "static method post bad"); +} +{ + my $b = contract::Bar->new(); + eval { $b->test_prepost(2,-4) }; + like($@, qr/\bRuntimeError\b/, "inherit pre bad"); +} +{ + my $d = contract::D->new(); + eval { $d->foo(-1,1,1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->foo(1,-1,1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->foo(1,1,-1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->foo(1,1,1,-1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->foo(1,1,1,1,-1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + + eval { $d->bar(-1,1,1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->bar(1,-1,1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->bar(1,1,-1,1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->bar(1,1,1,-1,1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); + eval { $d->bar(1,1,1,1,-1) }; + like($@, qr/\bRuntimeError\b/, "inherit pre D"); +} + diff --git a/Examples/test-suite/perl5/default_args_runme.pl b/Examples/test-suite/perl5/default_args_runme.pl new file mode 100644 index 0000000..8d0d268 --- /dev/null +++ b/Examples/test-suite/perl5/default_args_runme.pl @@ -0,0 +1,85 @@ +use strict; +use warnings; +use Test::More tests => 40; +BEGIN { use_ok('default_args') } +require_ok('default_args'); + +my $true = 1; +my $false = ''; + +is(default_args::anonymous(), 7771, "anonymous (1)"); +is(default_args::anonymous(1234), 1234, "anonymous (2)"); + +is(default_args::booltest(), $true, "booltest (1)"); +is(default_args::booltest($true), $true, "booltest (2)"); +is(default_args::booltest($false), $false, "booltest (3)"); + +my $ec = new default_args::EnumClass(); +is($ec->blah(), $true, "EnumClass"); + +is(default_args::casts1(), undef, "casts1"); +is(default_args::casts2(), "Hello", "casts2"); +is(default_args::casts1("Ciao"), "Ciao", "casts1 not default"); +is(default_args::chartest1(), 'x', "chartest1"); +is(default_args::chartest2(), "\0", "chartest2"); +is(default_args::chartest1('y'), 'y', "chartest1 not default"); +is(default_args::reftest1(), 42, "reftest1"); +is(default_args::reftest1(400), 400, "reftest1 not default"); +is(default_args::reftest2(), "hello", "reftest2"); + +# rename +my $foo = new default_args::Foo(); +can_ok($foo, qw(newname renamed3arg renamed2arg renamed1arg)); +eval { + $foo->newname(); + $foo->newname(10); + $foo->renamed3arg(10, 10.0); + $foo->renamed2arg(10); + $foo->renamed1arg(); +}; +ok(not($@), '%rename handling'); + +# exception specifications +eval { default_args::exceptionspec() }; +is($@, "ciao", "exceptionspec 1"); +eval { default_args::exceptionspec(-1) }; +is($@, "ciao", "exceptionspec 2"); +eval { default_args::exceptionspec(100) }; +is($@, '100', "exceptionspec 3"); + +my $ex = new default_args::Except($false); + +my $hit = 0; +eval { $ex->exspec(); $hit = 1; }; +# a zero was thrown, an exception occured, but $@ is false +is($hit, 0, "exspec 1"); +eval { $ex->exspec(-1) }; +is($@, "ciao", "exspec 2"); +eval { $ex->exspec(100) }; +is($@, 100, "exspec 3"); +eval { $ex = default_args::Except->new($true) }; +is($@, -1, "Except constructor 1"); +eval { $ex = default_args::Except->new($true, -2) }; +is($@, -2, "Except constructor 2"); + +#Default parameters in static class methods +is(default_args::Statics::staticmethod(), 60, "staticmethod 1"); +is(default_args::Statics::staticmethod(100), 150, "staticmethod 2"); +is(default_args::Statics::staticmethod(100,200,300), 600, "staticmethod 3"); + +my $tricky = new default_args::Tricky(); +is($tricky->privatedefault(), 200, "privatedefault"); +is($tricky->protectedint(), 2000, "protectedint"); +is($tricky->protecteddouble(), 987.654, "protecteddouble"); +is($tricky->functiondefault(), 500, "functiondefault"); +is($tricky->contrived(), 'X', "contrived"); +is(default_args::constructorcall()->{val}, -1, "constructorcall test 1"); +is(default_args::constructorcall(new default_args::Klass(2222))->{val}, + 2222, "constructorcall test 2"); +is(default_args::constructorcall(new default_args::Klass())->{val}, + -1, "constructorcall test 3"); + +# const methods +my $cm = new default_args::ConstMethods(); +is($cm->coo(), 20, "coo test 1"); +is($cm->coo(1.0), 20, "coo test 2"); diff --git a/Examples/test-suite/perl5/default_constructor_runme.pl b/Examples/test-suite/perl5/default_constructor_runme.pl new file mode 100644 index 0000000..b43df9e --- /dev/null +++ b/Examples/test-suite/perl5/default_constructor_runme.pl @@ -0,0 +1,51 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 20; +BEGIN { use_ok('default_constructor') } +require_ok('default_constructor'); + +isa_ok(eval { default_constructor::A->new() }, "default_constructor::A"); +isa_ok(eval { default_constructor::AA->new() }, "default_constructor::AA"); +is( eval { default_constructor::B->new() }, undef, "private default constructor"); +isa_ok(eval { default_constructor::B->new(0, 0) }, "default_constructor::B"); +is( eval { default_constructor::BB->new() }, undef, "inherited private default constructor"); +is( eval { default_constructor::C->new() }, undef, "protected default constructor"); +isa_ok(eval { default_constructor::CC->new() }, "default_constructor::CC"); +is( eval { default_constructor::D->new() }, undef, "private constructor"); +is( eval { default_constructor::DD->new() }, undef, "inherited private constructor"); +{ local $TODO = "default_constructor.i disagrees with our result"; +is( eval { default_constructor::AD->new() }, undef, "MI on A, D"); +} +isa_ok(eval { default_constructor::E->new() }, "default_constructor::E"); +isa_ok(eval { default_constructor::EE->new() }, "default_constructor::EE"); +{ local $TODO = "default_constructor.i disagrees with our result"; +is( eval { default_constructor::EB->new() }, undef, "MI on E, B"); +} +{ local $TODO = "destructor hiding seems off"; +my $hit = 0; +eval { + my $F = default_constructor::F->new(); + undef $F; + $hit = 1; +}; +ok(not($hit), "private destructor"); +$hit = 0; +eval { + my $G = default_constructor::G->new(); + undef $G; + $hit = 1; +}; +ok(not($hit), "protected destructor"); +$hit = 0; +eval { + my $G = default_constructor::GG->new(); + undef $G; + $hit = 1; +}; +ok(not($hit), "inherited protected destructor"); +} +isa_ok(eval { default_constructor::HH->new(0, 0) }, "default_constructor::HH"); +is( eval { default_constructor::HH->new() }, undef, "templated protected constructor"); + +# TODO: sort out what needs to be tested from OSRSpatialReferenceShadow diff --git a/Examples/test-suite/perl5/disown_runme.pl b/Examples/test-suite/perl5/disown_runme.pl new file mode 100644 index 0000000..0e8f8cb --- /dev/null +++ b/Examples/test-suite/perl5/disown_runme.pl @@ -0,0 +1,10 @@ +use disown; + +if (1) { + $a = new disown::A(); + $b = new disown::B(); + $c = $b->acquire($a); +} + + + diff --git a/Examples/test-suite/perl5/dynamic_cast_runme.pl b/Examples/test-suite/perl5/dynamic_cast_runme.pl new file mode 100644 index 0000000..3940669 --- /dev/null +++ b/Examples/test-suite/perl5/dynamic_cast_runme.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('dynamic_cast') } +require_ok('dynamic_cast'); + +my $f = dynamic_cast::Foo->new(); +my $b = dynamic_cast::Bar->new(); +my $x = $f->blah(); +my $y = $b->blah(); +my $a = dynamic_cast::do_test($y); +is($a, "Bar::test"); diff --git a/Examples/test-suite/perl5/enum_template_runme.pl b/Examples/test-suite/perl5/enum_template_runme.pl new file mode 100755 index 0000000..bdaaa85 --- /dev/null +++ b/Examples/test-suite/perl5/enum_template_runme.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('enum_template') } +require_ok('enum_template'); + +# adapted from ../python/enum_template_runme.py + +is(enum_template::MakeETest(), 1); + +is(enum_template::TakeETest(0), undef); diff --git a/Examples/test-suite/perl5/enum_thorough_runme.pl b/Examples/test-suite/perl5/enum_thorough_runme.pl new file mode 100644 index 0000000..66e7192 --- /dev/null +++ b/Examples/test-suite/perl5/enum_thorough_runme.pl @@ -0,0 +1,409 @@ +# an adaptation of ../java/enum_thorough_runme.java +use strict; +use warnings; +use Test::More tests => 298; +BEGIN { use_ok('enum_thorough') } +require_ok('enum_thorough'); + +is($enum_thorough::ReallyAnInteger, 200, "Test Anon 1"); + +{ + my $red = $enum_thorough::red; + is(enum_thorough::colourTest1($red), $red, "colourTest1"); + is(enum_thorough::colourTest2($red), $red, "colourTest2"); + is(enum_thorough::colourTest3($red), $red, "colourTest3"); + is(enum_thorough::colourTest4($red), $red, "colourTest4"); + isnt($enum_thorough::myColour, $red, "colour global get"); + $enum_thorough::myColour = $red; + is($enum_thorough::myColour, $red, "colour global set"); +} +{ + my $s = enum_thorough::SpeedClass->new(); + my $speed = $enum_thorough::SpeedClass::slow; + ok(defined($speed), "SpeedClass.slow"); + is($s->speedTest1($speed), $speed, "speedTest 1"); + is($s->speedTest2($speed), $speed, "speedTest 2"); + is($s->speedTest3($speed), $speed, "speedTest 3"); + is($s->speedTest4($speed), $speed, "speedTest 4"); + is($s->speedTest5($speed), $speed, "speedTest 5"); + is($s->speedTest6($speed), $speed, "speedTest 6"); + is($s->speedTest7($speed), $speed, "speedTest 7"); + is($s->speedTest8($speed), $speed, "speedTest 8"); + is(enum_thorough::speedTest1($speed), $speed, "speedTest Global 1"); + is(enum_thorough::speedTest2($speed), $speed, "speedTest Global 2"); + is(enum_thorough::speedTest3($speed), $speed, "speedTest Global 3"); + is(enum_thorough::speedTest4($speed), $speed, "speedTest Global 4"); + is(enum_thorough::speedTest5($speed), $speed, "speedTest Global 5"); +} +{ + my $s = enum_thorough::SpeedClass->new(); + my $slow = $enum_thorough::SpeedClass::slow; + my $lightning = $enum_thorough::SpeedClass::lightning; + is($s->{mySpeedtd1}, $slow, "mySpeedtd1 1"); + is($s->{mySpeedtd1}, 10, "mySpeedtd1 2"); + $s->{mySpeedtd1} = $lightning; + is($s->{mySpeedtd1}, $lightning, "mySpeedtd1 3"); + is($s->{mySpeedtd1}, 31, "mySpeedtd1 4"); +} +is(enum_thorough::namedanonTest1($enum_thorough::NamedAnon2), + $enum_thorough::NamedAnon2, "namedanonTest1"); +{ + my $val = $enum_thorough::TwoNames2; + is(enum_thorough::twonamesTest1($val), $val, "twonamesTest 1"); + is(enum_thorough::twonamesTest2($val), $val, "twonamesTest 2"); + is(enum_thorough::twonamesTest3($val), $val, "twonamesTest 3"); +} +{ local $TODO = "shouldn't namespaces drop into a package?"; + my $val = $enum_thorough::AnonSpace::NamedAnonSpace2; + ok(defined($val), "found enum value"); +SKIP: { + skip "enum value not in expected package", 3 unless defined $val; + is(enum_thorough::namedanonspaceTest1($val), $val, "namedanonspaceTest 1"); + is(enum_thorough::namedanonspaceTest2($val), $val, "namedanonspaceTest 2"); + is(enum_thorough::namedanonspaceTest3($val), $val, "namedanonspaceTest 3"); +}} +{ + my $t = enum_thorough::TemplateClassInt->new(); + my $galileo = $enum_thorough::TemplateClassInt::galileo; + is($t->scientistsTest1($galileo), $galileo, "scientistsTest 1"); + is($t->scientistsTest2($galileo), $galileo, "scientistsTest 2"); + is($t->scientistsTest3($galileo), $galileo, "scientistsTest 3"); + is($t->scientistsTest4($galileo), $galileo, "scientistsTest 4"); + is($t->scientistsTest5($galileo), $galileo, "scientistsTest 5"); + is($t->scientistsTest6($galileo), $galileo, "scientistsTest 6"); + is($t->scientistsTest7($galileo), $galileo, "scientistsTest 7"); + is($t->scientistsTest8($galileo), $galileo, "scientistsTest 8"); + is($t->scientistsTest9($galileo), $galileo, "scientistsTest 9"); + is($t->scientistsTestB($galileo), $galileo, "scientistsTest B"); + is($t->scientistsTestD($galileo), $galileo, "scientistsTest D"); + is($t->scientistsTestE($galileo), $galileo, "scientistsTest E"); + is($t->scientistsTestF($galileo), $galileo, "scientistsTest F"); + is($t->scientistsTestG($galileo), $galileo, "scientistsTest G"); + is($t->scientistsTestH($galileo), $galileo, "scientistsTest H"); + is($t->scientistsTestI($galileo), $galileo, "scientistsTest I"); + is($t->scientistsTestJ($galileo), $galileo, "scientistsTest J"); + + is(enum_thorough::scientistsTest1($galileo), $galileo, "scientistsTest Global 1"); + is(enum_thorough::scientistsTest2($galileo), $galileo, "scientistsTest Global 2"); + is(enum_thorough::scientistsTest3($galileo), $galileo, "scientistsTest Global 3"); + is(enum_thorough::scientistsTest4($galileo), $galileo, "scientistsTest Global 4"); + is(enum_thorough::scientistsTest5($galileo), $galileo, "scientistsTest Global 5"); + is(enum_thorough::scientistsTest6($galileo), $galileo, "scientistsTest Global 6"); + is(enum_thorough::scientistsTest7($galileo), $galileo, "scientistsTest Global 7"); + is(enum_thorough::scientistsTest8($galileo), $galileo, "scientistsTest Global 8"); +} +{ + my $t = enum_thorough::TClassInt->new(); + my $bell = $enum_thorough::TClassInt::bell; + my $galileo = $enum_thorough::TemplateClassInt::galileo; + is($t->scientistsNameTest1($bell), $bell, "scientistsNameTest 1"); + is($t->scientistsNameTest2($bell), $bell, "scientistsNameTest 2"); + is($t->scientistsNameTest3($bell), $bell, "scientistsNameTest 3"); + is($t->scientistsNameTest4($bell), $bell, "scientistsNameTest 4"); + is($t->scientistsNameTest5($bell), $bell, "scientistsNameTest 5"); + is($t->scientistsNameTest6($bell), $bell, "scientistsNameTest 6"); + is($t->scientistsNameTest7($bell), $bell, "scientistsNameTest 7"); + is($t->scientistsNameTest8($bell), $bell, "scientistsNameTest 8"); + is($t->scientistsNameTest9($bell), $bell, "scientistsNameTest 9"); + is($t->scientistsNameTestB($bell), $bell, "scientistsNameTest B"); + is($t->scientistsNameTestD($bell), $bell, "scientistsNameTest D"); + is($t->scientistsNameTestE($bell), $bell, "scientistsNameTest E"); + is($t->scientistsNameTestF($bell), $bell, "scientistsNameTest F"); + is($t->scientistsNameTestG($bell), $bell, "scientistsNameTest G"); + is($t->scientistsNameTestH($bell), $bell, "scientistsNameTest H"); + is($t->scientistsNameTestI($bell), $bell, "scientistsNameTest I"); + + is($t->scientistsNameSpaceTest1($bell), $bell, "scientistsNameSpaceTest 1"); + is($t->scientistsNameSpaceTest2($bell), $bell, "scientistsNameSpaceTest 2"); + is($t->scientistsNameSpaceTest3($bell), $bell, "scientistsNameSpaceTest 3"); + is($t->scientistsNameSpaceTest4($bell), $bell, "scientistsNameSpaceTest 4"); + is($t->scientistsNameSpaceTest5($bell), $bell, "scientistsNameSpaceTest 5"); + is($t->scientistsNameSpaceTest6($bell), $bell, "scientistsNameSpaceTest 6"); + is($t->scientistsNameSpaceTest7($bell), $bell, "scientistsNameSpaceTest 7"); + + is($t->scientistsOtherTest1($galileo), $galileo, "scientistsOtherTest 1"); + is($t->scientistsOtherTest2($galileo), $galileo, "scientistsOtherTest 2"); + is($t->scientistsOtherTest3($galileo), $galileo, "scientistsOtherTest 3"); + is($t->scientistsOtherTest4($galileo), $galileo, "scientistsOtherTest 4"); + is($t->scientistsOtherTest5($galileo), $galileo, "scientistsOtherTest 5"); + is($t->scientistsOtherTest6($galileo), $galileo, "scientistsOtherTest 6"); + is($t->scientistsOtherTest7($galileo), $galileo, "scientistsOtherTest 7"); + + is(enum_thorough::scientistsNameTest1($bell), $bell, "scientistsNameTest Global 1"); + is(enum_thorough::scientistsNameTest2($bell), $bell, "scientistsNameTest Global 2"); + is(enum_thorough::scientistsNameTest3($bell), $bell, "scientistsNameTest Global 3"); + is(enum_thorough::scientistsNameTest4($bell), $bell, "scientistsNameTest Global 4"); + is(enum_thorough::scientistsNameTest5($bell), $bell, "scientistsNameTest Global 5"); + is(enum_thorough::scientistsNameTest6($bell), $bell, "scientistsNameTest Global 6"); + is(enum_thorough::scientistsNameTest7($bell), $bell, "scientistsNameTest Global 7"); + + is(enum_thorough::scientistsNameSpaceTest1($bell), $bell, "scientistsNameSpaceTest Global 1"); + is(enum_thorough::scientistsNameSpaceTest2($bell), $bell, "scientistsNameSpaceTest Global 2"); + is(enum_thorough::scientistsNameSpaceTest3($bell), $bell, "scientistsNameSpaceTest Global 3"); + is(enum_thorough::scientistsNameSpaceTest4($bell), $bell, "scientistsNameSpaceTest Global 4"); + is(enum_thorough::scientistsNameSpaceTest5($bell), $bell, "scientistsNameSpaceTest Global 5"); + is(enum_thorough::scientistsNameSpaceTest6($bell), $bell, "scientistsNameSpaceTest Global 6"); + is(enum_thorough::scientistsNameSpaceTest7($bell), $bell, "scientistsNameSpaceTest Global 7"); + + is(enum_thorough::scientistsNameSpaceTest8($bell), $bell, "scientistsNameSpaceTest Global 8"); + is(enum_thorough::scientistsNameSpaceTest9($bell), $bell, "scientistsNameSpaceTest Global 9"); + is(enum_thorough::scientistsNameSpaceTestA($bell), $bell, "scientistsNameSpaceTest Global A"); + is(enum_thorough::scientistsNameSpaceTestB($bell), $bell, "scientistsNameSpaceTest Global B"); + is(enum_thorough::scientistsNameSpaceTestC($bell), $bell, "scientistsNameSpaceTest Global C"); + is(enum_thorough::scientistsNameSpaceTestD($bell), $bell, "scientistsNameSpaceTest Global D"); + is(enum_thorough::scientistsNameSpaceTestE($bell), $bell, "scientistsNameSpaceTest Global E"); + + is(enum_thorough::scientistsNameSpaceTestF($bell), $bell, "scientistsNameSpaceTest Global F"); + is(enum_thorough::scientistsNameSpaceTestG($bell), $bell, "scientistsNameSpaceTest Global G"); + is(enum_thorough::scientistsNameSpaceTestH($bell), $bell, "scientistsNameSpaceTest Global H"); + is(enum_thorough::scientistsNameSpaceTestI($bell), $bell, "scientistsNameSpaceTest Global I"); + is(enum_thorough::scientistsNameSpaceTestJ($bell), $bell, "scientistsNameSpaceTest Global J"); + is(enum_thorough::scientistsNameSpaceTestK($bell), $bell, "scientistsNameSpaceTest Global K"); + is(enum_thorough::scientistsNameSpaceTestL($bell), $bell, "scientistsNameSpaceTest Global L"); +} +{ + my $val = $enum_thorough::argh; + is(enum_thorough::renameTest1($val), $val, "renameTest Global 1"); + is(enum_thorough::renameTest2($val), $val, "renameTest Global 2"); +} +{ + my $n = enum_thorough::NewNameStruct->new(); + is($n->renameTest1($enum_thorough::NewNameStruct::bang), $enum_thorough::NewNameStruct::bang, "renameTest 1"); + is($n->renameTest2($enum_thorough::NewNameStruct::bang), $enum_thorough::NewNameStruct::bang, "renameTest 2"); + is($n->renameTest3($enum_thorough::NewNameStruct::simple1), $enum_thorough::NewNameStruct::simple1, "renameTest 3"); + is($n->renameTest4($enum_thorough::NewNameStruct::doublename1), $enum_thorough::NewNameStruct::doublename1, "renameTest 4"); + is($n->renameTest5($enum_thorough::NewNameStruct::doublename1), $enum_thorough::NewNameStruct::doublename1, "renameTest 5"); + is($n->renameTest6($enum_thorough::NewNameStruct::singlename1), $enum_thorough::NewNameStruct::singlename1, "renameTest 6"); +} +{ + is(enum_thorough::renameTest3($enum_thorough::NewNameStruct::bang), $enum_thorough::NewNameStruct::bang, "renameTest Global 3"); + is(enum_thorough::renameTest4($enum_thorough::NewNameStruct::simple1), $enum_thorough::NewNameStruct::simple1, "renameTest Global 4"); + is(enum_thorough::renameTest5($enum_thorough::NewNameStruct::doublename1), $enum_thorough::NewNameStruct::doublename1, "renameTest Global 5"); + is(enum_thorough::renameTest6($enum_thorough::NewNameStruct::doublename1), $enum_thorough::NewNameStruct::doublename1, "renameTest Global 6"); + is(enum_thorough::renameTest7($enum_thorough::NewNameStruct::singlename1), $enum_thorough::NewNameStruct::singlename1, "renameTest Global 7"); +} +{ + my $t = enum_thorough::TreesClass->new(); + my $pine = $enum_thorough::TreesClass::pine; + is($t->treesTest1($pine), $pine, "treesTest 1"); + is($t->treesTest2($pine), $pine, "treesTest 2"); + is($t->treesTest3($pine), $pine, "treesTest 3"); + is($t->treesTest4($pine), $pine, "treesTest 4"); + is($t->treesTest5($pine), $pine, "treesTest 5"); + is($t->treesTest6($pine), $pine, "treesTest 6"); + is($t->treesTest7($pine), $pine, "treesTest 7"); + is($t->treesTest8($pine), $pine, "treesTest 8"); + is($t->treesTest9($pine), $pine, "treesTest 9"); + is($t->treesTestA($pine), $pine, "treesTest A"); + is($t->treesTestB($pine), $pine, "treesTest B"); + is($t->treesTestC($pine), $pine, "treesTest C"); + is($t->treesTestD($pine), $pine, "treesTest D"); + is($t->treesTestE($pine), $pine, "treesTest E"); + is($t->treesTestF($pine), $pine, "treesTest F"); + is($t->treesTestG($pine), $pine, "treesTest G"); + is($t->treesTestH($pine), $pine, "treesTest H"); + is($t->treesTestI($pine), $pine, "treesTest I"); + is($t->treesTestJ($pine), $pine, "treesTest J"); + is($t->treesTestK($pine), $pine, "treesTest K"); + is($t->treesTestL($pine), $pine, "treesTest L"); + is($t->treesTestM($pine), $pine, "treesTest M"); + is($t->treesTestN($pine), $pine, "treesTest N"); + is($t->treesTestO($pine), $pine, "treesTest O"); + + is(enum_thorough::treesTest1($pine), $pine, "treesTest Global 1"); + is(enum_thorough::treesTest2($pine), $pine, "treesTest Global 2"); + is(enum_thorough::treesTest3($pine), $pine, "treesTest Global 3"); + is(enum_thorough::treesTest4($pine), $pine, "treesTest Global 4"); + is(enum_thorough::treesTest5($pine), $pine, "treesTest Global 5"); + is(enum_thorough::treesTest6($pine), $pine, "treesTest Global 6"); + is(enum_thorough::treesTest7($pine), $pine, "treesTest Global 7"); + is(enum_thorough::treesTest8($pine), $pine, "treesTest Global 8"); + is(enum_thorough::treesTest9($pine), $pine, "treesTest Global 9"); + is(enum_thorough::treesTestA($pine), $pine, "treesTest Global A"); + is(enum_thorough::treesTestB($pine), $pine, "treesTest Global B"); + is(enum_thorough::treesTestC($pine), $pine, "treesTest Global C"); + is(enum_thorough::treesTestD($pine), $pine, "treesTest Global D"); + is(enum_thorough::treesTestE($pine), $pine, "treesTest Global E"); + is(enum_thorough::treesTestF($pine), $pine, "treesTest Global F"); + is(enum_thorough::treesTestG($pine), $pine, "treesTest Global G"); + is(enum_thorough::treesTestH($pine), $pine, "treesTest Global H"); + is(enum_thorough::treesTestI($pine), $pine, "treesTest Global I"); + is(enum_thorough::treesTestJ($pine), $pine, "treesTest Global J"); + is(enum_thorough::treesTestK($pine), $pine, "treesTest Global K"); + is(enum_thorough::treesTestL($pine), $pine, "treesTest Global L"); + is(enum_thorough::treesTestM($pine), $pine, "treesTest Global M"); + is(enum_thorough::treesTestO($pine), $pine, "treesTest Global O"); + is(enum_thorough::treesTestP($pine), $pine, "treesTest Global P"); + is(enum_thorough::treesTestQ($pine), $pine, "treesTest Global Q"); + is(enum_thorough::treesTestR($pine), $pine, "treesTest Global R"); +} +{ + my $h = enum_thorough::HairStruct->new(); + my $ginger = $enum_thorough::HairStruct::ginger; + + is($h->hairTest1($ginger), $ginger, "hairTest 1"); + is($h->hairTest2($ginger), $ginger, "hairTest 2"); + is($h->hairTest3($ginger), $ginger, "hairTest 3"); + is($h->hairTest4($ginger), $ginger, "hairTest 4"); + is($h->hairTest5($ginger), $ginger, "hairTest 5"); + is($h->hairTest6($ginger), $ginger, "hairTest 6"); + is($h->hairTest7($ginger), $ginger, "hairTest 7"); + is($h->hairTest8($ginger), $ginger, "hairTest 8"); + is($h->hairTest9($ginger), $ginger, "hairTest 9"); + is($h->hairTestA($ginger), $ginger, "hairTest A"); + is($h->hairTestB($ginger), $ginger, "hairTest B"); + + my $red = $enum_thorough::red; + is($h->colourTest1($red), $red, "colourTest HairStruct 1"); + is($h->colourTest2($red), $red, "colourTest HairStruct 2"); + is($h->namedanonTest1($enum_thorough::NamedAnon2), $enum_thorough::NamedAnon2, "namedanonTest HairStruct 1"); +{ local $TODO = "shouldn't namespaces drop into a package?"; + ok(defined($enum_thorough::AnonSpace::NamedAnonSpace2), "found enum value"); +SKIP: { + skip "enum value not in expected package", 1 unless defined $enum_thorough::AnonSpace::NamedAnonSpace2; + is($h->namedanonspaceTest1($enum_thorough::AnonSpace::NamedAnonSpace2), $enum_thorough::AnonSpace::NamedAnonSpace2, "namedanonspaceTest HairStruct 1"); +}} + + + my $fir = $enum_thorough::TreesClass::fir; + is($h->treesGlobalTest1($fir), $fir, "treesGlobalTest1 HairStruct 1"); + is($h->treesGlobalTest2($fir), $fir, "treesGlobalTest1 HairStruct 2"); + is($h->treesGlobalTest3($fir), $fir, "treesGlobalTest1 HairStruct 3"); + is($h->treesGlobalTest4($fir), $fir, "treesGlobalTest1 HairStruct 4"); +} +{ + my $blonde = $enum_thorough::HairStruct::blonde; + is(enum_thorough::hairTest1($blonde), $blonde, "hairTest Global 1"); + is(enum_thorough::hairTest2($blonde), $blonde, "hairTest Global 2"); + is(enum_thorough::hairTest3($blonde), $blonde, "hairTest Global 3"); + is(enum_thorough::hairTest4($blonde), $blonde, "hairTest Global 4"); + is(enum_thorough::hairTest5($blonde), $blonde, "hairTest Global 5"); + is(enum_thorough::hairTest6($blonde), $blonde, "hairTest Global 6"); + is(enum_thorough::hairTest7($blonde), $blonde, "hairTest Global 7"); + is(enum_thorough::hairTest8($blonde), $blonde, "hairTest Global 8"); + is(enum_thorough::hairTest9($blonde), $blonde, "hairTest Global 9"); + is(enum_thorough::hairTestA($blonde), $blonde, "hairTest Global A"); + is(enum_thorough::hairTestB($blonde), $blonde, "hairTest Global B"); + is(enum_thorough::hairTestC($blonde), $blonde, "hairTest Global C"); + + is(enum_thorough::hairTestA1($blonde), $blonde, "hairTest Global A1"); + is(enum_thorough::hairTestA2($blonde), $blonde, "hairTest Global A2"); + is(enum_thorough::hairTestA3($blonde), $blonde, "hairTest Global A3"); + is(enum_thorough::hairTestA4($blonde), $blonde, "hairTest Global A4"); + is(enum_thorough::hairTestA5($blonde), $blonde, "hairTest Global A5"); + is(enum_thorough::hairTestA6($blonde), $blonde, "hairTest Global A6"); + is(enum_thorough::hairTestA7($blonde), $blonde, "hairTest Global A7"); + is(enum_thorough::hairTestA8($blonde), $blonde, "hairTest Global A8"); + is(enum_thorough::hairTestA9($blonde), $blonde, "hairTest Global A9"); + is(enum_thorough::hairTestAA($blonde), $blonde, "hairTest Global AA"); + is(enum_thorough::hairTestAB($blonde), $blonde, "hairTest Global AB"); + is(enum_thorough::hairTestAC($blonde), $blonde, "hairTest Global AC"); + + is(enum_thorough::hairTestB1($blonde), $blonde, "hairTest Global B1"); + is(enum_thorough::hairTestB2($blonde), $blonde, "hairTest Global B2"); + is(enum_thorough::hairTestB3($blonde), $blonde, "hairTest Global B3"); + is(enum_thorough::hairTestB4($blonde), $blonde, "hairTest Global B4"); + is(enum_thorough::hairTestB5($blonde), $blonde, "hairTest Global B5"); + is(enum_thorough::hairTestB6($blonde), $blonde, "hairTest Global B6"); + is(enum_thorough::hairTestB7($blonde), $blonde, "hairTest Global B7"); + is(enum_thorough::hairTestB8($blonde), $blonde, "hairTest Global B8"); + is(enum_thorough::hairTestB9($blonde), $blonde, "hairTest Global B9"); + is(enum_thorough::hairTestBA($blonde), $blonde, "hairTest Global BA"); + is(enum_thorough::hairTestBB($blonde), $blonde, "hairTest Global BB"); + is(enum_thorough::hairTestBC($blonde), $blonde, "hairTest Global BC"); + + is(enum_thorough::hairTestC1($blonde), $blonde, "hairTest Global C1"); + is(enum_thorough::hairTestC2($blonde), $blonde, "hairTest Global C2"); + is(enum_thorough::hairTestC3($blonde), $blonde, "hairTest Global C3"); + is(enum_thorough::hairTestC4($blonde), $blonde, "hairTest Global C4"); + is(enum_thorough::hairTestC5($blonde), $blonde, "hairTest Global C5"); + is(enum_thorough::hairTestC6($blonde), $blonde, "hairTest Global C6"); + is(enum_thorough::hairTestC7($blonde), $blonde, "hairTest Global C7"); + is(enum_thorough::hairTestC8($blonde), $blonde, "hairTest Global C8"); + is(enum_thorough::hairTestC9($blonde), $blonde, "hairTest Global C9"); + is(enum_thorough::hairTestCA($blonde), $blonde, "hairTest Global CA"); + is(enum_thorough::hairTestCB($blonde), $blonde, "hairTest Global CB"); + is(enum_thorough::hairTestCC($blonde), $blonde, "hairTest Global CC"); +} +{ + my $f = enum_thorough::FirStruct->new(); + my $blonde = $enum_thorough::HairStruct::blonde; + + is($f->hairTestFir1($blonde), $blonde, "hairTestFir 1"); + is($f->hairTestFir2($blonde), $blonde, "hairTestFir 2"); + is($f->hairTestFir3($blonde), $blonde, "hairTestFir 3"); + is($f->hairTestFir4($blonde), $blonde, "hairTestFir 4"); + is($f->hairTestFir5($blonde), $blonde, "hairTestFir 5"); + is($f->hairTestFir6($blonde), $blonde, "hairTestFir 6"); + is($f->hairTestFir7($blonde), $blonde, "hairTestFir 7"); + is($f->hairTestFir8($blonde), $blonde, "hairTestFir 8"); + is($f->hairTestFir9($blonde), $blonde, "hairTestFir 9"); + is($f->hairTestFirA($blonde), $blonde, "hairTestFir A"); +} +{ + $enum_thorough::GlobalInstance = $enum_thorough::globalinstance2; + is($enum_thorough::GlobalInstance, $enum_thorough::globalinstance2, "GlobalInstance 1"); + + my $i = enum_thorough::Instances->new(); + $i->{MemberInstance} = $enum_thorough::Instances::memberinstance3; + is($i->{MemberInstance}, $enum_thorough::Instances::memberinstance3, "MemberInstance 1"); +} +# ignore enum item tests start +{ + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_zero), 0, "ignoreATest 0"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_three), 3, "ignoreATest 3"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_ten), 10, "ignoreATest 10"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_eleven), 11, "ignoreATest 11"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_thirteen), 13, "ignoreATest 13"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_fourteen), 14, "ignoreATest 14"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_twenty), 20, "ignoreATest 20"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_thirty), 30, "ignoreATest 30"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_thirty_two), 32, "ignoreATest 32"); + is(enum_thorough::ignoreATest($enum_thorough::IgnoreTest::ignoreA_thirty_three), 33, "ignoreATest 33"); +} +{ + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_eleven), 11, "ignoreBTest 11"); + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_twelve), 12, "ignoreBTest 12"); + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_thirty_one), 31, "ignoreBTest 31"); + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_thirty_two), 32, "ignoreBTest 32"); + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_forty_one), 41, "ignoreBTest 41"); + is(enum_thorough::ignoreBTest($enum_thorough::IgnoreTest::ignoreB_forty_two), 42, "ignoreBTest 42"); +} +{ + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_ten), 10, "ignoreCTest 10"); + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_twelve), 12, "ignoreCTest 12"); + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_thirty), 30, "ignoreCTest 30"); + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_thirty_two), 32, "ignoreCTest 32"); + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_forty), 40, "ignoreCTest 40"); + is(enum_thorough::ignoreCTest($enum_thorough::IgnoreTest::ignoreC_forty_two), 42, "ignoreCTest 42"); +} +{ + is(enum_thorough::ignoreDTest($enum_thorough::IgnoreTest::ignoreD_twenty_one), 21, "ignoreDTest 21"); + is(enum_thorough::ignoreDTest($enum_thorough::IgnoreTest::ignoreD_twenty_two), 22, "ignoreDTest 22"); +} +{ + is(enum_thorough::ignoreETest($enum_thorough::IgnoreTest::ignoreE_zero), 0, "ignoreETest 0"); + is(enum_thorough::ignoreETest($enum_thorough::IgnoreTest::ignoreE_twenty_one), 21, "ignoreETest 21"); + is(enum_thorough::ignoreETest($enum_thorough::IgnoreTest::ignoreE_twenty_two), 22, "ignoreETest 22"); +} +# ignore enum item tests end +{ + is(enum_thorough::repeatTest($enum_thorough::one), 1, "repeatTest 1"); + is(enum_thorough::repeatTest($enum_thorough::initial), 1, "repeatTest 2"); + is(enum_thorough::repeatTest($enum_thorough::two), 2, "repeatTest 3"); + is(enum_thorough::repeatTest($enum_thorough::three), 3, "repeatTest 4"); + is(enum_thorough::repeatTest($enum_thorough::llast), 3, "repeatTest 5"); + is(enum_thorough::repeatTest($enum_thorough::end), 3, "repeatTest 6"); +} + +# these were the preexisting Perl testcases before the port. + +# Just test an in and out typemap for enum SWIGTYPE and const enum SWIGTYPE & typemaps +is(enum_thorough::speedTest4($enum_thorough::SpeedClass::slow), + $enum_thorough::SpeedClass::slow, "speedTest Global 4"); +is(enum_thorough::speedTest5($enum_thorough::SpeedClass::slow), + $enum_thorough::SpeedClass::slow, "speedTest Global 5"); +is(enum_thorough::speedTest4($enum_thorough::SpeedClass::fast), + $enum_thorough::SpeedClass::fast, "speedTest Global 4"); +is(enum_thorough::speedTest5($enum_thorough::SpeedClass::fast), + $enum_thorough::SpeedClass::fast, "speedTest Global 5"); diff --git a/Examples/test-suite/perl5/exception_order_runme.pl b/Examples/test-suite/perl5/exception_order_runme.pl new file mode 100644 index 0000000..79b1b9d --- /dev/null +++ b/Examples/test-suite/perl5/exception_order_runme.pl @@ -0,0 +1,25 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 7; +BEGIN { use_ok('exception_order') } +require_ok('exception_order'); + +# adapted from ../python/exception_order_runme.py + +my $a = exception_order::A->new(); + +eval { $a->foo() }; +isa_ok($@, "exception_order::E1"); + +eval { $a->bar() }; +isa_ok($@, "exception_order::E2"); + +eval { $a->foobar() }; +like($@, qr/\bpostcatch unknown\b/); + +eval { $a->barfoo(1) }; +isa_ok($@, "exception_order::E1"); + +eval { $a->barfoo(2) }; +isa_ok($@, "exception_order::E2"); diff --git a/Examples/test-suite/perl5/global_vars_runme.pl b/Examples/test-suite/perl5/global_vars_runme.pl new file mode 100644 index 0000000..b645f7b --- /dev/null +++ b/Examples/test-suite/perl5/global_vars_runme.pl @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('global_vars') } +require_ok('global_vars'); + +my $an = new global_vars::A(); +isa_ok($an, 'global_vars::A'); +$global_vars::ap = $an; +is($global_vars::ap, $an, "global var assignment"); + diff --git a/Examples/test-suite/perl5/grouping_runme.pl b/Examples/test-suite/perl5/grouping_runme.pl new file mode 100755 index 0000000..2009cce --- /dev/null +++ b/Examples/test-suite/perl5/grouping_runme.pl @@ -0,0 +1,17 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok('grouping') } +require_ok('grouping'); + +# adapted from ../python/grouping_runme.py + +is(grouping::test1(42), 42); + +isnt(eval { grouping::test2(42) }, undef); + +is(grouping::do_unary(37, $grouping::NEGATE), -37); + +$grouping::test3 = 42; +is($grouping::test3, 42); diff --git a/Examples/test-suite/perl5/ignore_parameter_runme.pl b/Examples/test-suite/perl5/ignore_parameter_runme.pl new file mode 100755 index 0000000..8e75e0b --- /dev/null +++ b/Examples/test-suite/perl5/ignore_parameter_runme.pl @@ -0,0 +1,33 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 14; +BEGIN { use_ok('ignore_parameter') } +require_ok('ignore_parameter'); + +# adapted from ../java/ignore_parameter_runme.java + +# Runtime test checking the %typemap(ignore) macro + +# Compilation will ensure the number of arguments and type are correct. +# Then check the return value is the same as the value given to the ignored parameter. +is(ignore_parameter::jaguar(200, 0.0), "hello", "jaguar()"); +is(ignore_parameter::lotus("fast", 0.0), 101, "lotus()"); +is(ignore_parameter::tvr("fast", 200), 8.8, "tvr()"); +is(ignore_parameter::ferrari(), 101, "ferrari()"); + +my $sc = new ignore_parameter::SportsCars(); +is($sc->daimler(200, 0.0), "hello", "daimler()"); +is($sc->astonmartin("fast", 0.0), 101, "astonmartin()"); +is($sc->bugatti("fast", 200), 8.8, "bugatti()"); +is($sc->lamborghini(), 101, "lamborghini()"); + +# Check constructors are also generated correctly +my $mc = eval { new ignore_parameter::MiniCooper(200, 0.0) }; +isa_ok($mc, 'ignore_parameter::MiniCooper'); +my $mm = eval { new ignore_parameter::MorrisMinor("slow", 0.0) }; +isa_ok($mm, 'ignore_parameter::MorrisMinor'); +my $fa = eval { new ignore_parameter::FordAnglia("slow", 200) }; +isa_ok($fa, 'ignore_parameter::FordAnglia'); +my $aa = eval { new ignore_parameter::AustinAllegro() }; +isa_ok($aa, 'ignore_parameter::AustinAllegro'); diff --git a/Examples/test-suite/perl5/import_nomodule_runme.pl b/Examples/test-suite/perl5/import_nomodule_runme.pl new file mode 100644 index 0000000..f2136c1 --- /dev/null +++ b/Examples/test-suite/perl5/import_nomodule_runme.pl @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('import_nomodule') } +require_ok('import_nomodule'); + +my $f = import_nomodule::create_Foo(); +import_nomodule::test1($f,42); +ok(1, "basecase"); + +my $b = new import_nomodule::Bar(); +import_nomodule::test1($b,37); +ok(1, "testcase"); diff --git a/Examples/test-suite/perl5/imports_runme.pl b/Examples/test-suite/perl5/imports_runme.pl new file mode 100644 index 0000000..fd730fe --- /dev/null +++ b/Examples/test-suite/perl5/imports_runme.pl @@ -0,0 +1,5 @@ +use imports_b; +use imports_a; + +$x = imports_bc::new_B(); +imports_ac::A_hello($x); diff --git a/Examples/test-suite/perl5/inctest_runme.pl b/Examples/test-suite/perl5/inctest_runme.pl new file mode 100644 index 0000000..db78c66 --- /dev/null +++ b/Examples/test-suite/perl5/inctest_runme.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('inctest') } +require_ok('inctest'); + +my $things = inctest::MY_THINGS->new(); +my $i = 0; +$things->{IntegerMember} = $i; +my $d = $things->{DoubleMember}; +ok(1); diff --git a/Examples/test-suite/perl5/inherit_missing_runme.pl b/Examples/test-suite/perl5/inherit_missing_runme.pl new file mode 100755 index 0000000..bc22602 --- /dev/null +++ b/Examples/test-suite/perl5/inherit_missing_runme.pl @@ -0,0 +1,20 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('inherit_missing') } +require_ok('inherit_missing'); + +# adapted from ../python/inherit_missing_runme.py + +my $a = inherit_missing::new_Foo(); +my $b = inherit_missing::Bar->new(); +my $c = inherit_missing::Spam->new(); + +is(inherit_missing::do_blah($a), "Foo::blah"); + +is(inherit_missing::do_blah($b), "Bar::blah"); + +is(inherit_missing::do_blah($c), "Spam::blah"); + +inherit_missing::delete_Foo($a); diff --git a/Examples/test-suite/perl5/inherit_runme.pl b/Examples/test-suite/perl5/inherit_runme.pl new file mode 100644 index 0000000..3add80d --- /dev/null +++ b/Examples/test-suite/perl5/inherit_runme.pl @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('inherit') } +require_ok('inherit'); + +my $der = new inherit::CDerived(); +is($der->Foo(), "CBase::Foo", "inherit test"); + diff --git a/Examples/test-suite/perl5/li_carrays_runme.pl b/Examples/test-suite/perl5/li_carrays_runme.pl new file mode 100644 index 0000000..00d12cd --- /dev/null +++ b/Examples/test-suite/perl5/li_carrays_runme.pl @@ -0,0 +1,72 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 38; +BEGIN { use_ok('li_carrays') } +require_ok('li_carrays'); + +# array_class +{ + my $length = 5; + my $xyArray = new li_carrays::XYArray($length); + for (my $i=0; $i<$length; $i++) { + my $xy = $xyArray->getitem($i); + $xy->{x} = $i*10; + $xy->{y} = $i*100; + $xyArray->setitem($i, $xy); + } + for (my $i=0; $i<$length; $i++) { + is($xyArray->getitem($i)->{x}, $i*10); + is($xyArray->getitem($i)->{y}, $i*100); + } +} + +{ + # global array variable + my $length = 5; + my $xyArrayPointer = $li_carrays::globalXYArray; + my $xyArray = li_carrays::XYArray::frompointer($xyArrayPointer); + for (my $i=0; $i<$length; $i++) { + my $xy = $xyArray->getitem($i); + $xy->{x} = $i*10; + $xy->{y} = $i*100; + $xyArray->setitem($i, $xy); + } + for (my $i=0; $i<$length; $i++) { + is($xyArray->getitem($i)->{x}, $i*10); + is($xyArray->getitem($i)->{y}, $i*100); + } +} + +# array_functions +{ + my $length = 5; + my $abArray = li_carrays::new_ABArray($length); + for (my $i=0; $i<$length; $i++) { + my $ab = li_carrays::ABArray_getitem($abArray, $i); + $ab->{a} = $i*10; + $ab->{b} = $i*100; + li_carrays::ABArray_setitem($abArray, $i, $ab); + } + for (my $i=0; $i<$length; $i++) { + is(li_carrays::ABArray_getitem($abArray, $i)->{a}, $i*10); + is(li_carrays::ABArray_getitem($abArray, $i)->{b}, $i*100); + } + li_carrays::delete_ABArray($abArray); +} + +{ + # global array variable + my $length = 3; + my $abArray = $li_carrays::globalABArray; + for (my $i=0; $i<$length; $i++) { + my $ab = li_carrays::ABArray_getitem($abArray, $i); + $ab->{a} = $i*10; + $ab->{b} = $i*100; + li_carrays::ABArray_setitem($abArray, $i, $ab); + } + for (my $i=0; $i<$length; $i++) { + is(li_carrays::ABArray_getitem($abArray, $i)->{a}, $i*10); + is(li_carrays::ABArray_getitem($abArray, $i)->{b}, $i*100); + } +} diff --git a/Examples/test-suite/perl5/li_cdata_carrays_runme.pl b/Examples/test-suite/perl5/li_cdata_carrays_runme.pl new file mode 100644 index 0000000..133006e --- /dev/null +++ b/Examples/test-suite/perl5/li_cdata_carrays_runme.pl @@ -0,0 +1,14 @@ +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('li_cdata_carrays') } +require_ok('li_cdata_carrays'); + +my $ia = li_cdata_carrays::intArray->new(5); +for (0..4) { + $ia->setitem($_, $_**2); +} +ok(1, "setitems"); +my $x = pack q{I5}, map $_**2, (0..4); +my $y = li_cdata_carrays::cdata_int($ia->cast, 5); +is($x, $y, "carrays"); diff --git a/Examples/test-suite/perl5/li_reference_runme.pl b/Examples/test-suite/perl5/li_reference_runme.pl new file mode 100644 index 0000000..afbd9e0 --- /dev/null +++ b/Examples/test-suite/perl5/li_reference_runme.pl @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More tests => 68; +BEGIN { use_ok('li_reference') } +require_ok('li_reference'); + +sub chk { my($type, $call, $v1, $v2) = @_; + $li_reference::FrVal = $v1; + my $v = $v2; + eval { $call->(\$v) }; + is($@, '', "$type check"); + is($li_reference::ToVal, $v2, "$type out"); + is($v, $v1, "$type in"); +} +chk("double*", \&li_reference::PDouble, 12.2, 18.6); +chk("double&", \&li_reference::RDouble, 32.5, 64.8); +chk("float*", \&li_reference::PFloat, 64.5, 96.0); +chk("float&", \&li_reference::RFloat, 98.5, 6.25); +chk("int*", \&li_reference::PInt, 1887, 3356); +chk("int&", \&li_reference::RInt, 2622, 9867); +chk("short*", \&li_reference::PShort, 4752, 3254); +chk("short&", \&li_reference::RShort, 1898, 5757); +chk("long*", \&li_reference::PLong, 6687, 7132); +chk("long&", \&li_reference::RLong, 8346, 4398); +chk("uint*", \&li_reference::PUInt, 6853, 5529); +chk("uint&", \&li_reference::RUInt, 5483, 7135); +chk("ushort*", \&li_reference::PUShort, 9960, 9930); +chk("ushort&", \&li_reference::RUShort, 1193, 4178); +chk("ulong*", \&li_reference::PULong, 7960, 4788); +chk("ulong&", \&li_reference::RULong, 8829, 1603); +chk("uchar*", \&li_reference::PUChar, 110, 239); +chk("uchar&", \&li_reference::RUChar, 15, 97); +chk("char*", \&li_reference::PChar, -7, 118); +chk("char&", \&li_reference::RChar, -3, -107); +chk("bool*", \&li_reference::PBool, 0, 1); +chk("bool&", \&li_reference::RBool, 1, 0); diff --git a/Examples/test-suite/perl5/li_std_except_runme.pl b/Examples/test-suite/perl5/li_std_except_runme.pl new file mode 100755 index 0000000..59d3126 --- /dev/null +++ b/Examples/test-suite/perl5/li_std_except_runme.pl @@ -0,0 +1,46 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 22; +BEGIN { use_ok('li_std_except') } +require_ok('li_std_except'); + +# adapted from ../java/li_std_except_runme.java + +# these are not prescriptive tests, they just match the error classes I +# found are currently being issued, we may want to provide a more +# granular error api later, so don't let these tests stop code +# improvements. + +my $test = new li_std_except::Test(); +eval { $test->throw_bad_exception() }; +like($@, qr/\bSystemError\b/, "throw_bad_exception"); +eval { $test->throw_domain_error() }; +like($@, qr/\bValueError\b/, "throw_domain_error"); +like($@, qr/\boops\b/, "throw_domain_error message"); +eval { $test->throw_exception() }; +like($@, qr/\bSystemError\b/, "throw_exception"); +eval { $test->throw_invalid_argument() }; +like($@, qr/\bValueError\b/, "throw_invalid_argument"); +like($@, qr/\boops\b/, "throw_invalid_argument message"); +eval { $test->throw_length_error() }; +like($@, qr/\bIndexError\b/, "throw_length_error"); +like($@, qr/\boops\b/, "throw_length_error message"); +eval { $test->throw_logic_error() }; +like($@, qr/\bRuntimeError\b/, "throw_logic_error"); +like($@, qr/\boops\b/, "throw_logic_error message"); +eval { $test->throw_out_of_range() }; +like($@, qr/\bIndexError\b/, "throw_out_of_range"); +like($@, qr/\boops\b/, "throw_out_of_range message"); +eval { $test->throw_overflow_error() }; +like($@, qr/\bOverflowError\b/, "throw_overflow_error"); +like($@, qr/\boops\b/, "throw_overflow_error message"); +eval { $test->throw_range_error() }; +like($@, qr/\bOverflowError\b/, "throw_range_error"); +like($@, qr/\boops\b/, "throw_range_error message"); +eval { $test->throw_runtime_error() }; +like($@, qr/\bRuntimeError\b/, "throw_runtime_error"); +like($@, qr/\boops\b/, "throw_runtime_error message"); +eval { $test->throw_underflow_error() }; +like($@, qr/\bOverflowError\b/, "throw_underflow_error"); +like($@, qr/\boops\b/, "throw_underflow_error message"); diff --git a/Examples/test-suite/perl5/li_std_string_runme.pl b/Examples/test-suite/perl5/li_std_string_runme.pl new file mode 100644 index 0000000..9ec7dd0 --- /dev/null +++ b/Examples/test-suite/perl5/li_std_string_runme.pl @@ -0,0 +1,113 @@ +use strict; +use warnings; +use Test::More tests => 30; +BEGIN { use_ok('li_std_string') } +require_ok('li_std_string'); + +use Devel::Peek; +# Checking expected use of %typemap(in) std::string {} +li_std_string::test_value("Fee"); + +# Checking expected result of %typemap(out) std::string {} +is(li_std_string::test_value("Fi"), "Fi", "Test 1"); + + +# Verify type-checking for %typemap(in) std::string {} +eval { li_std_string::test_value(undef) }; +like($@, qr/\bTypeError\b/, "Test 2"); + +# Checking expected use of %typemap(in) const std::string & {} +li_std_string::test_const_reference("Fo"); + +# Checking expected result of %typemap(out) const std::string& {} +is(li_std_string::test_const_reference("Fum"), "Fum", "Test 3"); + +# Verify type-checking for %typemap(in) const std::string & {} +eval { li_std_string::test_const_reference(undef) }; +like($@, qr/\bValueError\b/, "Test 4"); + +# +# Input and output typemaps for pointers and non-const references to +# std::string are *not* supported; the following tests confirm +# that none of these cases are slipping through. +# + +my $stringPtr = undef; + +$stringPtr = li_std_string::test_pointer_out(); + +li_std_string::test_pointer($stringPtr); + +$stringPtr = li_std_string::test_const_pointer_out(); + +li_std_string::test_const_pointer($stringPtr); + +$stringPtr = li_std_string::test_reference_out(); + +li_std_string::test_reference($stringPtr); + +# Check throw exception specification +eval { li_std_string::test_throw() }; +is($@, "test_throw message", "Test 5"); +{ local $TODO = "why is the error not a Perl string?"; +eval { li_std_string::test_const_reference_throw() }; +is($@, "<some kind of string>", "Test 6"); +} + +# Global variables +my $s = "initial string"; +is($li_std_string::GlobalString2, "global string 2", "GlobalString2 test 1"); +$li_std_string::GlobalString2 = $s; +is($li_std_string::GlobalString2, $s, "GlobalString2 test 2"); +is($li_std_string::ConstGlobalString, "const global string", "ConstGlobalString test"); + +# Member variables +my $myStructure = new li_std_string::Structure(); +is($myStructure->{MemberString2}, "member string 2", "MemberString2 test 1"); +$myStructure->{MemberString2} = $s; +is($myStructure->{MemberString2}, $s, "MemberString2 test 2"); +is($myStructure->{ConstMemberString}, "const member string", "ConstMemberString test"); + +is($li_std_string::Structure::StaticMemberString2, "static member string 2", "StaticMemberString2 test 1"); +$li_std_string::Structure::StaticMemberString2 = $s; +is($li_std_string::Structure::StaticMemberString2, $s, "StaticMemberString2 test 2"); +is($li_std_string::Structure::ConstStaticMemberString, "const static member string", "ConstStaticMemberString test"); + +is(li_std_string::test_reference_input("hello"), "hello", "reference_input"); + +is(li_std_string::test_reference_inout("hello"), "hellohello", "reference_inout"); + + +no strict; +my $gen1 = new li_std_string::Foo(); +is($gen1->test(1), 2, "ulonglong"); +is($gen1->test("1"), "11", "ulonglong"); +is($gen1->testl(12345), 12346, "ulonglong small number"); +# Note: 32 bit builds of perl will fail this test as the number is stored internally in scientific notation +# (USE_64_BIT_ALL probably needs defining when building Perl in order to avoid this) +SKIP: { + skip "this Perl does not seem to do 64 bit ints", 1 + if 9234567890121111114 - 9234567890121111113 != 1; + local $TODO; + use Config; + $TODO = "if we're lucky this might work" unless $Config{use64bitall}; + is(eval { $gen1->testl(9234567890121111113) }, 9234567890121111114, "ulonglong big number"); + # TODO: I suspect we can get by with "use64bitint", but I'll have to + # work that out later. -talby +} +is($gen1->testl("9234567890121111113"), "9234567890121111114", "ulonglong big number"); + + +is(li_std_string::stdstring_empty(), "", "stdstring_empty"); + +is(li_std_string::c_empty(), "", "c_empty"); + + +is(li_std_string::c_null(), undef, "c_empty"); + + +is(li_std_string::get_null(li_std_string::c_null()), undef, "c_empty"); + +is(li_std_string::get_null(li_std_string::c_empty()), "non-null", "c_empty"); + +is(li_std_string::get_null(li_std_string::stdstring_empty()), "non-null", "stdstring_empty"); diff --git a/Examples/test-suite/perl5/li_typemaps_runme.pl b/Examples/test-suite/perl5/li_typemaps_runme.pl new file mode 100644 index 0000000..c182cdb --- /dev/null +++ b/Examples/test-suite/perl5/li_typemaps_runme.pl @@ -0,0 +1,82 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 415; +BEGIN { use_ok('li_typemaps') } +require_ok('li_typemaps'); + +sub batch { my($type, @values) = @_; + # this is a little ugly because I'm trying to be clever and save my + # wrists from hammering out all these tests. + for my $val (@values) { + for my $tst (qw( + in inr + out outr + inout inoutr + )) { + my $func = $tst . '_' . $type; + is(eval { li_typemaps->can($func)->($val) }, $val, "$func $val"); + if($@) { + my $err = $@; + $err =~ s/^/#\$\@# /mg; + print $err; + } + } + } +} + +batch('bool', '', 1); +# let's assume we're at least on a 32 bit machine +batch('int', -0x80000000, -1, 0, 1, 12, 0x7fffffff); +# long could be bigger, but it's at least this big +batch('long', -0x80000000, -1, 0, 1, 12, 0x7fffffff); +batch('short', -0x8000, -1, 0, 1, 12, 0x7fff); +batch('uint', 0, 1, 12, 0xffffffff); +batch('ushort', 0, 1, 12, 0xffff); +batch('ulong', 0, 1, 12, 0xffffffff); +batch('uchar', 0, 1, 12, 0xff); +batch('schar', -0x80, 0, 1, 12, 0x7f); + +{ + use Math::BigInt qw(); + # the pack dance is to get plain old NVs out of the + # Math::BigInt objects. + my $inf = unpack 'd', pack 'd', Math::BigInt->binf(); + my $nan = unpack 'd', pack 'd', Math::BigInt->bnan(); + batch('float', + -(2 - 2 ** -23) * 2 ** 127, + -1, -2 ** -149, 0, 2 ** -149, 1, + (2 - 2 ** -23) * 2 ** 127, + $nan); + { local $TODO = "float typemaps don't pass infinity"; + # it seems as though SWIG is unwilling to pass infinity around + # because that value always fails bounds checking. I think that + # is a bug. + batch('float', $inf); + } + batch('double', + -(2 - 2 ** -53) ** 1023, + -1, -2 ** -1074, 0, 2 ** 1074, + (2 - 2 ** -53) ** 1023, + $nan, $inf); +} +batch('longlong', -1, 0, 1, 12); +batch('ulonglong', 0, 1, 12); +SKIP: { + my $a = "8000000000000000"; + my $b = "7fffffffffffffff"; + my $c = "ffffffffffffffff"; + skip "not a 64bit Perl", 18 unless eval { pack 'q', 1 }; + batch('longlong', -hex($a), hex($b)); + batch('ulonglong', hex($c)); +} + +my($foo, $int) = li_typemaps::out_foo(10); +isa_ok($foo, 'li_typemaps::Foo'); +is($foo->{a}, 10); +is($int, 20); + +my($a, $b) = li_typemaps::inoutr_int2(13, 31); +is($a, 13); +is($b, 31); + diff --git a/Examples/test-suite/perl5/member_pointer_runme.pl b/Examples/test-suite/perl5/member_pointer_runme.pl new file mode 100644 index 0000000..ff2cee7 --- /dev/null +++ b/Examples/test-suite/perl5/member_pointer_runme.pl @@ -0,0 +1,51 @@ +use strict; +use warnings; +use Test::More tests => 9; +# member_pointer using pointers to member functions + +BEGIN { use_ok('member_pointer') } +require_ok('member_pointer'); + +sub check($;$;$) { + my($what, $expected, $actual) = @_; + if ($expected != $actual) { + die ("Failed: $what Expected: $expected Actual: $actual"); + } +} + +# Get the pointers + +my $area_pt = member_pointer::areapt(); +my $perim_pt = member_pointer::perimeterpt(); + +# Create some objects + +my $s = new member_pointer::Square(10); + +# Do some calculations + +is(100.0, member_pointer::do_op($s,$area_pt), "Square area"); +is(40.0, member_pointer::do_op($s,$perim_pt), "Square perim"); +no strict; + +my $memberPtr = $member_pointer::areavar; +$memberPtr = $member_pointer::perimetervar; + +# Try the variables +is(100.0, member_pointer::do_op($s,$member_pointer::areavar), "Square area"); +is(40.0, member_pointer::do_op($s,$member_pointer::perimetervar), "Square perim"); + +# Modify one of the variables +$member_pointer::areavar = $perim_pt; + +is(40.0, member_pointer::do_op($s,$member_pointer::areavar), "Square perimeter"); + +# Try the constants + +$memberPtr = $member_pointer::AREAPT; +$memberPtr = $member_pointer::PERIMPT; +$memberPtr = $member_pointer::NULLPT; + +is(100.0, member_pointer::do_op($s,$member_pointer::AREAPT), "Square area"); +is(40.0, member_pointer::do_op($s,$member_pointer::PERIMPT), "Square perim"); + diff --git a/Examples/test-suite/perl5/minherit_runme.pl b/Examples/test-suite/perl5/minherit_runme.pl new file mode 100755 index 0000000..1f3afad --- /dev/null +++ b/Examples/test-suite/perl5/minherit_runme.pl @@ -0,0 +1,72 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 38; +BEGIN { use_ok('minherit') } +require_ok('minherit'); + +# adapted from ../python/minherit_runme.py + +my $a = minherit::Foo->new(); +my $b = minherit::Bar->new(); +my $c = minherit::FooBar->new(); +my $d = minherit::Spam->new(); + +is($a->xget(), 1); + +is($b->yget(), 2); + +is($c->xget(), 1); +is($c->yget(), 2); +is($c->zget(), 3); + +is($d->xget(), 1); +is($d->yget(), 2); +is($d->zget(), 3); +is($d->wget(), 4); + +is(minherit::xget($a), 1); + +is(minherit::yget($b), 2); + +is(minherit::xget($c), 1); +is(minherit::yget($c), 2); +is(minherit::zget($c), 3); + +is(minherit::xget($d), 1); +is(minherit::yget($d), 2); +is(minherit::zget($d), 3); +is(minherit::wget($d), 4); + +# Cleanse all of the pointers and see what happens + +my $aa = minherit::toFooPtr($a); +my $bb = minherit::toBarPtr($b); +my $cc = minherit::toFooBarPtr($c); +my $dd = minherit::toSpamPtr($d); + +is($aa->xget, 1); + +is($bb->yget(), 2); + +is($cc->xget(), 1); +is($cc->yget(), 2); +is($cc->zget(), 3); + +is($dd->xget(), 1); +is($dd->yget(), 2); +is($dd->zget(), 3); +is($dd->wget(), 4); + +is(minherit::xget($aa), 1); + +is(minherit::yget($bb), 2); + +is(minherit::xget($cc), 1); +is(minherit::yget($cc), 2); +is(minherit::zget($cc), 3); + +is(minherit::xget($dd), 1); +is(minherit::yget($dd), 2); +is(minherit::zget($dd), 3); +is(minherit::wget($dd), 4); diff --git a/Examples/test-suite/perl5/multiple_inheritance_runme.pl b/Examples/test-suite/perl5/multiple_inheritance_runme.pl new file mode 100644 index 0000000..1d913ff --- /dev/null +++ b/Examples/test-suite/perl5/multiple_inheritance_runme.pl @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('multiple_inheritance') } +require_ok('multiple_inheritance'); + +my $fooBar = new multiple_inheritance::FooBar(); +is($fooBar->foo(), 2, "Runtime test1"); + +is($fooBar->bar(), 1, "Runtime test2"); + +is($fooBar->fooBar(), 3, "Runtime test3 "); diff --git a/Examples/test-suite/perl5/naturalvar_runme.pl b/Examples/test-suite/perl5/naturalvar_runme.pl new file mode 100755 index 0000000..c0f972d --- /dev/null +++ b/Examples/test-suite/perl5/naturalvar_runme.pl @@ -0,0 +1,22 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('naturalvar') } +require_ok('naturalvar'); + +# adapted from ../python/naturalvar_runme.py + +my $f = naturalvar::Foo->new(); +isa_ok($f, 'naturalvar::Foo'); +my $b = naturalvar::Bar->new(); +isa_ok($b, 'naturalvar::Bar'); + +$b->{f} = $f; + +$naturalvar::s = "hello"; + +$b->{s} = "hello"; + +is($naturalvar::s, $b->{s}); + diff --git a/Examples/test-suite/perl5/operator_overload_break_runme.pl b/Examples/test-suite/perl5/operator_overload_break_runme.pl new file mode 100644 index 0000000..fd3fe33 --- /dev/null +++ b/Examples/test-suite/perl5/operator_overload_break_runme.pl @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 9; + +use operator_overload_break; + +# Workaround for +# ok( not (expression) , "test description" ); +# does not working in older versions of Perl, eg 5.004_04 +sub ok_not ($;$) { + my($test, $name) = @_; + $test = not $test; + ok($test, $name); +} + +pass("loaded"); + +my $op = operator_overload_break::Op->new(5); + +isa_ok($op, "operator_overload_break::Op"); + +ok((2 == $op - 3), + "subtraction"); + +$op->{k} = 37; + +ok((40 == $op + 3), + "addition"); + +$op->{k} = 22; + +ok((10 == (32 - $op)), + "reversed subtraction"); + +ok_not((3 == $op), + 'not equal'); + +$op->{k} = 3; + +++$op; + +ok(($op == 4), + "pre-increment operator"); + +$op++; + +ok(($op == 5), + "post-increment operator"); + +my $op2 = ++$op; + +$op2 = $op++; + +ok(($op == 7) and ($op2 == 7), + "multiple post-increments"); diff --git a/Examples/test-suite/perl5/operator_overload_runme.pl b/Examples/test-suite/perl5/operator_overload_runme.pl new file mode 100644 index 0000000..ba3f33a --- /dev/null +++ b/Examples/test-suite/perl5/operator_overload_runme.pl @@ -0,0 +1,175 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 39; + +use operator_overload; + +# Workaround for +# ok( not (expression) , "test description" ); +# does not working in older versions of Perl, eg 5.004_04 +sub ok_not ($;$) { + my($test, $name) = @_; + $test = not $test; + ok($test, $name); +} + +pass("loaded"); + +# first check all the operators are implemented correctly from pure C++ code +operator_overloadc::Op_sanity_check(); + +my $op = operator_overload::Op->new(); + +isa_ok($op, "operator_overload::Op"); + +my $op2 = operator_overload::Op->new(); + +isa_ok($op2, "operator_overload::Op"); + +# operator equal +$op->{i} = 5; +$op2->{i} = 3; + +ok_not(($op == $op2), "operator equal: not equal"); + +$op->{i} = 3; +ok(($op == $op2), "operator equal: equal"); + +# operator not equal +$op->{i} = 5; +$op2->{i} = 3; + +ok(($op != $op2), "operator not equal: not equal"); + +$op->{i} = 3; +ok_not(($op != $op2), "operator not equal: equal"); + +# stringify operator +$op->{i} = 3; +is("Op(3)", "$op", "operator stringify"); + +# addition operator +$op->{i} = 3; +$op2->{i} = 3; +my $op3 = $op + $op2; +is($op3->{i}, 6, "operator addition"); + +# addition assignment operator +$op->{i} = 3; +$op2->{i} = 3; +$op += $op2; +is($op->{i}, 6, "operator additive assignment"); + +# subtraction operator +$op3->{i} = 6; +$op2->{i} = 3; +$op = $op3 - $op2; +is($op->{i}, 3, "operator subtraction"); + +# reversed subtraction operator (with int) +$op3->{i} = 3; +$op = 6 - $op3; +is($op->{i}, 3, "reversed operator subtraction (with int)"); + +# subtractive assignment operator +$op->{i} = 6; +$op2->{i} = 3; +$op -= $op2; +is($op->{i}, 3, "operator subtractive assignment"); + +# multiplication operator +$op->{i} = 3; +$op2->{i} = 3; +$op3 = $op * $op2; +is($op3->{i}, 9, "operator multiplication"); + +# division operator +$op->{i} = 9; +$op2->{i} = 3; +$op3 = $op / $op2; +is($op3->{i}, 3, "operator division"); + +# modulus operator +$op->{i} = 8; +$op2->{i} = 3; +$op3 = $op % $op2; +is($op3->{i}, 2, "operator modulus"); + +# greater than operator +$op->{i} = 8; +$op2->{i} = 3; +ok($op > $op2, "operator greater than"); +ok_not(($op2 > $op), "operator greater than"); +$op->{i} = 3; +ok_not(($op2 > $op), "operator greater than"); +ok_not(($op > $op2), "operator greater than"); + +# greater than or equal operator +$op->{i} = 8; +$op2->{i} = 3; +ok($op >= $op2, "operator greater than or equal"); +ok_not(($op2 >= $op), "operator greater than or equal"); +$op->{i} = 3; +ok(($op2 >= $op), "operator greater than or equal"); +ok(($op >= $op2), "operator greater than or equal"); + +# lesser than operator +$op2->{i} = 8; +$op->{i} = 3; +ok($op < $op2, "operator lesser than"); +ok_not(($op2 < $op), "operator lesser than"); +$op2->{i} = 3; +ok_not(($op2 < $op), "operator lesser than"); +ok_not(($op < $op2), "operator lesser than"); + +# less than or equal operator +$op2->{i} = 8; +$op->{i} = 3; +ok($op <= $op2, "operator lesser than or equal"); +ok_not(($op2 <= $op), "operator lesser than or equal"); +$op2->{i} = 3; +ok(($op2 <= $op), "operator less than or equal"); +ok(($op <= $op2), "operator less than or equal"); + +# post-increment operator +$op->{i} = 7; +$op++; +is($op->{i}, 8, "operator post-increment"); + +# pre-increment operator +$op->{i} = 7; +++$op; +is($op->{i}, 8, "operator pre-increment"); + +# post-decrement operator +$op->{i} = 7; +$op--; +is($op->{i}, 6, "operator post-decrement"); + +# pre-decrement operator +$op->{i} = 7; +--$op; +is($op->{i}, 6, "operator pre-decrement"); + +# neg operator +$op->{i} = 3; +$op2 = -$op; +is($op2->{i}, -3, "operator neg"); + +# not operator +$op->{i} = 0; +is(!$op, !0, "operator not"); + +$op->{i} = 1; +is(!$op, !1, "operator not"); + +### # and operator +### $op->{i} = 4; +### $op2->{i} = 2; +### +### is($op & $op2, 4 & 2, "operator and"); +### +### isnt(($op & $op2), (10 & 2), "operator and - false"); + +# fail("testing failed condition"); + diff --git a/Examples/test-suite/perl5/overload_copy_runme.pl b/Examples/test-suite/perl5/overload_copy_runme.pl new file mode 100644 index 0000000..06d03f5 --- /dev/null +++ b/Examples/test-suite/perl5/overload_copy_runme.pl @@ -0,0 +1,5 @@ + +use overload_copy; + +$f = new overload_copy::Foo(); +$g = new overload_copy::Foo($f); diff --git a/Examples/test-suite/perl5/overload_simple_runme.pl b/Examples/test-suite/perl5/overload_simple_runme.pl new file mode 100644 index 0000000..27719aa --- /dev/null +++ b/Examples/test-suite/perl5/overload_simple_runme.pl @@ -0,0 +1,191 @@ +#!/usr/bin/perl -w +use overload_simple; +use vars qw/$DOWARN/; +use strict; +use Test::More tests => 71; + +pass("loaded"); + +my $f = new overload_simple::Foo(); +isa_ok($f, "overload_simple::Foo"); +my $b = new overload_simple::Bar(); +isa_ok($b, "overload_simple::Bar"); +my $v = overload_simple::malloc_void(32); +isa_ok($v, "_p_void"); + + +# +# Silence warnings about bad types +# +BEGIN { $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN } } +# +#these tests should 'fail' +# +eval { overload_simple::fint("l") }; +ok($@, "fint(int) - int"); + +eval { overload_simple::fint("3.5") }; +ok($@, "fint(int) - double"); + +eval { overload_simple::fdouble("l") }; +ok($@, "fint(double) - int"); + +eval { overload_simple::fdouble("1.5/2.0") }; +ok($@, "fint(double) - double"); + +# +#enable the warnings again +# +$DOWARN =1; + +# +# 'simple' dispatch (no overload) of int and double arguments +# + +is(overload_simple::fint(3), "fint:int", "fint(int) - int"); + +is(overload_simple::fint("1"), "fint:int", "fint(int) - string int"); + +is(overload_simple::fint(3.0), "fint:int", "fint(int) - double"); + +is(overload_simple::fint("3.0"), "fint:int", "fint(int) - string double"); + +# old bad case that now works +my $n = 3; +$n = $n + 1; +is(overload_simple::fint($n), "fint:int", "fint(int) - int var"); + +is(overload_simple::fint(4/2), "fint:int", "fint(int) - divide int denom"); + +is(overload_simple::fint(4/2.0), "fint:int", "fint(int) - divide double denom"); + +is(overload_simple::fdouble(3), "fdouble:double", "fdouble(double) - int"); + +is(overload_simple::fdouble("3"), "fdouble:double", "fdouble(double) - string int"); + +is(overload_simple::fdouble(3.0), "fdouble:double", "fdouble(double) - double"); + +is(overload_simple::fdouble("3.0"), "fdouble:double", "fdouble(double) - string doubl"); + +# +# Overload between int and double +# +is(overload_simple::num(3), "num:int", "num(int) - int"); + +is(overload_simple::num("3"), "num:int", "num(int) - string int"); + +is(overload_simple::num(3.0), "num:double", "num(int) - double"); + +is(overload_simple::num("3.0"), "num:double", "num(int) - string double"); + +# +# Overload between int, double, char * and many types. +# +is(overload_simple::foo(3), "foo:int", "foo:int - int"); + +is(overload_simple::foo(3.0), "foo:double", "foo:double - double"); + +is(overload_simple::foo("3"), "foo:char *", "foo:char * - string int"); + +is(overload_simple::foo("3.0"), "foo:char *", "foo:char * - string double"); + +is(overload_simple::foo("hello"), "foo:char *", "foo:char * string"); + +is(overload_simple::foo($f), "foo:Foo *", "foo:Foo *"); + +is(overload_simple::foo($b), "foo:Bar *", "foo:Bar *"); + +is(overload_simple::foo($v), "foo:void *", "foo:void *"); + +is(overload_simple::blah(3), "blah:double", "blah:double"); + +is(overload_simple::blah("hello"), "blah:char *", "blah:char *"); + +my $s = new overload_simple::Spam(); + +is($s->foo(3), "foo:int", "Spam::foo:int"); + +is($s->foo(3.0), "foo:double", "Spam::foo(double)"); + +is($s->foo("hello"), "foo:char *", "Spam::foo:char *"); + +is($s->foo($f), "foo:Foo *", "Spam::foo(Foo *)"); + +is($s->foo($b), "foo:Bar *", "Spam::foo(Bar *)"); + +is($s->foo($v), "foo:void *", "Spam::foo(void *)"); + +is(overload_simple::Spam::bar(3), "bar:int", "Spam::bar(int)"); + +is(overload_simple::Spam::bar(3.0), "bar:double", "Spam::bar(double)"); + +is(overload_simple::Spam::bar("hello"), "bar:char *", "Spam::bar(char *)"); + +is(overload_simple::Spam::bar($f), "bar:Foo *", "Spam::bar(Foo *)"); + +is(overload_simple::Spam::bar($b), "bar:Bar *", "Spam::bar(Bar *)"); + +is(overload_simple::Spam::bar($v), "bar:void *", "Spam::bar(void *)"); + +# Test constructors + +$s = new overload_simple::Spam(); +isa_ok($s, "overload_simple::Spam"); + +is($s->{type}, "none", "Spam()"); + +$s = new overload_simple::Spam(3); +isa_ok($s, "overload_simple::Spam"); + +is($s->{type}, "int", "Spam(int)"); + +$s = new overload_simple::Spam(3.0); +isa_ok($s, "overload_simple::Spam"); +is($s->{type}, "double", "Spam(double)"); + +$s = new overload_simple::Spam("hello"); +isa_ok($s, "overload_simple::Spam"); +is($s->{type}, "char *", "Spam(char *)"); + +$s = new overload_simple::Spam($f); +isa_ok($s, "overload_simple::Spam"); +is($s->{type}, "Foo *", "Spam(Foo *)"); + +$s = new overload_simple::Spam($b); +isa_ok($s, "overload_simple::Spam"); +is($s->{type}, "Bar *", "Spam(Bar *)"); + +$s = new overload_simple::Spam($v); +isa_ok($s, "overload_simple::Spam"); +is($s->{type}, "void *", "Spam(void *)"); + +# +# Combine dispatch +# + + +is(overload_simple::fid(3, 3.0), "fid:intdouble", "fid(int,double)"); + +is(overload_simple::fid(3.0, 3), "fid:doubleint", "fid(double,int)"); + +is(overload_simple::fid(3.0, 3.0), "fid:doubledouble", "fid(double,double)"); + +is(overload_simple::fid(3, 3), "fid:intint", "fid(int,int)"); + +# with strings now + +is(overload_simple::fid(3, "3.0"), "fid:intdouble", "fid(int,double)"); + +is(overload_simple::fid("3", 3.0), "fid:intdouble", "fid(int,double)"); + +is(overload_simple::fid("3", "3.0"), "fid:intdouble", "fid(int,double)"); + +is(overload_simple::fid(3.0, "3"), "fid:doubleint", "fid(double,int)"); + +is(overload_simple::fid("3.0", "3.0"), "fid:doubledouble", "fid:doubledouble"); + +is(overload_simple::fid("3", 3), "fid:intint", "fid:fid(int,int)"); + +isnt(overload_simple::fbool(0), overload_simple::fbool(1), "fbool(bool)"); + +is(2, overload_simple::fbool(2), "fbool(int)"); diff --git a/Examples/test-suite/perl5/packageoption_runme.pl b/Examples/test-suite/perl5/packageoption_runme.pl new file mode 100644 index 0000000..d94a7a1 --- /dev/null +++ b/Examples/test-suite/perl5/packageoption_runme.pl @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 4; + +BEGIN { use_ok('packageoption_a'); } +BEGIN { use_ok('packageoption_b'); } + +# Workaround for +# ok( not (expression) , "test description" ); +# does not working in older versions of Perl, eg 5.004_04 +sub ok_not ($;$) { + my($test, $name) = @_; + $test = not $test; + ok($test, $name); +} + +my $a = CommonPackage::A->new(); + +isa_ok($a, 'CommonPackage::A'); + +my $b = CommonPackage::B->new(); + +isa_ok($b, 'CommonPackage::B'); + diff --git a/Examples/test-suite/perl5/preproc_runme.pl b/Examples/test-suite/perl5/preproc_runme.pl new file mode 100755 index 0000000..89e25f8 --- /dev/null +++ b/Examples/test-suite/perl5/preproc_runme.pl @@ -0,0 +1,14 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok('preproc') } +require_ok('preproc'); + +# adapted from ../python/preproc_runme.py + +is($preproc::endif, 1); +is($preproc::define, 1); +is($preproc::defined, 1); +is($preproc::one * 2, $preproc::two); + diff --git a/Examples/test-suite/perl5/primitive_ref_runme.pl b/Examples/test-suite/perl5/primitive_ref_runme.pl new file mode 100644 index 0000000..20d37a7 --- /dev/null +++ b/Examples/test-suite/perl5/primitive_ref_runme.pl @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More tests => 14; +BEGIN { use_ok('primitive_ref') } +require_ok('primitive_ref'); + +is(primitive_ref::ref_int(3), 3, "ref_int"); +is(primitive_ref::ref_uint(3), 3, "ref_uint"); +is(primitive_ref::ref_short(3), 3, "ref_short"); +is(primitive_ref::ref_ushort(3), 3, "ref_ushort"); +is(primitive_ref::ref_long(3), 3, "ref_long"); +is(primitive_ref::ref_ulong(3), 3, "ref_ulong"); +is(primitive_ref::ref_schar(3), 3, "ref_schar"); +is(primitive_ref::ref_uchar(3), 3, "ref_uchar"); +is(primitive_ref::ref_bool(1), 1, "ref_bool"); +is(primitive_ref::ref_float(3.5), 3.5, "ref_float"); +is(primitive_ref::ref_double(3.5), 3.5, "ref_double"); +is(primitive_ref::ref_char('x'), 'x', "ref_char"); diff --git a/Examples/test-suite/perl5/primitive_types_runme.pl b/Examples/test-suite/perl5/primitive_types_runme.pl new file mode 100755 index 0000000..6d7b05d --- /dev/null +++ b/Examples/test-suite/perl5/primitive_types_runme.pl @@ -0,0 +1,282 @@ +use strict; +use warnings; +use Test::More tests => 54; +BEGIN { use_ok('primitive_types') } +require_ok('primitive_types'); + +primitive_types::var_init(); + +# assigning globals calls +$primitive_types::var_bool = $primitive_types::sct_bool; +$primitive_types::var_schar = $primitive_types::sct_schar; +$primitive_types::var_uchar = $primitive_types::sct_uchar; +$primitive_types::var_int = $primitive_types::sct_int; +$primitive_types::var_uint = $primitive_types::sct_uint; +$primitive_types::var_short = $primitive_types::sct_short; +$primitive_types::var_ushort = $primitive_types::sct_ushort; +$primitive_types::var_long = $primitive_types::sct_long; +$primitive_types::var_ulong = $primitive_types::sct_ulong; +$primitive_types::var_llong = $primitive_types::sct_llong; +$primitive_types::var_ullong = $primitive_types::sct_ullong; +$primitive_types::var_char = $primitive_types::sct_char; +$primitive_types::var_pchar = $primitive_types::sct_pchar; +$primitive_types::var_pcharc = $primitive_types::sct_pcharc; +$primitive_types::var_pint = $primitive_types::sct_pint; +$primitive_types::var_sizet = $primitive_types::sct_sizet; +$primitive_types::var_hello = $primitive_types::sct_hello; +$primitive_types::var_myint = $primitive_types::sct_myint; +$primitive_types::var_namet = $primitive_types::def_namet; +$primitive_types::var_parami = $primitive_types::sct_parami; +$primitive_types::var_paramd = $primitive_types::sct_paramd; +$primitive_types::var_paramc = $primitive_types::sct_paramc; + +ok(primitive_types::v_check(), "v_check"); + +#def pyerror(name, val, cte): +# print "bad val/cte", name, val, cte +# raise RuntimeError +# pass + +is($primitive_types::var_bool, $primitive_types::cct_bool, "bool"); +is($primitive_types::var_schar, $primitive_types::cct_schar, "schar"); +is($primitive_types::var_uchar, $primitive_types::cct_uchar, "uchar"); +is($primitive_types::var_int, $primitive_types::cct_int, "int"); +is($primitive_types::var_uint, $primitive_types::cct_uint, "uint"); +is($primitive_types::var_short, $primitive_types::cct_short, "short"); +is($primitive_types::var_ushort, $primitive_types::cct_ushort, "ushort"); +is($primitive_types::var_long, $primitive_types::cct_long, "long"); +is($primitive_types::var_ulong, $primitive_types::cct_ulong, "ulong"); +is($primitive_types::var_llong, $primitive_types::cct_llong, "llong"); +is($primitive_types::var_ullong, $primitive_types::cct_ullong, "ullong"); +is($primitive_types::var_char, $primitive_types::cct_char, "char"); +is($primitive_types::var_pchar, $primitive_types::cct_pchar, "pchar"); +is($primitive_types::var_pcharc, $primitive_types::cct_pcharc, "pchar"); +is($primitive_types::var_pint, $primitive_types::cct_pint, "pint"); +is($primitive_types::var_sizet, $primitive_types::cct_sizet, "sizet"); +is($primitive_types::var_hello, $primitive_types::cct_hello, "hello"); +is($primitive_types::var_myint, $primitive_types::cct_myint, "myint"); +is($primitive_types::var_namet, $primitive_types::def_namet, "name"); + +#class PyTest (TestDirector): +# def __init__(self): +# TestDirector.__init__(self) +# pass +# def ident(self, x): +# return x +# +# def vval_bool(self, x): return self.ident(x) +# def vval_schar(self, x): return self.ident(x) +# def vval_uchar(self, x): return self.ident(x) +# def vval_int(self, x): return self.ident(x) +# def vval_uint(self, x): return self.ident(x) +# def vval_short(self, x): return self.ident(x) +# def vval_ushort(self, x): return self.ident(x) +# def vval_long(self, x): return self.ident(x) +# def vval_ulong(self, x): return self.ident(x) +# def vval_llong(self, x): return self.ident(x) +# def vval_ullong(self, x): return self.ident(x) +# def vval_float(self, x): return self.ident(x) +# def vval_double(self, x): return self.ident(x) +# def vval_char(self, x): return self.ident(x) +# def vval_pchar(self, x): return self.ident(x) +# def vval_pcharc(self, x): return self.ident(x) +# def vval_pint(self, x): return self.ident(x) +# def vval_sizet(self, x): return self.ident(x) +# def vval_hello(self, x): return self.ident(x) +# def vval_myint(self, x): return self.ident(x) +# +# def vref_bool(self, x): return self.ident(x) +# def vref_schar(self, x): return self.ident(x) +# def vref_uchar(self, x): return self.ident(x) +# def vref_int(self, x): return self.ident(x) +# def vref_uint(self, x): return self.ident(x) +# def vref_short(self, x): return self.ident(x) +# def vref_ushort(self, x): return self.ident(x) +# def vref_long(self, x): return self.ident(x) +# def vref_ulong(self, x): return self.ident(x) +# def vref_llong(self, x): return self.ident(x) +# def vref_ullong(self, x): return self.ident(x) +# def vref_float(self, x): return self.ident(x) +# def vref_double(self, x): return self.ident(x) +# def vref_char(self, x): return self.ident(x) +# def vref_pchar(self, x): return self.ident(x) +# def vref_pcharc(self, x): return self.ident(x) +# def vref_pint(self, x): return self.ident(x) +# def vref_sizet(self, x): return self.ident(x) +# def vref_hello(self, x): return self.ident(x) +# def vref_myint(self, x): return self.ident(x) +# +# pass + + +my $t = primitive_types::Test->new(); +#p = PyTest() +# +# +# internal call check +#if t.c_check() != p.c_check(): +# raise RuntimeError, "bad director" +# +#p.var_bool = p.stc_bool +#p.var_schar = p.stc_schar +#p.var_uchar = p.stc_uchar +#p.var_int = p.stc_int +#p.var_uint = p.stc_uint +#p.var_short = p.stc_short +#p.var_ushort = p.stc_ushort +#p.var_long = p.stc_long +#p.var_ulong = p.stc_ulong +#p.var_llong = p.stc_llong +#p.var_ullong = p.stc_ullong +#p.var_char = p.stc_char +#p.var_pchar = sct_pchar +#p.var_pcharc = sct_pcharc +#p.var_pint = sct_pint +#p.var_sizet = sct_sizet +#p.var_hello = sct_hello +#p.var_myint = sct_myint +#p.var_namet = def_namet +#p.var_parami = sct_parami +#p.var_paramd = sct_paramd +#p.var_paramc = sct_paramc +# +#p.v_check() + +$t->{var_bool} = $primitive_types::Test::stc_bool; +$t->{var_schar} = $primitive_types::Test::stc_schar; +$t->{var_uchar} = $primitive_types::Test::stc_uchar; +$t->{var_int} = $primitive_types::Test::stc_int; +$t->{var_uint} = $primitive_types::Test::stc_uint; +$t->{var_short} = $primitive_types::Test::stc_short; +$t->{var_ushort} = $primitive_types::Test::stc_ushort; +$t->{var_long} = $primitive_types::Test::stc_long; +$t->{var_ulong} = $primitive_types::Test::stc_ulong; +$t->{var_llong} = $primitive_types::Test::stc_llong; +$t->{var_ullong} = $primitive_types::Test::stc_ullong; +$t->{var_char} = $primitive_types::Test::stc_char; +$t->{var_pchar} = $primitive_types::sct_pchar; +$t->{var_pcharc} = $primitive_types::sct_pcharc; +$t->{var_pint} = $primitive_types::sct_pint; +$t->{var_sizet} = $primitive_types::sct_sizet; +$t->{var_hello} = $primitive_types::sct_hello; +$t->{var_myint} = $primitive_types::sct_myint; +$t->{var_namet} = $primitive_types::def_namet; +$t->{var_parami} = $primitive_types::sct_parami; +$t->{var_paramd} = $primitive_types::sct_paramd; +$t->{var_paramc} = $primitive_types::sct_paramc; +ok($t->v_check(), 'v_check'); + +is($primitive_types::def_namet, "ho\0la", "namet"); +$t->{var_namet} = $primitive_types::def_namet; +is($t->{var_namet}, $primitive_types::def_namet, "namet"); + +$t->{var_namet} = 'holac'; + +is($t->{var_namet}, 'holac', "namet"); + +$t->{var_namet} = 'hol'; + +is($t->{var_namet}, 'hol', "namet"); + + +is($t->strlen('hile'), 4, "string typemap"); + +is($t->strlen("hil\0"), 4, "string typemap"); + + +$primitive_types::var_char = "\0"; +is($primitive_types::var_char, "\0", "char '0' case"); + +$primitive_types::var_char = 0; +is($primitive_types::var_char, "\0", "char '0' case"); + +$primitive_types::var_namet = "\0"; +is($primitive_types::var_namet, '', "char '\\0' case"); + +$primitive_types::var_namet = ''; +is($primitive_types::var_namet, '', "char empty case"); + +$primitive_types::var_pchar = undef; +is($primitive_types::var_pchar, undef, "undef case"); + +$primitive_types::var_pchar = ''; +is($primitive_types::var_pchar, '', "char empty case"); + +$primitive_types::var_pcharc = undef; +is($primitive_types::var_pcharc, undef, "undef case"); + +$primitive_types::var_pcharc = ''; +is($primitive_types::var_pcharc, '', "char empty case"); + + +# +# creating a raw char* +# +my $pc = primitive_types::new_pchar(5); +primitive_types::pchar_setitem($pc, 0, 'h'); +primitive_types::pchar_setitem($pc, 1, 'o'); +primitive_types::pchar_setitem($pc, 2, 'l'); +primitive_types::pchar_setitem($pc, 3, 'a'); +primitive_types::pchar_setitem($pc, 4, 0); + + +is($t->strlen($pc), 4, "string typemap"); + +$primitive_types::var_pchar = $pc; +is($primitive_types::var_pchar, "hola", "pointer case"); + +$primitive_types::var_namet = $pc; +is($primitive_types::var_namet, "hola", "pointer case"); + +primitive_types::delete_pchar($pc); + +# +# Now when things should fail +# + +{ + my $orig = $t->{var_uchar}; + eval { $t->{var_uchar} = 10000 }; + like($@, qr/\bOverflowError\b/, "uchar typemap"); + is($orig, $t->{var_uchar}, "uchar typemap"); +} +{ + my $orig = $t->{var_char}; + #eval { $t->{var_char} = "23" }; Perl will gladly make a number out of that + eval { $t->{var_char} = "twenty-three" }; + like($@, qr/\bTypeError\b/, "char typemap"); + is($orig, $t->{var_char}, "char typemap"); +} +{ + my $orig = $t->{var_uint}; + eval { $t->{var_uint} = -1 }; + like($@, qr/\bOverflowError\b/, "uint typemap"); + is($orig, $t->{var_uint}, "uint typemap"); +} +{ + my $orig = $t->{var_namet}; + eval { $t->{var_namet} = '123456' }; + like($@, qr/\bTypeError\b/, "namet typemap"); + is($orig, $t->{var_namet}, "namet typemap"); +} +#t2 = p.vtest(t) +#if t.var_namet != t2.var_namet: +# raise RuntimeError, "bad SWIGTYPE* typemap" + +is($primitive_types::fixsize, "ho\0la\0\0\0", "FIXSIZE typemap"); + +$primitive_types::fixsize = 'ho'; +is($primitive_types::fixsize, "ho\0\0\0\0\0\0", "FIXSIZE typemap"); + + +my $f = primitive_types::Foo->new(3); +my $f1 = primitive_types::fptr_val($f); +my $f2 = primitive_types::fptr_ref($f); +is($f1->{_a}, $f2->{_a}, "const ptr& typemap"); + + +is(primitive_types::char_foo(1,3), 3, "int typemap"); + +is(primitive_types::char_foo(1,"hello"), "hello", "char* typemap"); + +is(primitive_types::SetPos(1,3), 4, "int typemap"); diff --git a/Examples/test-suite/perl5/profiletest_runme.pl b/Examples/test-suite/perl5/profiletest_runme.pl new file mode 100644 index 0000000..fcf5c6a --- /dev/null +++ b/Examples/test-suite/perl5/profiletest_runme.pl @@ -0,0 +1,8 @@ +use profiletest; +$a = profiletestc::new_A(); +$b = profiletestc::new_B(); + +for ($i = 0; $i < 100000; $i++) { + $a = profiletestc::B_fn($b, $a); +} + diff --git a/Examples/test-suite/perl5/reference_global_vars_runme.pl b/Examples/test-suite/perl5/reference_global_vars_runme.pl new file mode 100755 index 0000000..dfbcf15 --- /dev/null +++ b/Examples/test-suite/perl5/reference_global_vars_runme.pl @@ -0,0 +1,80 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 19; +BEGIN { use_ok('reference_global_vars') } +require_ok('reference_global_vars'); + +# adapted from ../python/reference_global_vars_runme.py + +my $cvar; +{ + # don't try this at home kids... sneaking an import of all symbols + # from reference_global_vars to main because my fingers are getting + # sore from qualifying all these names. ;) + my $cvar = *reference_global_vars::; + map { ${*::}{$_} = ${$cvar}{$_} } keys %{$cvar}; +} + +is(getconstTC()->{num}, 33); + +# primitive reference variables +$cvar->{var_bool} = createref_bool(0); +is(value_bool($cvar->{var_bool}), ''); + +$cvar->{var_bool} = createref_bool(1); +is(value_bool($cvar->{var_bool}), 1); + +$cvar->{var_char} = createref_char('w'); +is(value_char($cvar->{var_char}), 'w'); + +$cvar->{var_unsigned_char} = createref_unsigned_char(10); +is(value_unsigned_char($cvar->{var_unsigned_char}), 10); + +$cvar->{var_signed_char} = createref_signed_char(10); +is(value_signed_char($cvar->{var_signed_char}), 10); + +$cvar->{var_short} = createref_short(10); +is(value_short($cvar->{var_short}), 10); + +$cvar->{var_unsigned_short} = createref_unsigned_short(10); +is(value_unsigned_short($cvar->{var_unsigned_short}), 10); + +$cvar->{var_int} = createref_int(10); +is(value_int($cvar->{var_int}), 10); + +$cvar->{var_unsigned_int} = createref_unsigned_int(10); +is(value_unsigned_int($cvar->{var_unsigned_int}), 10); + +$cvar->{var_long} = createref_long(10); +is(value_long($cvar->{var_long}), 10); + +$cvar->{var_unsigned_long} = createref_unsigned_long(10); +is(value_unsigned_long($cvar->{var_unsigned_long}), 10); + +SKIP: { + my $a = "6FFFFFFFFFFFFFF8"; + skip "64 bit int support", 1 unless eval { pack 'q', 1 }; + # using hex() here instead of a literal because non 64bit Perls will + # be noisy about big constants. + $cvar->{var_long_long} = createref_long_long(hex $a); + is(value_long_long($cvar->{var_long_long}), hex $a); +} + +#ull = abs(0xFFFFFFF2FFFFFFF0) +my $ull = 55834574864; +$cvar->{var_unsigned_long_long} = createref_unsigned_long_long($ull); +is(value_unsigned_long_long($cvar->{var_unsigned_long_long}), $ull); + +$cvar->{var_float} = createref_float(10.5); +is(value_float($cvar->{var_float}), 10.5); + +$cvar->{var_double} = createref_double(10.5); +is(value_double($cvar->{var_double}), 10.5); + +# class reference variable +$cvar->{var_TestClass} = createref_TestClass( + TestClass->new(20) +); +is(value_TestClass($cvar->{var_TestClass})->{num}, 20); + diff --git a/Examples/test-suite/perl5/rename_scope_runme.pl b/Examples/test-suite/perl5/rename_scope_runme.pl new file mode 100755 index 0000000..71c0cfc --- /dev/null +++ b/Examples/test-suite/perl5/rename_scope_runme.pl @@ -0,0 +1,15 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('rename_scope') } +require_ok('rename_scope'); + +# adapted from ../python/rename_scope_runme.py + +my $a = rename_scope::Natural_UP->new(); +is($a->rtest(), 1); +my $b = rename_scope::Natural_BP->new(); +is($b->rtest(), 1); + +isa_ok(rename_scope->can('equals'), 'CODE'); diff --git a/Examples/test-suite/perl5/ret_by_value_runme.pl b/Examples/test-suite/perl5/ret_by_value_runme.pl new file mode 100644 index 0000000..6126627 --- /dev/null +++ b/Examples/test-suite/perl5/ret_by_value_runme.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('ret_by_value') } +require_ok('ret_by_value'); + +my $tst = ret_by_value::get_test(); +isa_ok($tst, 'ret_by_value::test'); +is($tst->{myInt}, 100); +is($tst->{myShort}, 200); + diff --git a/Examples/test-suite/perl5/return_const_value_runme.pl b/Examples/test-suite/perl5/return_const_value_runme.pl new file mode 100755 index 0000000..4b31c0b --- /dev/null +++ b/Examples/test-suite/perl5/return_const_value_runme.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('return_const_value') } +require_ok('return_const_value'); + +# adapted from ../python/return_const_value_runme.py + +is(return_const_value::Foo_ptr::getPtr()->getVal(), 17); + +is(return_const_value::Foo_ptr::getConstPtr()->getVal(), 17); + diff --git a/Examples/test-suite/perl5/run-perl-test.pl b/Examples/test-suite/perl5/run-perl-test.pl new file mode 100755 index 0000000..106bf00 --- /dev/null +++ b/Examples/test-suite/perl5/run-perl-test.pl @@ -0,0 +1,15 @@ +#!/usr/bin/perl + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; +#!/usr/bin/perl -w + +use strict; + +my $command = shift @ARGV; + +my $output = `$^X $command 2>&1`; + +die "SWIG Perl test failed: \n\n$output\n" + if $?; + +exit(0); diff --git a/Examples/test-suite/perl5/sizet_runme.pl b/Examples/test-suite/perl5/sizet_runme.pl new file mode 100755 index 0000000..5f29773 --- /dev/null +++ b/Examples/test-suite/perl5/sizet_runme.pl @@ -0,0 +1,18 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok('sizet') } +require_ok('sizet'); + +# adapted from ../java/sizet_runme.java + +my $s = 2000; +$s = sizet::test1($s + 1); +is($s, 2001, 'test1'); +$s = sizet::test1($s + 1); +is($s, 2002, 'test2'); +$s = sizet::test1($s + 1); +is($s, 2003, 'test3'); +$s = sizet::test1($s + 1); +is($s, 2004, 'test4'); diff --git a/Examples/test-suite/perl5/sneaky1_runme.pl b/Examples/test-suite/perl5/sneaky1_runme.pl new file mode 100755 index 0000000..097d446 --- /dev/null +++ b/Examples/test-suite/perl5/sneaky1_runme.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More 'no_plan'; +BEGIN { use_ok('sneaky1') } +require_ok('sneaky1'); + +# adapted from ../python/sneaky1_runme.py + +is(sneaky1::add(3,4), 7); +is(sneaky1::subtract(3,4), -1); +is(sneaky1::mul(3,4), 12); +is(sneaky1::divide(3,4), 0); diff --git a/Examples/test-suite/perl5/template_default_arg_runme.pl b/Examples/test-suite/perl5/template_default_arg_runme.pl new file mode 100644 index 0000000..791f508 --- /dev/null +++ b/Examples/test-suite/perl5/template_default_arg_runme.pl @@ -0,0 +1,111 @@ +use strict; +use warnings; +use Test::More tests => 34; +BEGIN { use_ok('template_default_arg') } +require_ok('template_default_arg'); + +{ + my $helloInt = new template_default_arg::Hello_int(); + $helloInt->foo(0); +} +{ + my $x = new template_default_arg::X_int(); + is($x->meth(20.0, 200), 200, "X_int test 1"); + is($x->meth(20), 20, "X_int test 2"); + is($x->meth(), 0, "X_int test 3"); +} + +{ + my $y = new template_default_arg::Y_unsigned(); + is($y->meth(20.0, 200), 200, "Y_unsigned test 1"); + is($y->meth(20), 20, "Y_unsigned test 2"); + is($y->meth(), 0, "Y_unsigned test 3"); +} + +{ + my $x = new template_default_arg::X_longlong(); + $x = new template_default_arg::X_longlong(20.0); + $x = new template_default_arg::X_longlong(20.0, 200); +} +{ + my $x = new template_default_arg::X_int(); + $x = new template_default_arg::X_int(20.0); + $x = new template_default_arg::X_int(20.0, 200); +} +{ + my $x = new template_default_arg::X_hello_unsigned(); + $x = new template_default_arg::X_hello_unsigned(20.0); + $x = new template_default_arg::X_hello_unsigned(20.0, new template_default_arg::Hello_int()); +} +{ + my $y = new template_default_arg::Y_hello_unsigned(); + $y->meth(20.0, new template_default_arg::Hello_int()); + $y->meth(new template_default_arg::Hello_int()); + $y->meth(); +} + +{ + my $fz = new template_default_arg::Foo_Z_8(); + my $x = new template_default_arg::X_Foo_Z_8(); + my $fzc = $x->meth($fz); +} + +# Templated functions +{ + # plain function: int ott(Foo<int>) + is(template_default_arg::ott(new template_default_arg::Foo_int()), 30, "ott test 1"); + + # %template(ott) ott<int, int>; + is(template_default_arg::ott(), 10, "ott test 2"); + is(template_default_arg::ott(1), 10, "ott test 3"); + is(template_default_arg::ott(1, 1), 10, "ott test 4"); + + is(template_default_arg::ott("hi"), 20, "ott test 5"); + is(template_default_arg::ott("hi", 1), 20, "ott test 6"); + is(template_default_arg::ott("hi", 1, 1), 20,"ott test 7"); + + # %template(ott) ott<const char *>; + is(template_default_arg::ottstring(new template_default_arg::Hello_int(), "hi"), 40, "ott test 8"); + + is(template_default_arg::ottstring(new template_default_arg::Hello_int()), 40, "ott test 9"); + + # %template(ott) ott<int>; + is(template_default_arg::ottint(new template_default_arg::Hello_int(), 1), 50, "ott test 10"); + + is(template_default_arg::ottint(new template_default_arg::Hello_int()), 50, "ott test 11"); + + # %template(ott) ott<double>; + is(template_default_arg::ott(new template_default_arg::Hello_int(), 1.0), 60, "ott test 12"); + + is(template_default_arg::ott(new template_default_arg::Hello_int()), 60, "ott test 13"); +} + +# Above test in namespaces +{ + # plain function: int nsott(Foo<int>) + is(template_default_arg::nsott(new template_default_arg::Foo_int()), 130, "nsott test 1"); + + # %template(nsott) nsott<int, int>; + is(template_default_arg::nsott(), 110, "nsott test 2"); + is(template_default_arg::nsott(1), 110, "nsott test 3"); + is(template_default_arg::nsott(1, 1), 110, "nsott test 4"); + + is(template_default_arg::nsott("hi"), 120, "nsott test 5"); + is(template_default_arg::nsott("hi", 1), 120, "nsott test 6"); + is(template_default_arg::nsott("hi", 1, 1), 120, "nsott test 7"); + + # %template(nsott) nsott<const char *>; + is(template_default_arg::nsottstring(new template_default_arg::Hello_int(), "hi"), 140, "nsott test 8"); + + is(template_default_arg::nsottstring(new template_default_arg::Hello_int()), 140, "nsott test 9"); + + # %template(nsott) nsott<int>; + is(template_default_arg::nsottint(new template_default_arg::Hello_int(), 1), 150, "nsott test 10"); + + is(template_default_arg::nsottint(new template_default_arg::Hello_int()), 150, "nsott test 11"); + + # %template(nsott) nsott<double>; + is(template_default_arg::nsott(new template_default_arg::Hello_int(), 1.0), 160, "nsott test 12"); + + is(template_default_arg::nsott(new template_default_arg::Hello_int()), 160, "nsott test 13"); +} diff --git a/Examples/test-suite/perl5/template_ref_type_runme.pl b/Examples/test-suite/perl5/template_ref_type_runme.pl new file mode 100644 index 0000000..ba6e2b9 --- /dev/null +++ b/Examples/test-suite/perl5/template_ref_type_runme.pl @@ -0,0 +1,6 @@ +use template_ref_type; + +my $xr = template_ref_type::XC->new(); +my $y = template_ref_type::Y->new(); + +$y->find($xr); diff --git a/Examples/test-suite/perl5/template_typedef_cplx2_runme.pl b/Examples/test-suite/perl5/template_typedef_cplx2_runme.pl new file mode 100755 index 0000000..e0a3003 --- /dev/null +++ b/Examples/test-suite/perl5/template_typedef_cplx2_runme.pl @@ -0,0 +1,53 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 16; +BEGIN { use_ok('template_typedef_cplx2') } +require_ok('template_typedef_cplx2'); + +# adapted from ../python/template_typedef_cplx2_runme.py + +{ # kids, don't try this at home (glob hijinks) + my $cvar = *template_typedef_cplx2::; + map { ${*::}{$_} = ${$cvar}{$_} } keys %{$cvar}; +} + +# +# double case +# + +my $d = eval { make_Identity_double() }; +ok(ref($d), 'is an object'); +like(ref($d), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $e = eval { make_Multiplies_double_double_double_double($d, $d) }; +ok(ref($e), 'is an object'); +like(ref($e), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +# +# complex case +# + +my $c = eval { make_Identity_complex() }; +ok(ref($c), 'is an object'); +like(ref($c), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $f = eval { make_Multiplies_complex_complex_complex_complex($c, $c) }; +ok(ref($f), 'is an object'); +like(ref($f), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +# +# Mix case +# + +my $g = eval { make_Multiplies_double_double_complex_complex($d, $c) }; +ok(ref($g), 'is an object'); +like(ref($g), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $h = eval { make_Multiplies_complex_complex_double_double($c, $d) }; +ok(ref($h), 'is an object'); +like(ref($h), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +can_ok($g, 'get_value'); +ok(eval { $g->get_value() }, 'get_value'); + diff --git a/Examples/test-suite/perl5/template_typedef_cplx3_runme.pl b/Examples/test-suite/perl5/template_typedef_cplx3_runme.pl new file mode 100644 index 0000000..fe411f6 --- /dev/null +++ b/Examples/test-suite/perl5/template_typedef_cplx3_runme.pl @@ -0,0 +1,41 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 16; +BEGIN { use_ok('template_typedef_cplx3') } +require_ok('template_typedef_cplx3'); + +# adapted from ../python/template_typedef_cplx3_runme.py + +{ # kids, don't try this at home (glob hijinks) + my $cvar = *template_typedef_cplx3::; + map { ${*::}{$_} = ${$cvar}{$_} } keys %{$cvar}; +} + +my $s = Sin->new(); +is($s->get_base_value(), 0); +is($s->get_value(), 1); +is($s->get_arith_value(), 2); +is(my_func_r($s), 0); +isa_ok(make_Multiplies_double_double_double_double($s,$s), + "template_typedef_cplx3::ArithUnaryFunction_double_double"); + +my $z = CSin->new(); +is($z->get_base_value(), 0); +is($z->get_value(), 1); +is($z->get_arith_value(), 2); +is(my_func_c($z), 1); +isa_ok(make_Multiplies_complex_complex_complex_complex($z,$z), + "template_typedef_cplx3::ArithUnaryFunction_complex_complex"); + +my $d = eval { make_Identity_double() }; +isa_ok($d, "template_typedef_cplx3::ArithUnaryFunction_double_double"); +is(my_func_r($d), 0); + +my $c = eval { make_Identity_complex() }; +isa_ok($d, "template_typedef_cplx3::ArithUnaryFunction_double_double"); +is(my_func_c($c), 1); + + + + diff --git a/Examples/test-suite/perl5/template_typedef_cplx_runme.pl b/Examples/test-suite/perl5/template_typedef_cplx_runme.pl new file mode 100644 index 0000000..47cc672 --- /dev/null +++ b/Examples/test-suite/perl5/template_typedef_cplx_runme.pl @@ -0,0 +1,49 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 14; +BEGIN { use_ok('template_typedef_cplx') } +require_ok('template_typedef_cplx'); + +# adapted from ../python/template_typedef_cplx_runme.py + +{ # kids, don't try this at home (glob hijinks) + my $cvar = *template_typedef_cplx::; + map { ${*::}{$_} = ${$cvar}{$_} } keys %{$cvar}; +} + +# +# double case +# + +my $d = eval { make_Identity_double() }; +ok(ref($d), 'is an object'); +like(ref($d), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $e = eval { make_Multiplies_double_double_double_double($d, $d) }; +ok(ref($e), 'is an object'); +like(ref($e), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +# +# complex case +# + +my $c = eval { make_Identity_complex() }; +ok(ref($c), 'is an object'); +like(ref($c), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $f = eval { make_Multiplies_complex_complex_complex_complex($c, $c) }; +ok(ref($f), 'is an object'); +like(ref($f), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +# +# Mix case +# + +my $g = eval { make_Multiplies_double_double_complex_complex($d, $c) }; +ok(ref($f), 'is an object'); +like(ref($f), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); + +my $h = eval { make_Multiplies_complex_complex_double_double($c, $d) }; +ok(ref($h), 'is an object'); +like(ref($h), qr/ArithUnaryFunction/, "is an ArithUnaryFunction"); diff --git a/Examples/test-suite/perl5/typedef_class_runme.pl b/Examples/test-suite/perl5/typedef_class_runme.pl new file mode 100755 index 0000000..a7b88a7 --- /dev/null +++ b/Examples/test-suite/perl5/typedef_class_runme.pl @@ -0,0 +1,16 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok('typedef_class') } +require_ok('typedef_class'); + +# adapted from ../python/typedef_class_runme.py + +my $a = typedef_class::RealA->new(); +isa_ok($a, 'typedef_class::RealA'); +$a->{a} = 3; +is($a->{a}, 3); +my $b = typedef_class::B->new(); +isa_ok($b, 'typedef_class::B'); +is($b->testA($a), 3); diff --git a/Examples/test-suite/perl5/typemap_namespace_runme.pl b/Examples/test-suite/perl5/typemap_namespace_runme.pl new file mode 100644 index 0000000..f2fdd6f --- /dev/null +++ b/Examples/test-suite/perl5/typemap_namespace_runme.pl @@ -0,0 +1,9 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('typemap_namespace') } +require_ok('typemap_namespace'); + +is(typemap_namespace::test1("hello"), "hello", "test 1"); +is(typemap_namespace::test2("hello"), "hello", "test 1"); diff --git a/Examples/test-suite/perl5/typename_runme.pl b/Examples/test-suite/perl5/typename_runme.pl new file mode 100755 index 0000000..543080d --- /dev/null +++ b/Examples/test-suite/perl5/typename_runme.pl @@ -0,0 +1,17 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok('typename') } +require_ok('typename'); + +# adapted from ../python/typename_runme.py + +my $f = typename::Foo->new(); +my $b = typename::Bar->new(); +my $x = typename::twoFoo($f); +is($x, 4.3656); +my $y = typename::twoBar($b); +is($y, 84); +# I would like this test better if I could pass in a float to the +# integer test and see it lose precision. diff --git a/Examples/test-suite/perl5/unions_runme.pl b/Examples/test-suite/perl5/unions_runme.pl new file mode 100644 index 0000000..7a62295 --- /dev/null +++ b/Examples/test-suite/perl5/unions_runme.pl @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More tests => 7; +# This is the union runtime testcase. It ensures that values within a +# union embedded within a struct can be set and read correctly. + +BEGIN { use_ok('unions') } +require_ok('unions'); + +# Create new instances of SmallStruct and BigStruct for later use +my $small = new unions::SmallStruct(); +$small->{jill} = 200; + +my $big = new unions::BigStruct(); +$big->{smallstruct} = $small; +$big->{jack} = 300; + +# Use SmallStruct then BigStruct to setup EmbeddedUnionTest. +# Ensure values in EmbeddedUnionTest are set correctly for each. +my $eut = new unions::EmbeddedUnionTest(); + +# First check the SmallStruct in EmbeddedUnionTest +$eut->{number} = 1; +$eut->{uni}->{small} = $small; +my $Jill1 = $eut->{uni}->{small}->{jill}; +is($Jill1, 200, "eut.uni.small.jill"); + +my $Num1 = $eut->{number}; +is($Num1, 1, "test2 eut.number"); + +# Secondly check the BigStruct in EmbeddedUnionTest +$eut->{number} = 2; +$eut->{uni}->{big} = $big; +my $Jack1 = $eut->{uni}->{big}->{jack}; +is($Jack1, 300, "test3 eut.uni.big.jack"); + +my $Jill2 = $eut->{uni}->{big}->{smallstruct}->{jill}; +is($Jill2, 200, "test4 eut.uni.big.smallstruct.jill"); + +my $Num2 = $eut->{number}; +is($Num2, 2, "test5 eut.number"); + diff --git a/Examples/test-suite/perl5/using1_runme.pl b/Examples/test-suite/perl5/using1_runme.pl new file mode 100755 index 0000000..8551b6f --- /dev/null +++ b/Examples/test-suite/perl5/using1_runme.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('using1') } +require_ok('using1'); + +# adapted from ../python/using1_runme.py + +is(using1::spam(37), 37); diff --git a/Examples/test-suite/perl5/using2_runme.pl b/Examples/test-suite/perl5/using2_runme.pl new file mode 100755 index 0000000..3a31bb3 --- /dev/null +++ b/Examples/test-suite/perl5/using2_runme.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('using2') } +require_ok('using2'); + +# adapted from ../python/using2_runme.py + +is(using2::spam(37), 37); diff --git a/Examples/test-suite/perl5/varargs_runme.pl b/Examples/test-suite/perl5/varargs_runme.pl new file mode 100644 index 0000000..4d8a831 --- /dev/null +++ b/Examples/test-suite/perl5/varargs_runme.pl @@ -0,0 +1,18 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 7; +BEGIN { use_ok('varargs') } +require_ok('varargs'); + +is(varargs::test("Hello"), "Hello"); + +my $f = new varargs::Foo("BuonGiorno", 1); +is($f->{str}, "BuonGiorno"); + +$f = new varargs::Foo("Greetings"); +is($f->{str}, "Greetings"); + +is($f->test("Hello"), "Hello"); + +is(varargs::Foo::statictest("Grussen", 1), "Grussen"); diff --git a/Examples/test-suite/perl5/virtual_poly_runme.pl b/Examples/test-suite/perl5/virtual_poly_runme.pl new file mode 100644 index 0000000..a56a64e --- /dev/null +++ b/Examples/test-suite/perl5/virtual_poly_runme.pl @@ -0,0 +1,36 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 8; +BEGIN { use_ok('virtual_poly') } +require_ok('virtual_poly'); + +my $d = virtual_poly::NDouble->new(3.5); +my $i = virtual_poly::NInt->new(2); + +# +# the copy methods return the right polymorphic types +# +my $dc = $d->copy(); +my $ic = $i->copy(); + +is($d->get(), $dc->get()); + +is($i->get(), $ic->get()); + +virtual_poly::incr($ic); + +is($i->get() + 1, $ic->get()); + +my $dr = $d->ref_this(); +is($d->get(), $dr->get()); + + +# +# 'narrowing' also works +# +my $ddc = virtual_poly::NDouble::narrow($d->nnumber()); +is($d->get, $ddc->get()); + +my $dic = virtual_poly::NInt::narrow($i->nnumber()); +is($i->get(), $dic->get()); diff --git a/Examples/test-suite/perl5/voidtest_runme.pl b/Examples/test-suite/perl5/voidtest_runme.pl new file mode 100644 index 0000000..405f8fd --- /dev/null +++ b/Examples/test-suite/perl5/voidtest_runme.pl @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More tests => 7; +BEGIN { use_ok('voidtest') } +require_ok('voidtest'); + +# adapted from ../python/voidtest_runme.py +voidtest::globalfunc(); +my $f = voidtest::Foo->new(); +is($f->memberfunc(), undef); +{ local $TODO = "opaque pointers hidden behind layer of indirection"; +my $v1 = voidtest::vfunc1($f); +my $v2 = voidtest::vfunc2($f); +is($v1, $v2); +my $v3 = voidtest::vfunc3($v1); +is($v3->this, $f->this); +my $v4 = voidtest::vfunc4($f); +is($v1, $v4); +} +ok(1, "done"); diff --git a/Examples/test-suite/perl5/wrapmacro_runme.pl b/Examples/test-suite/perl5/wrapmacro_runme.pl new file mode 100755 index 0000000..8e01540 --- /dev/null +++ b/Examples/test-suite/perl5/wrapmacro_runme.pl @@ -0,0 +1,14 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok('wrapmacro') } +require_ok('wrapmacro'); + +# adapted from ../python/wrapmacro_runme.py + +my $a = 2; +my $b = -1; +is(wrapmacro::maximum($a,$b), 2); +is(wrapmacro::maximum($a/7.0, -$b*256), 256); +is(wrapmacro::GUINT16_SWAP_LE_BE_CONSTANT(1), 256); |