Change 33172 by [EMAIL PROTECTED] on 2008/02/01 19:03:16
Integrate:
[ 31610]
Use new style L<> links in POD
[ 32102]
Share the internal XS functions defined in universal.c
to Safe compartments
[ 32103]
Funny symbol table names can be shared, too
[ 32104]
New test for Safe
[ 32117]
More tests for Safe
[ 32597]
Change maintainer address for Safe.
[ 33111]
Integrate:
[ 32651]
Upgrade to B-Lint-1.11
[ 32654]
Upgrade to Sys-Syslog-0.23
[ 32656]
Add new Sys::Syslog file to MANIFEST
[ 32658]
Subject: [PATCH] threads::shared 1.15
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Wed, 19 Dec 2007 10:17:46 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 32799]
Upgrade to Sys-Syslog-0.24
[ 33093]
In Safe, load Carp::Heavy only if it exists (to remain
compatible with older perls)
[ 33096]
Bump the version of Safe
[ 33102]
Make this test pass with the Test::More that comes with perl 5.6.2
[ 33105]
Document why ok() is being used instead of like(), to stop someone
undoing it.
[ 33112]
Integrate:
[ 33093]
In Safe, load Carp::Heavy only if it exists (to remain
compatible with older perls)
[ 33096]
Bump the version of Safe
[ 33102]
Make this test pass with the Test::More that comes with perl 5.6.2
[ 33105]
Document why ok() is being used instead of like(), to stop someone
undoing it.
[in the correct branch. Whoops!]
[ 33164]
Integrate:
[ 33124]
Bump Safe's version
[ 33171]
Integrate:
[ 33170]
Break apart the list of functions defined in universal.c by perl
version (from 5.8.8 upwards)
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#415 integrate
... //depot/maint-5.8/perl/ext/B/B/Lint.pm#9 integrate
... //depot/maint-5.8/perl/ext/B/B/Lint/Debug.pm#1 branch
... //depot/maint-5.8/perl/ext/Opcode/Opcode.pm#4 integrate
... //depot/maint-5.8/perl/ext/Opcode/Safe.pm#9 integrate
... //depot/maint-5.8/perl/ext/Opcode/ops.pm#4 integrate
... //depot/maint-5.8/perl/ext/Safe/t/safe3.t#3 integrate
... //depot/maint-5.8/perl/ext/Safe/t/safeuniversal.t#1 branch
... //depot/maint-5.8/perl/ext/Sys/Syslog/Makefile.PL#6 integrate
... //depot/maint-5.8/perl/ext/Sys/Syslog/Syslog.pm#19 integrate
... //depot/maint-5.8/perl/ext/Sys/Syslog/fallback/syslog.h#1 branch
... //depot/maint-5.8/perl/ext/Sys/Syslog/t/syslog.t#8 integrate
... //depot/maint-5.8/perl/ext/threads/shared/shared.pm#16 integrate
... //depot/maint-5.8/perl/ext/threads/shared/shared.xs#30 integrate
... //depot/maint-5.8/perl/ext/threads/shared/t/object.t#1 branch
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#415 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#414~33006~ 2008-01-18 12:15:11.000000000 -0800
+++ perl/MANIFEST 2008-02-01 11:03:16.000000000 -0800
@@ -89,6 +89,7 @@
ext/B/B/disassemble Disassemble compiler bytecode output
ext/B/B/Disassembler.pm Compiler Disassembler backend
ext/B/B/Lint.pm Compiler Lint backend
+ext/B/B/Lint/Debug.pm Adds debugging stringification to B::
ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler
ext/B/B.pm Compiler backend support functions and methods
ext/B/B/Showlex.pm Compiler Showlex backend
@@ -821,6 +822,7 @@
ext/Safe/t/safe2.t See if Safe works
ext/Safe/t/safe3.t See if Safe works
ext/Safe/t/safeops.t Tests that all ops can be trapped by Safe
+ext/Safe/t/safeuniversal.t Tests Safe with functions from universal.c
ext/SDBM_File/Makefile.PL SDBM extension makefile writer
ext/SDBM_File/sdbm/biblio SDBM kit
ext/SDBM_File/sdbm/CHANGES SDBM kit
@@ -910,6 +912,7 @@
ext/Sys/Syslog/Changes Changlog for Sys::Syslog
ext/Sys/Syslog/fallback/const-c.inc Sys::Syslog constants fallback file
ext/Sys/Syslog/fallback/const-xs.inc Sys::Syslog constants fallback file
+ext/Sys/Syslog/fallback/syslog.h Sys::Syslog header fallback file
ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer
ext/Sys/Syslog/README README for Sys::Syslog
ext/Sys/Syslog/README.win32 README for Sys::Syslog on Windows
@@ -961,6 +964,7 @@
ext/threads/shared/t/hv_refs.t Test shared hashes containing references
ext/threads/shared/t/hv_simple.t Tests for basic shared hash
functionality.
ext/threads/shared/t/no_share.t Tests for disabled share on variables.
+ext/threads/shared/t/object.t Shared objects tests
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
==== //depot/maint-5.8/perl/ext/B/B/Lint.pm#9 (text) ====
Index: perl/ext/B/B/Lint.pm
--- perl/ext/B/B/Lint.pm#8~32256~ 2007-11-09 13:58:43.000000000 -0800
+++ perl/ext/B/B/Lint.pm 2008-02-01 11:03:16.000000000 -0800
@@ -1,6 +1,6 @@
package B::Lint;
-our $VERSION = '1.09'; ## no critic
+our $VERSION = '1.11'; ## no critic
=head1 NAME
@@ -185,6 +185,10 @@
Malcolm Beattie, [EMAIL PROTECTED]
+=head1 ACKNOWLEDGEMENTS
+
+Sebastien Aperghis-Tramoni - bug fixes
+
=cut
use strict;
@@ -347,8 +351,8 @@
my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
($elt) = first {
eval { $_->isa('B::SV') } ? $_ : ();
- }
- @elts[ 0, reverse 1 .. $#elts ];
+ }
+ @elts[ 0, reverse 1 .. $#elts ];
return $elt;
};
}
@@ -511,7 +515,7 @@
# scratchpad to find things. I suppose this is so a optree can be
# shared between threads and all symbol table muckery will just get
# written to a scratchpad.
-*B::PADOP::lint = \&B::SVOP::lint;
+*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
sub B::SVOP::lint {
my ($op) = @_;
==== //depot/maint-5.8/perl/ext/B/B/Lint/Debug.pm#1 (text) ====
Index: perl/ext/B/B/Lint/Debug.pm
--- /dev/null 2008-01-31 11:01:07.519870462 -0800
+++ perl/ext/B/B/Lint/Debug.pm 2008-02-01 11:03:16.000000000 -0800
@@ -0,0 +1,65 @@
+package B::Lint::Debug;
+
+=head1 NAME
+
+B::Lint::Debug - Adds debugging stringification to B::
+
+=head1 DESCRIPTION
+
+This module injects stringification to a B::OP*/B::SPECIAL. This
+should not be loaded unless you're debugging.
+
+=cut
+
+package B::SPECIAL;
+use overload '""' => sub {
+ my $self = shift @_;
+ "SPECIAL($$self)";
+};
+
+package B::OP;
+use overload '""' => sub {
+ my $self = shift @_;
+ my $class = ref $self;
+ $class =~ s/\AB:://xms;
+ my $name = $self->name;
+ "$class($name)";
+};
+
+package B::SVOP;
+use overload '""' => sub {
+ my $self = shift @_;
+ my $class = ref $self;
+ $class =~ s/\AB:://xms;
+ my $name = $self->name;
+ "$class($name," . $self->sv . "," . $self->gv . ")";
+};
+
+package B::SPECIAL;
+sub DESTROY { }
+our $AUTOLOAD;
+
+sub AUTOLOAD {
+ my $cx = 0;
+ print "AUTOLOAD $AUTOLOAD\n";
+
+ package DB;
+ while ( my @stuff = caller $cx ) {
+
+ print "$cx: [EMAIL PROTECTED]::args] [EMAIL PROTECTED]";
+ if ( ref $DB::args[0] ) {
+ if ( $DB::args[0]->can('padix') ) {
+ print " PADIX: " . $DB::args[0]->padix . "\n";
+ }
+ if ( $DB::args[0]->can('targ') ) {
+ print " TARG: " . $DB::args[0]->targ . "\n";
+ for ( B::Lint::cv()->PADLIST->ARRAY ) {
+ print +( $_->ARRAY )[ $DB::args[0]->targ ] . "\n";
+ }
+ }
+ }
+ ++$cx;
+ }
+}
+
+1;
==== //depot/maint-5.8/perl/ext/Opcode/Opcode.pm#4 (text) ====
Index: perl/ext/Opcode/Opcode.pm
--- perl/ext/Opcode/Opcode.pm#3~26806~ 2006-01-12 11:23:34.000000000 -0800
+++ perl/ext/Opcode/Opcode.pm 2008-02-01 11:03:16.000000000 -0800
@@ -557,14 +557,13 @@
syscall dump chroot
-
=back
=head1 SEE ALSO
-ops(3) -- perl pragma interface to Opcode module.
+L<ops> -- perl pragma interface to Opcode module.
-Safe(3) -- Opcode and namespace limited execution compartments
+L<Safe> -- Opcode and namespace limited execution compartments
=head1 AUTHORS
==== //depot/maint-5.8/perl/ext/Opcode/Safe.pm#9 (text) ====
Index: perl/ext/Opcode/Safe.pm
--- perl/ext/Opcode/Safe.pm#8~33111~ 2008-01-29 11:03:04.000000000 -0800
+++ perl/ext/Opcode/Safe.pm 2008-02-01 11:03:16.000000000 -0800
@@ -3,7 +3,7 @@
use 5.003_11;
use strict;
-$Safe::VERSION = "2.13";
+$Safe::VERSION = "2.15";
# *** Don't declare any lexicals above this point ***
#
@@ -40,7 +40,58 @@
my $default_root = 0;
-my $default_share = ['*_']; #, '*main::'];
+# share *_ and functions defined in universal.c
+# Don't share stuff like *UNIVERSAL:: otherwise code from the
+# compartment can 0wn functions in UNIVERSAL
+my $default_share = [qw[
+ *_
+ &PerlIO::get_layers
+ &Regexp::DESTROY
+ &UNIVERSAL::isa
+ &UNIVERSAL::can
+ &UNIVERSAL::VERSION
+ &utf8::is_utf8
+ &utf8::valid
+ &utf8::encode
+ &utf8::decode
+ &utf8::upgrade
+ &utf8::downgrade
+ &utf8::native_to_unicode
+ &utf8::unicode_to_native
+], ($] >= 5.010 && qw[
+ &re::is_regexp
+ &re::regname
+ &re::regnames
+ &re::regnames_count
+ &Tie::Hash::NamedCapture::FETCH
+ &Tie::Hash::NamedCapture::STORE
+ &Tie::Hash::NamedCapture::DELETE
+ &Tie::Hash::NamedCapture::CLEAR
+ &Tie::Hash::NamedCapture::EXISTS
+ &Tie::Hash::NamedCapture::FIRSTKEY
+ &Tie::Hash::NamedCapture::NEXTKEY
+ &Tie::Hash::NamedCapture::SCALAR
+ &Tie::Hash::NamedCapture::flags
+ &UNIVERSAL::DOES
+ &version::()
+ &version::new
+ &version::(""
+ &version::stringify
+ &version::(0+
+ &version::numify
+ &version::normal
+ &version::(cmp
+ &version::(<=>
+ &version::vcmp
+ &version::(bool
+ &version::boolean
+ &version::(nomethod
+ &version::noop
+ &version::is_alpha
+ &version::qv
+]), ($] >= 5.011 && qw[
+ &re::regexp_pattern
+])];
sub new {
my($class, $root, $mask) = @_;
@@ -185,9 +236,6 @@
my $arg;
foreach $arg (@$vars) {
# catch some $safe->share($var) errors:
- croak("'$arg' not a valid symbol table name")
- unless $arg =~ /[EMAIL PROTECTED]&]?\w[\w:]*$/
- or $arg =~ /^\$\W$/;
my ($var, $type);
$type = $1 if ($var = $arg) =~ s/^(\W)//;
# warn "share_from $pkg $type $var";
@@ -306,7 +354,7 @@
The default operator mask for a newly created compartment is
the ':default' optag.
-It is important that you read the Opcode(3) module documentation
+It is important that you read the L<Opcode> module documentation
for more information, especially for detailed definitions of opnames,
optags and opsets.
@@ -568,11 +616,11 @@
=head2 AUTHOR
-Originally designed and implemented by Malcolm Beattie,
[EMAIL PROTECTED]
+Originally designed and implemented by Malcolm Beattie.
-Reworked to use the Opcode module and other changes added by Tim Bunce
-E<lt>F<[EMAIL PROTECTED]>E<gt>.
+Reworked to use the Opcode module and other changes added by Tim Bunce.
+
+Currently maintained by the Perl 5 Porters, <[EMAIL PROTECTED]>.
=cut
==== //depot/maint-5.8/perl/ext/Opcode/ops.pm#4 (text) ====
Index: perl/ext/Opcode/ops.pm
--- perl/ext/Opcode/ops.pm#3~26806~ 2006-01-12 11:23:34.000000000 -0800
+++ perl/ext/Opcode/ops.pm 2008-02-01 11:03:16.000000000 -0800
@@ -33,7 +33,7 @@
=head1 DESCRIPTION
-Since the ops pragma currently has an irreversible global effect, it is
+Since the C<ops> pragma currently has an irreversible global effect, it is
only of significant practical use with the C<-M> option on the command line.
See the L<Opcode> module for information about opcodes, optags, opmasks
@@ -41,7 +41,7 @@
=head1 SEE ALSO
-Opcode(3), Safe(3), perlrun(3)
+L<Opcode>, L<Safe>, L<perlrun>
=cut
==== //depot/maint-5.8/perl/ext/Safe/t/safeuniversal.t#1 (text) ====
Index: perl/ext/Safe/t/safeuniversal.t
--- /dev/null 2008-01-31 11:01:07.519870462 -0800
+++ perl/ext/Safe/t/safeuniversal.t 2008-02-01 11:03:16.000000000 -0800
@@ -0,0 +1,46 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require Config;
+ import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use strict;
+use Test::More;
+use Safe;
+plan(tests => 6);
+
+my $c = new Safe;
+$c->permit(qw(require caller));
+
+my $r = $c->reval(q!
+ sub UNIVERSAL::isa { "pwned" }
+ (bless[],"Foo")->isa("Foo");
+!);
+
+is( $r, "pwned", "isa overriden in compartment" );
+is( (bless[],"Foo")->isa("Foo"), 1, "... but not outside" );
+
+sub Foo::foo {}
+
+$r = $c->reval(q!
+ sub UNIVERSAL::can { "pwned" }
+ (bless[],"Foo")->can("foo");
+!);
+
+is( $r, "pwned", "can overriden in compartment" );
+is( (bless[],"Foo")->can("foo"), \&Foo::foo, "... but not outside" );
+
+$r = $c->reval(q!
+ utf8::is_utf8("\x{100}");
+!);
+is( $@, '', 'can call utf8::is_valid' );
+is( $r, 1, '... returns 1' );
==== //depot/maint-5.8/perl/ext/Sys/Syslog/Makefile.PL#6 (text) ====
Index: perl/ext/Sys/Syslog/Makefile.PL
--- perl/ext/Sys/Syslog/Makefile.PL#5~32287~ 2007-11-12 10:07:41.000000000
-0800
+++ perl/ext/Sys/Syslog/Makefile.PL 2008-02-01 11:03:16.000000000 -0800
@@ -70,6 +70,9 @@
DEFINE => '-DUSE_PPPORT_H';
}
+# on pre-5.6 Perls, add warnings::compat to the prereq modules
+push @extra_prereqs, "warnings::compat" if $] < 5.006;
+
WriteMakefile(
NAME => 'Sys::Syslog',
LICENSE => 'perl',
==== //depot/maint-5.8/perl/ext/Sys/Syslog/Syslog.pm#19 (text) ====
Index: perl/ext/Sys/Syslog/Syslog.pm
--- perl/ext/Sys/Syslog/Syslog.pm#18~32287~ 2007-11-12 10:07:41.000000000
-0800
+++ perl/ext/Sys/Syslog/Syslog.pm 2008-02-01 11:03:16.000000000 -0800
@@ -10,7 +10,7 @@
require Exporter;
{ no strict 'vars';
- $VERSION = '0.22';
+ $VERSION = '0.24';
@ISA = qw(Exporter);
%EXPORT_TAGS = (
@@ -221,7 +221,7 @@
} elsif (lc $setsock eq 'pipe') {
for my $path ($syslog_path, &_PATH_LOG, "/dev/log") {
- next unless defined $path and length $path and -w $path;
+ next unless defined $path and length $path and -p $path and -w _;
$syslog_path = $path;
last
}
@@ -771,7 +771,7 @@
=head1 VERSION
-Version 0.22
+Version 0.24
=head1 SYNOPSIS
==== //depot/maint-5.8/perl/ext/Sys/Syslog/fallback/syslog.h#1 (text) ====
Index: perl/ext/Sys/Syslog/fallback/syslog.h
--- /dev/null 2008-01-31 11:01:07.519870462 -0800
+++ perl/ext/Sys/Syslog/fallback/syslog.h 2008-02-01 11:03:16.000000000
-0800
@@ -0,0 +1,111 @@
+/*
+ * Copyright (c) 1982, 1986, 1988, 1993
+ * The Regents of the University of California. All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ * @(#)syslog.h 8.1 (Berkeley) 6/2/93
+ */
+
+#ifndef _SYS_SYSLOG_H
+#define _SYS_SYSLOG_H 1
+
+#define _PATH_LOG ""
+
+/*
+ * priorities/facilities are encoded into a single 32-bit quantity, where the
+ * bottom 3 bits are the priority (0-7) and the top 28 bits are the facility
+ * (0-big number). Both the priorities and the facilities map roughly
+ * one-to-one to strings in the syslogd(8) source code. This mapping is
+ * included in this file.
+ *
+ * priorities (these are ordered)
+ */
+#define LOG_EMERG 0 /* system is unusable */
+#define LOG_ALERT 1 /* action must be taken immediately */
+#define LOG_CRIT 2 /* critical conditions */
+#define LOG_ERR 3 /* error conditions */
+#define LOG_WARNING 4 /* warning conditions */
+#define LOG_NOTICE 5 /* normal but significant condition */
+#define LOG_INFO 6 /* informational */
+#define LOG_DEBUG 7 /* debug-level messages */
+
+#define LOG_PRIMASK 0x07 /* mask to extract priority part
(internal) */
+ /* extract priority */
+#define LOG_PRI(p) ((p) & LOG_PRIMASK)
+#define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri))
+
+/* facility codes */
+#define LOG_KERN (0<<3) /* kernel messages */
+#define LOG_USER (1<<3) /* random user-level messages */
+#define LOG_MAIL (2<<3) /* mail system */
+#define LOG_DAEMON (3<<3) /* system daemons */
+#define LOG_AUTH (4<<3) /* security/authorization messages */
+#define LOG_SYSLOG (5<<3) /* messages generated internally by
syslogd */
+#define LOG_LPR (6<<3) /* line printer subsystem */
+#define LOG_NEWS (7<<3) /* network news subsystem */
+#define LOG_UUCP (8<<3) /* UUCP subsystem */
+#define LOG_CRON (9<<3) /* clock daemon */
+#define LOG_AUTHPRIV (10<<3) /* security/authorization messages
(private) */
+#define LOG_FTP (11<<3) /* ftp daemon */
+#define LOG_NETINFO (12<<3) /* NetInfo */
+#define LOG_REMOTEAUTH (13<<3) /* remote authentication/authorization
*/
+#define LOG_INSTALL (14<<3) /* installer subsystem */
+#define LOG_RAS (15<<3) /* Remote Access Service (VPN / PPP) */
+#define LOG_LOCAL0 (16<<3) /* reserved for local use */
+#define LOG_LOCAL1 (17<<3) /* reserved for local use */
+#define LOG_LOCAL2 (18<<3) /* reserved for local use */
+#define LOG_LOCAL3 (19<<3) /* reserved for local use */
+#define LOG_LOCAL4 (20<<3) /* reserved for local use */
+#define LOG_LOCAL5 (21<<3) /* reserved for local use */
+#define LOG_LOCAL6 (22<<3) /* reserved for local use */
+#define LOG_LOCAL7 (23<<3) /* reserved for local use */
+#define LOG_LAUNCHD (24<<3) /* launchd - general bootstrap daemon */
+
+#define LOG_NFACILITIES 25 /* current number of facilities */
+#define LOG_FACMASK 0x03f8 /* mask to extract facility part */
+ /* facility of pri */
+#define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3)
+
+/*
+ * arguments to setlogmask.
+ */
+#define LOG_MASK(pri) (1 << (pri)) /* mask for one
priority */
+#define LOG_UPTO(pri) ((1 << ((pri)+1)) - 1) /* all priorities
through pri */
+
+/*
+ * Option flags for openlog.
+ *
+ * LOG_ODELAY no longer does anything.
+ * LOG_NDELAY is the inverse of what it used to be.
+ */
+#define LOG_PID 0x01 /* log the pid with each message */
+#define LOG_CONS 0x02 /* log on the console if errors in
sending */
+#define LOG_ODELAY 0x04 /* delay open until first syslog()
(default) */
+#define LOG_NDELAY 0x08 /* don't delay open */
+#define LOG_NOWAIT 0x10 /* don't wait for console forks:
DEPRECATED */
+#define LOG_PERROR 0x20 /* log to stderr as well */
+
+#endif /* sys/syslog.h */
==== //depot/maint-5.8/perl/ext/Sys/Syslog/t/syslog.t#8 (xtext) ====
Index: perl/ext/Sys/Syslog/t/syslog.t
--- perl/ext/Sys/Syslog/t/syslog.t#7~32287~ 2007-11-12 10:07:41.000000000
-0800
+++ perl/ext/Sys/Syslog/t/syslog.t 2008-02-01 11:03:16.000000000 -0800
@@ -19,6 +19,10 @@
pack portable recursion redefine regexp severe signal substr
syntax taint uninitialized unpack untie utf8 void);
+# if someone is using warnings::compat, the previous trick won't work, so we
+# must manually disable warnings
+$^W = 0 if $] < 5.006;
+
my $is_Win32 = $^O =~ /win32/i;
my $is_Cygwin = $^O =~ /cygwin/i;
@@ -189,6 +193,9 @@
skip "the 'unix' mechanism works, so the tests will likely fail with the
'stream' mechanism", 10
if grep {/unix/} @passed;
+ skip "not testing setlogsock('stream'): _PATH_LOG unavailable", 10
+ unless -e Sys::Syslog::_PATH_LOG();
+
# setlogsock() with "stream" and an undef path
$r = eval { setlogsock("stream", undef ) } || '';
is( $@, '', "setlogsock() called, with 'stream' and an undef path" );
==== //depot/maint-5.8/perl/ext/threads/shared/shared.pm#16 (text) ====
Index: perl/ext/threads/shared/shared.pm
--- perl/ext/threads/shared/shared.pm#15~32289~ 2007-11-12 11:42:34.000000000
-0800
+++ perl/ext/threads/shared/shared.pm 2008-02-01 11:03:16.000000000 -0800
@@ -5,7 +5,7 @@
use strict;
use warnings;
-our $VERSION = '1.14';
+our $VERSION = '1.15';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -73,7 +73,7 @@
=head1 VERSION
-This document describes threads::shared version 1.14
+This document describes threads::shared version 1.15
=head1 SYNOPSIS
@@ -360,7 +360,7 @@
C<< lock($hasref->{key}) >>.
View existing bug reports at, and submit any new bugs, problems, patches, etc.
-to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads-shared>
+to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
=head1 SEE ALSO
@@ -368,7 +368,7 @@
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.14/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.15/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
==== //depot/maint-5.8/perl/ext/threads/shared/shared.xs#30 (text) ====
Index: perl/ext/threads/shared/shared.xs
--- perl/ext/threads/shared/shared.xs#29~32289~ 2007-11-12 11:42:34.000000000
-0800
+++ perl/ext/threads/shared/shared.xs 2008-02-01 11:03:16.000000000 -0800
@@ -1108,6 +1108,24 @@
}
+/* Can a shared object be destroyed?
+ * True if not a shared,
+ * or if detroying last proxy on a shared object
+ */
+#ifdef PL_destroyhook
+bool
+Perl_shared_object_destroy(pTHX_ SV *sv)
+{
+ SV *ssv;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ ssv = Perl_sharedsv_find(aTHX_ sv);
+ return (!ssv || (SvREFCNT(ssv) <= 1));
+}
+#endif
+
+
/* Saves a space for keeping SVs wider than an interpreter. */
void
@@ -1121,6 +1139,9 @@
recursive_lock_init(aTHX_ &PL_sharedsv_lock);
PL_lockhook = &Perl_sharedsv_locksv;
PL_sharehook = &Perl_sharedsv_share;
+#ifdef PL_destroyhook
+ PL_destroyhook = &Perl_shared_object_destroy;
+#endif
}
#endif /* USE_ITHREADS */
==== //depot/maint-5.8/perl/ext/threads/shared/t/object.t#1 (text) ====
Index: perl/ext/threads/shared/t/object.t
--- /dev/null 2008-01-31 11:01:07.519870462 -0800
+++ perl/ext/threads/shared/t/object.t 2008-02-01 11:03:16.000000000 -0800
@@ -0,0 +1,151 @@
+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);
+ }
+ if ($] < 5.010) {
+ print("1..0 # Skip: Needs Perl 5.10.0 or later\n");
+ exit(0);
+ }
+}
+
+use ExtUtils::testlib;
+
+BEGIN {
+ $| = 1;
+ print("1..23\n"); ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
+
+sub ok {
+ my ($ok, $name) = @_;
+
+ lock($TEST);
+ my $id = $TEST++;
+
+ # You have to do it this way or VMS will get confused.
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+
+ return ($ok);
+}
+
+ok(1, 'Loaded');
+
+### Start of Testing ###
+
+{ package Jar;
+ my @jar :shared;
+
+ sub new
+ {
+ bless(&threads::shared::share({}), shift);
+ }
+
+ sub store
+ {
+ my ($self, $cookie) = @_;
+ push(@jar, $cookie);
+ return $jar[-1]; # Results in destruction of proxy object
+ }
+
+ sub peek
+ {
+ return $jar[-1];
+ }
+
+ sub fetch
+ {
+ pop(@jar);
+ }
+}
+
+{ package Cookie;
+
+ sub new
+ {
+ my $self = bless(&threads::shared::share({}), shift);
+ $self->{'type'} = shift;
+ return $self;
+ }
+
+ sub DESTROY
+ {
+ delete(shift->{'type'});
+ }
+}
+
+my $C1 = 'chocolate chip';
+my $C2 = 'oatmeal raisin';
+my $C3 = 'vanilla wafer';
+
+my $cookie = Cookie->new($C1);
+ok($cookie->{'type'} eq $C1, 'Have cookie');
+
+my $jar = Jar->new();
+$jar->store($cookie);
+
+ok($cookie->{'type'} eq $C1, 'Still have cookie');
+ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
+ok($cookie->{'type'} eq $C1, 'Still have cookie');
+
+threads->create(sub {
+ ok($cookie->{'type'} eq $C1, 'Have cookie in thread');
+ ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
+ ok($cookie->{'type'} eq $C1, 'Still have cookie in thread');
+
+ $jar->store(Cookie->new($C2));
+ ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
+})->join();
+
+ok($cookie->{'type'} eq $C1, 'Still have original cookie after thread');
+ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
+
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C2, 'Fetched cookie from jar');
+ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
+
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C1, 'Fetched cookie from jar');
+undef($cookie);
+
+share($cookie);
+$cookie = $jar->store(Cookie->new($C3));
+ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
+ok($cookie->{'type'} eq $C3, 'Have cookie');
+
+threads->create(sub {
+ ok($cookie->{'type'} eq $C3, 'Have cookie in thread');
+ $cookie = Cookie->new($C1);
+ ok($cookie->{'type'} eq $C1, 'Change cookie in thread');
+ ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+})->join();
+
+ok($cookie->{'type'} eq $C1, 'Have changed cookie after thread');
+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+undef($cookie);
+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C3, 'Fetched cookie from jar');
+
+# EOF
End of Patch.
