From: Nick Ing-Simmons Date: Mon, 5 Mar 2001 18:12:41 +0000 (+0000) Subject: Some tests for Camel 3rd edition features. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=595ae48196d4b0901d4a1aee37333fa960a6031f;p=p5sagit%2Fp5-mst-13.2.git Some tests for Camel 3rd edition features. Make gethostbyaddr() test in above work. p4raw-id: //depot/perlio@9042 --- diff --git a/pp.h b/pp.h index 5dbc09c..61fadc3 100644 --- a/pp.h +++ b/pp.h @@ -100,7 +100,16 @@ See C and L for other uses. Pops an SV off the stack. =for apidoc Amn|char*|POPp +Pops a string off the stack. Deprecated. New code should provide +a STRLEN n_a and use POPpx. + +=for apidoc Amn|char*|POPpx Pops a string off the stack. +Requires a variable STRLEN n_a in scope. + +=for apidoc Amn|char*|POPpbytex +Pops a string off the stack which must consist of bytes i.e. characters < 256. +Requires a variable STRLEN n_a in scope. =for apidoc Amn|NV|POPn Pops a double off the stack. @@ -122,6 +131,7 @@ Pops a long off the stack. #define POPs (*sp--) #define POPp (SvPVx(POPs, PL_na)) /* deprecated */ #define POPpx (SvPVx(POPs, n_a)) +#define POPpbytex (SvPVbytex(POPs, n_a)) #define POPn (SvNVx(POPs)) #define POPi ((IV)SvIVx(POPs)) #define POPu ((UV)SvUVx(POPs)) diff --git a/pp_sys.c b/pp_sys.c index 5179e0b..c6e407b 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -4515,7 +4515,7 @@ PP(pp_ghostent) EXTEND(SP, 10); if (which == OP_GHBYNAME) #ifdef HAS_GETHOSTBYNAME - hent = PerlSock_gethostbyname(POPpx); + hent = PerlSock_gethostbyname(POPpbytex); #else DIE(aTHX_ PL_no_sock_func, "gethostbyname"); #endif @@ -4524,7 +4524,7 @@ PP(pp_ghostent) int addrtype = POPi; SV *addrsv = POPs; STRLEN addrlen; - Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen); + Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen); hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); #else diff --git a/t/TEST b/t/TEST index c2bfb9f..a2c8899 100755 --- a/t/TEST +++ b/t/TEST @@ -27,13 +27,13 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($#ARGV == -1) { @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t pod/*.t`); + `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t pod/*.t camel-III/*.t`); } -# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); _testprogs('perl', @ARGV); -_testprogs('compile', @ARGV) if (-e "../testcompile"); +_testprogs('compile', @ARGV) if (-e "../testcompile"); sub _testprogs { $type = shift @_; @@ -46,7 +46,7 @@ TESTING COMPILER -------------------------------------------------------------------------------- EOT - $ENV{PERLCC_TIMEOUT} = 120 + $ENV{PERLCC_TIMEOUT} = 120 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); $bad = 0; @@ -65,7 +65,7 @@ EOT while ($test = shift @tests) { if ( $infinite{$test} && $type eq 'compile' ) { - print STDERR "$test creates infinite loop! Skipping.\n"; + print STDERR "$test creates infinite loop! Skipping.\n"; next; } if ($test =~ /^$/) { @@ -93,7 +93,7 @@ EOT : ''; my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC if ($type eq 'perl') { - my $run = "./perl $testswitch $switch $utf $test |"; + my $run = "./perl $testswitch $switch $utf $test |"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } else { @@ -122,7 +122,7 @@ EOT } else { if (/^(not )?ok (\d+)(\s*#.*)?/ && - $2 == $next) + $2 == $next) { my($not, $num, $extra) = ($1, $2, $3); my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra; @@ -189,8 +189,8 @@ EOT ### Since not all tests were successful, you may want to run some ### of them individually and examine any diagnostic messages they ### produce. See the INSTALL document's section on "make test". - ### If you are testing the compiler, then ignore this message - ### and run + ### If you are testing the compiler, then ignore this message + ### and run ### ./perl harness ### in the directory ./t. SHRDLU @@ -198,7 +198,7 @@ SHRDLU ### ### Since most tests were successful, you have a good chance to ### get information with better granularity by running - ### ./perl harness + ### ./perl harness ### in directory ./t. SHRDLU } diff --git a/t/camel-III/vstring.t b/t/camel-III/vstring.t new file mode 100644 index 0000000..7d05790 --- /dev/null +++ b/t/camel-III/vstring.t @@ -0,0 +1,38 @@ +# See if the things Camel-III says are true. +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} +use Test; +plan test => 6; +# Error messages may have wide chars, say that is okay - if we can. +eval { binmode STDOUT,":utf8" }; + +# Chapter 2 pp67/68 +my $vs = v1.20.300.4000; +ok($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}"); +ok($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()"); +ok('foo',v102.111.111,"v-string ne ''"); + +# Chapter 15, pp403 + +# See if sane addr and gethostbyaddr() work +eval { require Socket; gethostbyaddr(v127.0.0.1,Socket::AF_INET()) }; +if ($@) + { + # No - so don't test insane fails. + skip("No Socket",''); + } +else + { + my $ip = v2004.148.0.1; + my $host; + eval { $host = gethostbyaddr($ip,Socket::AF_INET()) }; + ok($@ =~ /Wide character/,1,"Non-bytes leak to gethostbyaddr"); + } + +# Chapter 28, pp671 +ok(v5.6.0 lt v5.7.0,1,"v5.6.0 lt v5.7.0 fails"); +# Some floating-point risk here ... +my $v = ord($^V)+ord(substr($^V,1,1))/1000+ord(substr($^V,2,1))/1000000; +ok($v,$],"\$^V and \$] do not match"); diff --git a/t/harness b/t/harness index c24d46f..ca8a676 100644 --- a/t/harness +++ b/t/harness @@ -37,7 +37,7 @@ foreach (keys %datahandle) { } @tests = @ARGV; -@tests = unless @tests; +@tests = unless @tests; Test::Harness::runtests @tests; exit(0) unless -e "../testcompile"; @@ -46,7 +46,7 @@ exit(0) unless -e "../testcompile"; # op/bop.t 1 # lib/hostname.t 1 # op/lex_assign.t 1 -# lib/ph.t 1 +# lib/ph.t 1 # ); my $dhwrapper = <<'EOT'; @@ -72,10 +72,10 @@ EOT print "The tests ", join(' ', keys(%infinite)), " generate infinite loops! Skipping!\n"; -$ENV{'HARNESS_COMPILE_TEST'} = 1; +$ENV{'HARNESS_COMPILE_TEST'} = 1; $ENV{'PERLCC_TIMEOUT'} = 120 unless $ENV{'PERLCC_TIMEOUT'}; -Test::Harness::runtests @tests; +Test::Harness::runtests @tests; foreach (keys %datahandle) { unlink "$_.t"; }