From: Jerry D. Hedden Date: Wed, 2 Jul 2008 10:01:59 +0000 (-0400) Subject: threads::shared 1.24 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c4393b60d8ec72e4e014027bff4b708963d68d04;p=p5sagit%2Fp5-mst-13.2.git threads::shared 1.24 From: "Jerry D. Hedden" Message-ID: <1ff86f510807020701v78a14d06g1e0e5f098c6131ed@mail.gmail.com> ...plus some adjustments to the test headers to prevent failures in the Perl core. p4raw-id: //depot/perl@34098 --- diff --git a/MANIFEST b/MANIFEST index dd8bd12..8a76fba 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1150,6 +1150,7 @@ ext/threads/shared/t/shared_attr.t Test :shared attribute ext/threads/shared/t/stress.t Stress test ext/threads/shared/t/sv_refs.t thread shared variables ext/threads/shared/t/sv_simple.t thread shared variables +ext/threads/shared/t/utf8.t Test UTF-8 keys in shared hashes ext/threads/shared/t/waithires.t Test sub-second cond_timedwait ext/threads/shared/t/wait.t Test cond_wait and cond_timedwait ext/threads/t/basic.t ithreads diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index c73303b..f25f166 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.23'; +our $VERSION = '1.24'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -186,7 +186,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.23 +This document describes threads::shared version 1.24 =head1 SYNOPSIS @@ -540,7 +540,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L Source repository: L diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index cdea8c9..b744796 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -123,6 +123,7 @@ # define NEED_sv_2pv_flags # define NEED_vnewSVpvf # define NEED_warner +# define NEED_newSVpvn_flags # include "ppport.h" # include "shared.h" #endif @@ -875,7 +876,7 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) STRLEN len = mg->mg_len; assert ( mg->mg_ptr != 0 ); if (mg->mg_len == HEf_SVKEY) { - key = SvPV((SV *) mg->mg_ptr, len); + key = SvPVutf8((SV *)mg->mg_ptr, len); } SHARED_CONTEXT; svp = hv_fetch((HV*) saggregate, key, len, 0); @@ -926,7 +927,7 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) STRLEN len = mg->mg_len; assert ( mg->mg_ptr != 0 ); if (mg->mg_len == HEf_SVKEY) - key = SvPV((SV *) mg->mg_ptr, len); + key = SvPVutf8((SV *)mg->mg_ptr, len); SHARED_CONTEXT; svp = hv_fetch((HV*) saggregate, key, len, 1); } @@ -957,7 +958,7 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) STRLEN len = mg->mg_len; assert ( mg->mg_ptr != 0 ); if (mg->mg_len == HEf_SVKEY) - key = SvPV((SV *) mg->mg_ptr, len); + key = SvPVutf8((SV *)mg->mg_ptr, len); SHARED_CONTEXT; hv_delete((HV*) saggregate, key, len, G_DISCARD); } @@ -1275,7 +1276,7 @@ EXISTS(SV *obj, SV *index) exists = av_exists((AV*) sobj, SvIV(index)); } else { STRLEN len; - char *key = SvPV(index,len); + char *key = SvPVutf8(index, len); SHARED_EDIT; exists = hv_exists((HV*) sobj, key, len); } @@ -1299,7 +1300,7 @@ FIRSTKEY(SV *obj) if (entry) { key = hv_iterkey(entry,&len); CALLER_CONTEXT; - ST(0) = sv_2mortal(newSVpv(key, len)); + ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1)); } else { CALLER_CONTEXT; ST(0) = &PL_sv_undef; @@ -1325,7 +1326,7 @@ NEXTKEY(SV *obj, SV *oldkey) if (entry) { key = hv_iterkey(entry,&len); CALLER_CONTEXT; - ST(0) = sv_2mortal(newSVpv(key, len)); + ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1)); } else { CALLER_CONTEXT; ST(0) = &PL_sv_undef; diff --git a/ext/threads/shared/t/utf8.t b/ext/threads/shared/t/utf8.t new file mode 100644 index 0000000..f2e0ac3 --- /dev/null +++ b/ext/threads/shared/t/utf8.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +my $TEST = 1; + +sub is { + my ($got, $exp, $name) = @_; + + my $ok = ($got eq $exp); + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $TEST - $name\n"); + } else { + print("not ok $TEST - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + print("# Got: $got\n"); + print("# Expected: $exp\n"); + } + + $TEST++; + + return ($ok); +} + +BEGIN { + $| = 1; + print("1..12\n"); ### Number of tests that will be run ### +}; + +use threads; +use threads::shared; + +### Start of Testing ### + +binmode STDOUT, ":utf8"; + +my $plain = 'foo'; +my $utf8 = "\x{123}\x{84}\x{20F}\x{2C1}"; + +my %a :shared; +$a{$plain} = $plain; +$a{$utf8} = $utf8; +$a{\&is} = 'code'; + +is(exists($a{$plain}), 1, 'Found plain key in shared hash'); +is(exists($a{$utf8}), 1, 'Found UTF-8 key in shared hash'); +is(exists($a{\&is}), 1, 'Found code ref key in shared hash'); + +while (my ($key, $value) = each (%a)) { + if ($key eq $plain) { + is($key, $plain, 'Plain key in shared hash'); + } elsif ($key eq $utf8) { + is($key, $utf8, 'UTF-8 key in shared hash'); + } else { + is($key, \&is, 'Code ref key in shared hash'); + } +} + +my $a = &share({}); +$$a{$plain} = $plain; +$$a{$utf8} = $utf8; +$$a{\&is} = 'code'; + +is(exists($$a{$plain}), 1, 'Found plain key in shared hash ref'); +is(exists($$a{$utf8}), 1, 'Found UTF-8 key in shared hash ref'); +is(exists($$a{\&is}), 1, 'Found code ref key in shared hash ref'); + +while (my ($key, $value) = each (%$a)) { + if ($key eq $plain) { + is($key, $plain, 'Plain key in shared hash ref'); + } elsif ($key eq $utf8) { + is($key, $utf8, 'UTF-8 key in shared hash ref'); + } else { + is($key, \&is, 'Code ref key in shared hash ref'); + } +} + +exit(0); + +# EOF diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t index c08e2ed..de8d9f1 100644 --- a/ext/threads/shared/t/wait.t +++ b/ext/threads/shared/t/wait.t @@ -1,42 +1,31 @@ use strict; use warnings; -use Config; BEGIN { + # Import test.pl into its own package + if ($ENV{'PERL_CORE'}){ chdir 't'; unshift @INC, '../lib'; + { + package Test; + require 'test.pl'; + } + } else { + { + package Test; + require 't/test.pl'; + } } + + use Config; if (! $Config{'useithreads'}) { - print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); - exit(0); + Test::skip_all(q/Perl not compiled with 'useithreads'/); } } use ExtUtils::testlib; -### Self-destruct timer child process -my $TIMEOUT = 600; -my $timer_pid; - -if ($Config{'d_fork'}) { - $timer_pid = fork(); - if (defined($timer_pid) && ($timer_pid == 0)) { - # Child process - my $ppid = getppid(); - - # Sleep for timeout period - sleep($TIMEOUT - 2); # Workaround for perlbug #49073 - sleep(2); # Wait for parent to exit - - # Kill parent if it still exists - kill('KILL', $ppid) if (kill(0, $ppid)); - exit(0); - } - # Parent will kill this process if tests finish on time -} - - sub ok { my ($id, $ok, $name) = @_; @@ -62,6 +51,7 @@ use threads::shared; my $TEST = 1; ok($TEST++, 1, 'Loaded'); +Test::watchdog(600); # In case we get stuck ### Start of Testing ### @@ -355,11 +345,6 @@ SYNCH_REFS: { } # -- SYNCH_REFS block -# Kill timer process -if ($timer_pid && kill(0, $timer_pid)) { - kill('KILL', $timer_pid); -} - # Done exit(0); diff --git a/ext/threads/shared/t/waithires.t b/ext/threads/shared/t/waithires.t index 2817334..82913ca 100644 --- a/ext/threads/shared/t/waithires.t +++ b/ext/threads/shared/t/waithires.t @@ -1,50 +1,37 @@ use strict; use warnings; -use Config; BEGIN { + # Import test.pl into its own package + if ($ENV{'PERL_CORE'}){ chdir 't'; unshift @INC, '../lib'; + { + package Test; + require 'test.pl'; + } + } else { + { + package Test; + require 't/test.pl'; + } } + + use Config; if (! $Config{'useithreads'}) { - print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); - exit(0); + Test::skip_all(q/Perl not compiled with 'useithreads'/); } + eval { require Time::HiRes; Time::HiRes->import('time'); }; - if ($@) { - print("1..0 # SKIP Time::HiRes not available.\n"); - exit(0); - } + Test::skip_all('Time::HiRes not available') if ($@); } use ExtUtils::testlib; -### Self-destruct timer child process -my $TIMEOUT = 60; -my $timer_pid; - -if ($Config{'d_fork'}) { - $timer_pid = fork(); - if (defined($timer_pid) && ($timer_pid == 0)) { - # Child process - my $ppid = getppid(); - - # Sleep for timeout period - sleep($TIMEOUT - 2); # Workaround for perlbug #49073 - sleep(2); # Wait for parent to exit - - # Kill parent if it still exists - kill('KILL', $ppid) if (kill(0, $ppid)); - exit(0); - } - # Parent will kill this process if tests finish on time -} - - sub ok { my ($id, $ok, $name) = @_; @@ -70,6 +57,7 @@ use threads::shared; my $TEST = 1; ok($TEST++, 1, 'Loaded'); +Test::watchdog(60); # In case we get stuck ### Start of Testing ### @@ -297,11 +285,6 @@ SYNCH_REFS: { } # -- SYNCH_REFS block -# Kill timer process -if ($timer_pid && kill(0, $timer_pid)) { - kill('KILL', $timer_pid); -} - # Done exit(0);