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
use Scalar::Util qw(reftype refaddr blessed);
-our $VERSION = '1.23';
+our $VERSION = '1.24';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads::shared version 1.23
+This document describes threads::shared version 1.24
=head1 SYNOPSIS
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.23/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.24/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
# define NEED_sv_2pv_flags
# define NEED_vnewSVpvf
# define NEED_warner
+# define NEED_newSVpvn_flags
# include "ppport.h"
# include "shared.h"
#endif
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);
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);
}
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);
}
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);
}
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;
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;
--- /dev/null
+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
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) = @_;
my $TEST = 1;
ok($TEST++, 1, 'Loaded');
+Test::watchdog(600); # In case we get stuck
### Start of Testing ###
} # -- SYNCH_REFS block
-# Kill timer process
-if ($timer_pid && kill(0, $timer_pid)) {
- kill('KILL', $timer_pid);
-}
-
# Done
exit(0);
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) = @_;
my $TEST = 1;
ok($TEST++, 1, 'Loaded');
+Test::watchdog(60); # In case we get stuck
### Start of Testing ###
} # -- SYNCH_REFS block
-# Kill timer process
-if ($timer_pid && kill(0, $timer_pid)) {
- kill('KILL', $timer_pid);
-}
-
# Done
exit(0);
projects / platform / upstream / perl.git / commitdiff