Version v5.7.X Development release working toward v5.8
--------------
____________________________________________________________________________
+[ 16693] By: jhi on 2002/05/19 14:28:37
+ Log: Subject: [PATCH] Benchmark.pm: empty loop too slow
+ From: Slaven Rezic <slaven.rezic@berlin.de>
+ Date: Sun, 19 May 2002 16:03:12 +0200 (CEST)
+ Message-Id: <200205191403.g4JE3ClB025990@vran.herceg.de>
+ Branch: perl
+ ! lib/Benchmark.pm
+____________________________________________________________________________
+[ 16692] By: jhi on 2002/05/19 03:05:41
+ Log: Document once more the difference between :utf8
+ and :encoding(...).
+ Branch: perl
+ ! lib/open.pm pod/perluniintro.pod
+____________________________________________________________________________
+[ 16691] By: jhi on 2002/05/19 02:24:30
+ Log: Third Degree: make the options more portable between
+ Tru64 versions.
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 16690] By: jhi on 2002/05/19 01:41:54
+ Log: IRIX SMP turned up a few hundred "Use of uninitialized
+ value in numeric eq" warnings: initialise the $counter2.
+ Branch: perl
+ ! ext/threads/shared/t/cond.t
+____________________________________________________________________________
+[ 16689] By: jhi on 2002/05/19 00:29:36
+ Log: Subject: Re: [PATCH threads] revised warnings + more tests + docs
+ From: Dave Mitchell <davem@fdgroup.com>
+ Date: Sun, 19 May 2002 00:50:43 +0100
+ Message-ID: <20020519005043.F7275@fdgroup.com>
+ Branch: perl
+ ! ext/threads/shared/t/cond.t
+____________________________________________________________________________
+[ 16688] By: jhi on 2002/05/19 00:28:51
+ Log: Sarathy pointed out that instead of zeroing heap
+ it is more prudent to poison it.
+ Branch: perl
+ ! handy.h pod/perlapi.pod pod/perlclib.pod pod/perlhack.pod
+ ! scope.c sv.c util.c
+____________________________________________________________________________
+[ 16687] By: jhi on 2002/05/18 22:03:29
+ Log: The thread warnings aren't quite yet working as planned.
+ Branch: perl
+ ! ext/threads/shared/t/cond.t
+____________________________________________________________________________
+[ 16686] By: jhi on 2002/05/18 20:48:03
+ Log: Forgotten from #16685.
+ Branch: perl
+ ! ext/threads/shared/t/cond.t
+____________________________________________________________________________
+[ 16685] By: jhi on 2002/05/18 20:46:13
+ Log: Subject: [PATCH threads] revised warnings + more tests + docs
+ From: Dave Mitchell <davem@fdgroup.com>
+ Date: Sat, 18 May 2002 22:24:51 +0100
+ Message-ID: <20020518222451.E7275@fdgroup.com>
+ Branch: perl
+ ! ext/threads/shared/shared.pm ext/threads/shared/shared.xs
+ ! ext/threads/t/thread.t ext/threads/threads.pm lib/warnings.pm
+ ! pod/perldiag.pod pod/perllexwarn.pod warnings.h warnings.pl
+____________________________________________________________________________
+[ 16684] By: jhi on 2002/05/18 20:10:53
+ Log: Storable status tweak.
+ Branch: perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 16683] By: rgs on 2002/05/18 19:39:42
+ Log: perlfunc and perldelta updates about caller().
+ Branch: perl
+ ! pod/perldelta.pod pod/perlfunc.pod
+____________________________________________________________________________
+[ 16682] By: jhi on 2002/05/18 19:33:51
+ Log: Subject: [PATCH] RE: perl@16678
+ From: "Paul Marquess" <Paul.Marquess@ntlworld.com>
+ Date: Sat, 18 May 2002 21:15:43 +0100
+ Message-ID: <AIEAJICLCBDNAAOLLOKLCEAPELAA.Paul.Marquess@ntlworld.com>
+
+ Making the symbols generated by warnings.pl future-proof.
+ Branch: perl
+ ! lib/warnings.pm warnings.h warnings.pl
+____________________________________________________________________________
+[ 16681] By: jhi on 2002/05/18 18:44:32
+ Log: Subject: [PATCH] ExtUtils::MakeMaker 5.94_02 -> 5.95_01
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 18 May 2002 14:53:50 -0400
+ Message-ID: <20020518185350.GB2878@ool-18b93024.dyn.optonline.net>
+ Branch: perl
+ ! lib/ExtUtils/Changes lib/ExtUtils/MakeMaker.pm
+ ! lib/ExtUtils/t/testlib.t lib/ExtUtils/testlib.pm
+____________________________________________________________________________
+[ 16680] By: jhi on 2002/05/18 18:43:35
+ Log: Prettyprinting.
+ Branch: perl
+ ! t/op/recurse.t
+____________________________________________________________________________
+[ 16679] By: jhi on 2002/05/18 18:42:08
+ Log: Companion to #16601: cxinc would create uninitialized
+ PERL_CONTEXTs. The bug was tickled by the test
+ lib/Math/BigInt/t/upgrade.t, the new test of recurse.t
+ added to check that I got the context stack extension right.
+ Also rewrite recurse.t to use test.pl.
+ Branch: perl
+ ! scope.c t/op/recurse.t
+____________________________________________________________________________
+[ 16678] By: jhi on 2002/05/18 16:38:29
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
+[ 16677] By: jhi on 2002/05/18 15:50:25
+ Log: URL and other tiny tweaks.
+ Branch: perl
+ ! pod/perluniintro.pod
+____________________________________________________________________________
+[ 16676] By: jhi on 2002/05/18 15:40:35
+ Log: Subject: [Patch] doc patch on Unicode
+ From: SADAHIRO Tomoyuki <bqw10602@nifty.com>
+ Date: Sun, 19 May 2002 01:01:58 +0900
+ Message-Id: <20020519005515.18F0.BQW10602@nifty.com>
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perlunicode.pod pod/perluniintro.pod
+____________________________________________________________________________
+[ 16675] By: ams on 2002/05/18 15:06:35
+ Log: s/2.0/2.00/ to be CPAN friendly.
+ Branch: perl
+ ! ext/Storable/Storable.pm
+____________________________________________________________________________
+[ 16674] By: ams on 2002/05/18 14:47:07
+ Log: Subject: Re: Change 16621: 1. Not hardcoding \x0A and \x0D seems to help
+ EBCDIC, amazing.
+ From: Philip Newton <Philip.Newton@gmx.net>
+ Date: Sat, 18 May 2002 09:54:13 +0200
+ Message-Id: <432ceucrfducg2iitau6uggeb02lu209a2@4ax.com>
+ Branch: perl
+ ! lib/Pod/t/eol.t
+____________________________________________________________________________
+[ 16673] By: ams on 2002/05/18 14:41:00
+ Log: Subject: Storable test for 64 bit 5.6.1
+ From: Nicholas Clark <nick@unfortu.net>
+ Date: Sat, 18 May 2002 15:48:55 +0100
+ Message-Id: <20020518144854.GD304@Bagpuss.unfortu.net>
+ (Private mail.)
+ Branch: perl
+ ! ext/Storable/t/malice.t
+____________________________________________________________________________
+[ 16672] By: nick on 2002/05/18 09:47:51
+ Log: Integrate mainline
+ Branch: perlio
+ +> t/lib/sample-tests/shbang_misparse t/op/caller.t
+ - t/lib/st-dump.pl
+ !> (integrate 67 files)
+____________________________________________________________________________
+[ 16671] By: jhi on 2002/05/18 04:31:00
+ Log: No more true.
+ Branch: perl
+ ! lib/vars.pm
+____________________________________________________________________________
+[ 16670] By: jhi on 2002/05/18 04:14:25
+ Log: Make use vars grok UTF-8.
+ Branch: perl
+ ! lib/vars.pm t/run/fresh_perl.t
+____________________________________________________________________________
+[ 16669] By: jhi on 2002/05/18 03:53:27
+ Log: Subject: [PATCH] Re: t/op/tie.t #19 TODO ENOTWORKING
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 17 May 2002 23:54:29 -0400
+ Message-ID: <20020518035429.GA704@ool-18b93024.dyn.optonline.net>
+ Branch: perl
+ ! t/op/tie.t t/run/fresh_perl.t
+____________________________________________________________________________
+[ 16668] By: jhi on 2002/05/18 03:44:57
+ Log: Subject: [PATCH] Test::Harness 2.21 -> 2.22
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 17 May 2002 20:37:26 -0400
+ Message-ID: <20020518003726.GB358@ool-18b93024.dyn.optonline.net>
+ Branch: perl
+ + t/lib/sample-tests/shbang_misparse
+ ! MANIFEST lib/Test/Harness.pm lib/Test/Harness/Changes
+ ! lib/Test/Harness/Straps.pm lib/Test/Harness/t/strap-analyze.t
+ ! lib/Test/Harness/t/test-harness.t
+____________________________________________________________________________
+[ 16667] By: jhi on 2002/05/18 03:41:34
+ Log: Subject: [PATCH] Re: [PATCH] Storable stand alone tests
+ From: Nicholas Clark <nick@unfortu.net>
+ Date: Sat, 18 May 2002 00:18:39 +0100
+ Message-ID: <20020517231838.GI290@Bagpuss.unfortu.net>
+
+ Use Storable's st-dump.pl.
+ Branch: perl
+ - t/lib/st-dump.pl
+ ! MANIFEST ext/Storable/t/blessed.t ext/Storable/t/compat06.t
+ ! ext/Storable/t/dclone.t ext/Storable/t/freeze.t
+ ! ext/Storable/t/lock.t ext/Storable/t/overload.t
+ ! ext/Storable/t/recurse.t ext/Storable/t/restrict.t
+ ! ext/Storable/t/retrieve.t ext/Storable/t/store.t
+ ! ext/Storable/t/tied.t ext/Storable/t/tied_hook.t
+ ! ext/Storable/t/tied_items.t ext/Storable/t/utf8.t
+____________________________________________________________________________
+[ 16666] By: jhi on 2002/05/17 21:46:04
+ Log: Forgotten from #16656.
+ Branch: perl
+ ! ext/B/B.xs
+____________________________________________________________________________
+[ 16665] By: jhi on 2002/05/17 21:40:55
+ Log: Subject: [PATCH] Storable ChangeLog ready for release
+ From: Nicholas Clark <nick@unfortu.net>
+ Date: Fri, 17 May 2002 23:17:34 +0100
+ Message-ID: <20020517221733.GH290@Bagpuss.unfortu.net>
+ Branch: perl
+ ! ext/Storable/ChangeLog
+____________________________________________________________________________
+[ 16664] By: jhi on 2002/05/17 21:39:37
+ Log: Subject: [PATCH] Storable stand alone tests
+ From: Nicholas Clark <nick@unfortu.net>
+ Date: Fri, 17 May 2002 22:43:35 +0100
+ Message-ID: <20020517214334.GG290@Bagpuss.unfortu.net>
+ Branch: perl
+ ! ext/Storable/t/blessed.t ext/Storable/t/canonical.t
+ ! ext/Storable/t/compat06.t ext/Storable/t/croak.t
+ ! ext/Storable/t/dclone.t ext/Storable/t/downgrade.t
+ ! ext/Storable/t/forgive.t ext/Storable/t/freeze.t
+ ! ext/Storable/t/lock.t ext/Storable/t/malice.t
+ ! ext/Storable/t/overload.t ext/Storable/t/recurse.t
+ ! ext/Storable/t/restrict.t ext/Storable/t/retrieve.t
+ ! ext/Storable/t/store.t ext/Storable/t/tied.t
+ ! ext/Storable/t/tied_hook.t ext/Storable/t/tied_items.t
+ ! ext/Storable/t/utf8.t ext/Storable/t/utf8hash.t
+____________________________________________________________________________
+[ 16663] By: jhi on 2002/05/17 21:35:45
+ Log: Subject: [PATCH] ExtUtils::MakeMaker 5.92_01 -> 5.94_02
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 17 May 2002 17:17:54 -0400
+ Message-ID: <20020517211754.GK13131@ool-18b93024.dyn.optonline.net>
+ Branch: perl
+ ! lib/ExtUtils/Changes lib/ExtUtils/Command.pm
+ ! lib/ExtUtils/Command/MM.pm lib/ExtUtils/Install.pm
+ ! lib/ExtUtils/Installed.pm lib/ExtUtils/Liblist.pm
+ ! lib/ExtUtils/Liblist/Kid.pm lib/ExtUtils/MM_BeOS.pm
+ ! lib/ExtUtils/MM_MacOS.pm lib/ExtUtils/MM_NW5.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm
+ ! lib/ExtUtils/Mksymlists.pm lib/ExtUtils/Packlist.pm
+ ! lib/ExtUtils/t/00setup_dummy.t lib/ExtUtils/t/Command.t
+ ! lib/ExtUtils/t/INST.t lib/ExtUtils/t/Installed.t
+ ! lib/ExtUtils/t/MM_Cygwin.t lib/ExtUtils/t/MM_Unix.t
+ ! lib/ExtUtils/t/Manifest.t lib/ExtUtils/t/Mkbootstrap.t
+ ! lib/ExtUtils/t/Packlist.t lib/ExtUtils/t/VERSION_FROM.t
+ ! lib/ExtUtils/t/basic.t lib/ExtUtils/t/hints.t
+____________________________________________________________________________
+[ 16662] By: rgs on 2002/05/17 20:07:21
+ Log: More regression tests for caller() and fix one bug of #16658.
+ Branch: perl
+ ! pp_ctl.c t/op/caller.t
+____________________________________________________________________________
+[ 16661] By: jhi on 2002/05/17 19:13:18
+ Log: Integrate perlio;
+
+ Fix the crlf.t buffer leak
+ - actually a generic PerlIOBuf_xxx derived leak-on-pop, but :crlf
+ flagged it because it is more often popped without stream
+ being closed.
+ - Define non-noop PerlIOBuf_popped(), use it and export it.
+ Branch: perl
+ !> makedef.pl perlio.c perliol.h
+____________________________________________________________________________
+[ 16660] By: rgs on 2002/05/17 19:09:03
+ Log: Add a note about Cwd::fastcwd() returning tainted data.
+ Sort modules alphabetically.
+ Branch: perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 16659] By: rgs on 2002/05/17 19:05:11
+ Log: Remove O from the untested modules list.
+ Branch: perl
+ ! t/lib/1_compile.t
+____________________________________________________________________________
+[ 16658] By: rgs on 2002/05/17 19:03:06
+ Log: Fix bug 20020517.003 : segfault with caller().
+ Add regression tests for caller.
+ Branch: perl
+ + t/op/caller.t
+ ! MANIFEST pp_ctl.c
+____________________________________________________________________________
+[ 16657] By: nick on 2002/05/17 17:18:18
+ Log: Fix the crlf.t buffer leak
+ - actually a generic PerlIOBuf_xxx derived leak-on-pop, but :crlf
+ flagged it because it is more often popped without stream
+ being closed.
+ - Define non-noop PerlIOBuf_popped(), use it and export it.
+ Branch: perlio
+ ! makedef.pl perlio.c perliol.h
+____________________________________________________________________________
+[ 16656] By: jhi on 2002/05/17 16:52:15
+ Log: PERL_HASH() casting games so that our hashed data is "unsigned
+ char" but old code using just a "char" doesn't need changes.
+ (The change is using a temporary pointer instead of a direct
+ cast to unsigned char* which would blindly cast anything,
+ not just char pointers.) (The problem arose in MacOS Classic,
+ as seen by Pudge, the cure by Nicholas Clark.)
+ Branch: perl
+ ! hv.c hv.h op.c sv.c vms/vms.c
+____________________________________________________________________________
+[ 16655] By: nick on 2002/05/17 14:59:20
+ Log: Integrate mainline
+ Branch: perlio
+ !> (integrate 28 files)
+____________________________________________________________________________
+[ 16654] By: jhi on 2002/05/17 12:24:07
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
[ 16653] By: jhi on 2002/05/17 12:18:54
Log: FAQ sync.
Branch: perl
@grep "^usemymalloc='n'" config.sh >/dev/null || exit 1
perl.third: /usr/bin/atom perl.third.config perl
- atom -tool third -L. -all -gp -toolargs="-pthread -fork -quiet -invalid -uninit heap+stack+partword+copy -min 0" perl
+ atom -tool third -L. -all -gp -toolargs="-invalid -uninit heap+stack+copy -min 0" perl
@echo "Now you may run perl.third and then study perl.3log."
# Pixie Perls (Tru64 and IRIX only)
use AutoLoader;
use vars qw($forgive_me $VERSION);
-$VERSION = '2.0';
+$VERSION = '2.00';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
}
use strict;
-use vars qw($file_magic_str $other_magic $network_magic $major $minor
- $minor_write $fancy);
+use vars qw($file_magic_str $other_magic $network_magic $byteorder
+ $major $minor $minor_write $fancy);
+
+$byteorder = $Config{byteorder};
+
+if ($] < 5.007003 && $] >= 5.006 && $^O ne 'MSWin32'
+ && $Config{longsize} != $Config{ivsize}) {
+ # 5.6.x, not on Windows, built with IVs as long long
+ # config.h and Config.sh differ in their idea of the value of byteorder
+ # Storable's header is written out using C (hence config.h), but we're
+ # testing with perl
+ if ($byteorder eq '12345678') {
+ $byteorder = '1234';
+ } elsif ($byteorder eq '87654321') {
+ $byteorder = '4321';
+ } else {
+ die "I don't recognise Your byteorder: '$byteorder'";
+ }
+}
+
$file_magic_str = 'pst0';
-$other_magic = 7 + length($Config{byteorder});
+$other_magic = 7 + length $byteorder;
$network_magic = 2;
$major = 2;
$minor = 5;
# present in files, but not in things store()ed to memory
$fancy = ($] > 5.007 ? 2 : 0);
-plan tests => 378 + length($Config{byteorder}) * 4 + $fancy * 8;
+plan tests => 368 + length ($byteorder) * 4 + $fancy * 8;
use Storable qw (store retrieve freeze thaw nstore nfreeze);
is ($header->{major}, $major, "major number");
is ($header->{minor}, $minor_write, "minor number");
is (!!$header->{netorder}, !!$isnetorder, "is network order");
- SKIP: {
- skip "Network order header has no sizes", 5 if ($isnetorder);
- is ($header->{byteorder}, $Config{byteorder}, "byte order");
+ if ($isnetorder) {
+ # Network order header has no sizes
+ } else {
+ is ($header->{byteorder}, $byteorder, "byte order");
is ($header->{intsize}, $Config{intsize}, "int size");
is ($header->{longsize}, $Config{longsize}, "long size");
is ($header->{ptrsize}, $Config{ptrsize}, "long size");
use threads;
use threads::shared;
+ my $var : shared;
+
my($scalar, @array, %hash);
share($scalar);
share(@array);
my $bar = share([]);
$hash{bar} = share({});
- lock(%hash);
- unlock(%hash);
+ { lock(%hash); ... }
+
cond_wait($scalar);
cond_broadcast(@array);
cond_signal(%hash);
=head1 DESCRIPTION
-This modules allows you to share() variables. These variables will
-then be shared across different threads (and pseudoforks on
-win32). They are used together with the threads module.
+By default, variables are private to each thread, and each newly created
+thread gets a private copy of each existing variable. This module allows
+you to share variables across different threads (and pseudoforks on
+win32). It is used together with the threads module.
=head1 EXPORT
-C<share>, C<lock>, C<unlock>, C<cond_wait>, C<cond_signal>, C<cond_broadcast>
+C<share>, C<lock>, C<cond_wait>, C<cond_signal>, C<cond_broadcast>
=head1 FUNCTIONS
C<share> will traverse up references exactly I<one> level.
C<share(\$a)> is equivalent to C<share($a)>, while C<share(\\$a)> is not.
+A variable can also be marked as shared at compile time by using the
+C<shared> attribute: C<my $var : shared>.
+
=item lock VARIABLE
C<lock> places a lock on a variable until the lock goes out of scope. If
the variable is locked by another thread, the C<lock> call will block until
it's available. C<lock> is recursive, so multiple calls to C<lock> are
safe -- the variable will remain locked until the outermost lock on the
-variable goes out of scope or C<unlock> is called enough times to match
-the number of calls to <lock>.
+variable goes out of scope.
If a container object, such as a hash or array, is locked, all the elements
of that container are not locked. For example, if a thread does a C<lock
C<lock> will traverse up references exactly I<one> level.
C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not.
-
-=item unlock VARIABLE
-
-C<unlock> takes a B<locked> variable and decrements the lock count.
-If the lock count is zero the variable is unlocked. It is not necessary
-to call C<unlock> but it can be useful to reduce lock contention.
-
-C<unlock> will traverse up references exactly I<one> level.
-C<unlock(\$a)> is equivalent to C<unlock($a)>, while C<unlock(\\$a)> is not.
+Note that you cannot explicitly unlock a variable; you can only wait for
+the lock to go out of scope. If you need more fine-grained control, see
+L<threads::shared::semaphore>.
=item cond_wait VARIABLE
C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied.
If there are multiple threads C<cond_wait>ing on the same variable, all but
one will reblock waiting to reacquire the lock on the variable. (So if
-you're only using C<cond_wait> for synchronization, give up the lock as
-soon as possible)
+you're only using C<cond_wait> for synchronisation, give up the lock as
+soon as possible). The two actions of unlocking the variable and entering
+the blocked wait state are atomic, The two actions of exiting from the
+blocked wait state and relocking the variable are not.
It is important to note that the variable can be notified even if no
thread C<cond_signal> or C<cond_broadcast> on the variable. It is therefore
which one is indeterminate) will be unblocked.
If there are no threads blocked in a C<cond_wait> on the variable, the
-signal is discarded.
+signal is discarded. By always locking before signaling, you can (with
+care), avoid signaling before another thread has entered cond_wait().
+
+C<cond_signal> will normally generate a warning if you attempt to use it
+on an unlocked variable. On the rare occasions where doing this may be
+sensible, you can skip the warning with
+
+ { no warnings 'threads'; cond_signal($foo) }
=item cond_broadcast VARIABLE
if(SvROK(sv))
sv = SvRV(sv);
- shared = Perl_sharedsv_find(aTHX, sv);
+ shared = Perl_sharedsv_find(aTHX_ sv);
if(!shared)
croak("lock can only be used on shared values");
Perl_sharedsv_lock(aTHX_ shared);
ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
- Perl_sharedsv_share(aTHX, ref);
+ Perl_sharedsv_share(aTHX_ ref);
void
lock_enabled(SV *ref)
ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
- shared = Perl_sharedsv_find(aTHX, ref);
+ shared = Perl_sharedsv_find(aTHX_ ref);
if(!shared)
croak("lock can only be used on shared values");
Perl_sharedsv_lock(aTHX_ shared);
if(SvROK(ref))
ref = SvRV(ref);
shared = Perl_sharedsv_find(aTHX_ ref);
+ if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "cond_signal() called on unlocked variable");
if(!shared)
croak("cond_signal can only be used on shared values");
COND_SIGNAL(&shared->user_cond);
shared = Perl_sharedsv_find(aTHX_ ref);
if(!shared)
croak("cond_broadcast can only be used on shared values");
+ if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "cond_broadcast() called on unlocked variable");
COND_BROADCAST(&shared->user_cond);
#endif /* USE_ITHREADS */
}
}
$|++;
-print "1..5\n";
+print "1..29\n";
use strict;
use threads::shared;
-my $lock : shared;
+# We can't use the normal ok() type stuff here, as part of the test is
+# to check that the numbers get printed in the right order. Instead, we
+# set a 'base' number for each part of the test and specify the ok()
+# number as an offset from that base.
-sub foo {
- lock($lock);
- print "ok 1\n";
- my $tr2 = threads->create(\&bar);
- cond_wait($lock);
- $tr2->join();
- print "ok 5\n";
+my $Base = 0;
+
+sub ok {
+ my ($offset, $bool, $text) = @_;
+ print "not " unless $bool;
+ print "ok ", $Base + $offset, " - $text\n";
}
-sub bar {
- print "ok 2\n";
- lock($lock);
- print "ok 3\n";
+# test locking
+
+{
+ my $lock : shared;
+ my $tr;
+
+ # test that a subthread can't lock until parent thread has unlocked
+
+ {
+ lock($lock);
+ ok(1,1,"set first lock");
+ $tr = async {
+ lock($lock);
+ ok(3,1,"set lock in subthread");
+ };
+ threads->yield;
+ ok(2,1,"still got lock");
+ }
+ $tr->join;
+
+ $Base += 3;
+
+ # ditto with ref to thread
+
+ {
+ my $lockref = \$lock;
+ lock($lockref);
+ ok(1,1,"set first lockref");
+ $tr = async {
+ lock($lockref);
+ ok(3,1,"set lockref in subthread");
+ };
+ threads->yield;
+ ok(2,1,"still got lockref");
+ }
+ $tr->join;
+
+ $Base += 3;
+
+ # make sure recursive locks unlock at the right place
+ {
+ lock($lock);
+ ok(1,1,"set first recursive lock");
+ lock($lock);
+ threads->yield;
+ {
+ lock($lock);
+ threads->yield;
+ }
+ $tr = async {
+ lock($lock);
+ ok(3,1,"set recursive lock in subthread");
+ };
+ {
+ lock($lock);
+ threads->yield;
+ {
+ lock($lock);
+ threads->yield;
+ lock($lock);
+ threads->yield;
+ }
+ }
+ ok(2,1,"still got recursive lock");
+ }
+ $tr->join;
+
+ $Base += 3;
+
+ # Make sure a lock factory gives out fresh locks each time
+ # for both attribute and run-time shares
+
+ sub lock_factory1 { my $lock : shared; return \$lock; }
+ sub lock_factory2 { my $lock; share($lock); return \$lock; }
+
+ my (@locks1, @locks2);
+ push @locks1, lock_factory1() for 1..2;
+ push @locks1, lock_factory2() for 1..2;
+ push @locks2, lock_factory1() for 1..2;
+ push @locks2, lock_factory2() for 1..2;
+
+ ok(1,1,"lock factory: locking all locks");
+ lock $locks1[0];
+ lock $locks1[1];
+ lock $locks1[2];
+ lock $locks1[3];
+ ok(2,1,"lock factory: locked all locks");
+ $tr = async {
+ ok(3,1,"lock factory: child: locking all locks");
+ lock $locks2[0];
+ lock $locks2[1];
+ lock $locks2[2];
+ lock $locks2[3];
+ ok(4,1,"lock factory: child: locked all locks");
+ };
+ $tr->join;
+
+ $Base += 4;
+}
+
+# test cond_signal()
+
+{
+ my $lock : shared;
+
+ sub foo {
+ lock($lock);
+ ok(1,1,"cond_signal: created first lock");
+ my $tr2 = threads->create(\&bar);
+ cond_wait($lock);
+ $tr2->join();
+ ok(5,1,"cond_signal: joined");
+ }
+
+ sub bar {
+ ok(2,1,"cond_signal: child before lock");
+ lock($lock);
+ ok(3,1,"cond_signal: child locked");
+ cond_signal($lock);
+ ok(4,1,"cond_signal: signalled");
+ }
+
+ my $tr = threads->create(\&foo);
+ $tr->join();
+
+ $Base += 5;
+
+ # ditto, but with lockrefs
+
+ my $lockref = \$lock;
+ sub foo2 {
+ lock($lockref);
+ ok(1,1,"cond_signal: ref: created first lock");
+ my $tr2 = threads->create(\&bar2);
+ cond_wait($lockref);
+ $tr2->join();
+ ok(5,1,"cond_signal: ref: joined");
+ }
+
+ sub bar2 {
+ ok(2,1,"cond_signal: ref: child before lock");
+ lock($lockref);
+ ok(3,1,"cond_signal: ref: child locked");
+ cond_signal($lockref);
+ ok(4,1,"cond_signal: ref: signalled");
+ }
+
+ $tr = threads->create(\&foo2);
+ $tr->join();
+
+ $Base += 5;
+
+}
+
+
+# test cond_broadcast()
+
+{
+ my $counter : shared = 0;
+
+ sub waiter {
+ lock($counter);
+ $counter++;
+ cond_wait($counter);
+ $counter += 10;
+ }
+
+ my $tr1 = threads->new(\&waiter);
+ my $tr2 = threads->new(\&waiter);
+ my $tr3 = threads->new(\&waiter);
+
+ while (1) {
+ lock $counter;
+ # make sure all 3 threads are waiting
+ next unless $counter == 3;
+ cond_broadcast $counter;
+ last;
+ }
+ $tr1->join(); $tr2->join(); $tr3->join();
+ ok(1, $counter == 33, "cond_broadcast: all three threads woken");
+ print "# counter=$counter\n";
+
+ $Base += 1;
+
+ # ditto with refs and shared()
+
+ my $counter2 = 0;
+ share($counter2);
+ my $r = \$counter2;
+
+ sub waiter2 {
+ lock($r);
+ $$r++;
+ cond_wait($r);
+ $$r += 10;
+ }
+
+ $tr1 = threads->new(\&waiter2);
+ $tr2 = threads->new(\&waiter2);
+ $tr3 = threads->new(\&waiter2);
+
+ while (1) {
+ lock($r);
+ # make sure all 3 threads are waiting
+ next unless $$r == 3;
+ cond_broadcast $r;
+ last;
+ }
+ $tr1->join(); $tr2->join(); $tr3->join();
+ ok(1, $$r == 33, "cond_broadcast: ref: all three threads woken");
+ print "# counter=$$r\n";
+
+ $Base += 1;
+
+}
+
+# test warnings;
+
+{
+ my $warncount = 0;
+ local $SIG{__WARN__} = sub { $warncount++ };
+
+ my $lock : shared;
+
cond_signal($lock);
- print "ok 4\n";
+ ok(1, $warncount == 1, 'get warning on cond_signal');
+ cond_broadcast($lock);
+ ok(2, $warncount == 2, 'get warning on cond_broadcast');
+ no warnings 'threads';
+ cond_signal($lock);
+ ok(3, $warncount == 2, 'get no warning on cond_signal');
+ cond_broadcast($lock);
+ ok(4, $warncount == 2, 'get no warning on cond_broadcast');
+
+ $Base += 4;
}
-my $tr = threads->create(\&foo);
-$tr->join();
+
use ExtUtils::testlib;
use strict;
-BEGIN { $| = 1; print "1..21\n" };
+BEGIN { $| = 1; print "1..24\n" };
use threads;
use threads::shared;
ok($thr6->join());
ok($thr7->join());
}
+
+# test that 'yield' is importable
+
+package Test1;
+
+use threads 'yield';
+yield;
+main::ok(1);
+
+package main;
+
+
+# test async
+
+{
+ my $th = async {return 1 };
+ ok($th);
+ ok($th->join());
+}
+
=head1 SYNOPSIS
-use threads;
+ use threads;
-sub start_thread {
- print "Thread started\n";
-}
-
-my $thread = threads->create("start_thread","argument");
-
-$thread->create(sub { print "I am a thread"},"argument");
-
-$thread->join();
+ sub start_thread {
+ print "Thread started\n";
+ }
-$thread->detach();
+ my $thread = threads->create("start_thread","argument");
+ my $thread2 = $thread->create(sub { print "I am a thread"},"argument");
+ my $thread3 = async { foreach (@files) { ... } };
-$thread = threads->self();
+ $thread->join();
+ $thread->detach();
-threads->tid();
-threads->self->tid();
+ $thread = threads->self();
-$thread->tid();
+ $thread->tid();
+ threads->tid();
+ threads->self->tid();
-threads->yield();
+ threads->yield();
-threads->list();
+ threads->list();
=head1 DESCRIPTION
variables are per default thread local. To use shared variables one
must use threads::shared.
-It is also important to note that you preferably enable threads by
+It is also important to note that you must enable threads by
doing C<use threads> as early as possible and that it is not possible
to enable threading inside an eval ""; In particular, if you are
intending to share variables with threads::shared, you must
This will create a new thread with the entry point function and give
it LIST as parameters. It will return the corresponding threads
-object.
+object. The new() method is an alias for create().
=item $thread->join
-This will wait for the corresponding thread to join. When it finishes
-join will return the return values of the entry point function. If a
-thread has been detached, an error will be thrown..
+This will wait for the corresponding thread to join. When the thread finishes,
+join() will return the return values of the entry point function. If the
+thread has been detached, an error will be thrown. If the program
+exits without all other threads having been either joined or detached,
+then a warning will be issued. (A program exits either because one of its
+threads explicitly calls exit(), or in the case of the main thread, reaches
+the end of the main program file.)
=item $thread->detach
-Will throw away the return value from the thread and make it
-non-joinable.
+Will make the thread unjoinable, and cause any eventual return value to be
+discarded.
=item threads->self
-This will return the object for the current thread.
+This will return the thread object for the current thread.
=item $thread->tid
-This will return the id of the thread. threads->tid() is a quick way
-to get current thread id if you don't have your thread handy.
+This will return the id of the thread. Thread IDs are integers, with the
+main thread in a program being 0. Currently Perl assigns a unique tid to
+every thread ever created in your program, assigning the first thread to
+be created a tid of 1, and increasing the tid by 1 for each new thread
+that's created.
+
+NB the class method C<< threads->tid() >> is a quick way to get the
+current thread id if you don't have your thread object handy.
=item threads->yield();
-This will tell the OS to let this thread yield CPU time to other threads.
-However this is highly depending on the underlying thread implementation.
+This is a suggestion to the OS to let this thread yield CPU time to other
+threads. What actually happens is highly dependent upon the underlying
+thread implementation.
You may do C<use threads qw(yield)> then use just a bare C<yield> in your
code.
C<async> creates a thread to execute the block immediately following
it. This block is treated as an anonymous sub, and so must have a
-semi-colon after the closing brace. Like C<threads->new>, C<async>
+semi-colon after the closing brace. Like C<< threads->new >>, C<async>
returns a thread object.
=back
=head1 BUGS / TODO
-The current implmentation of threads has been an attempt to get
+The current implementation of threads has been an attempt to get
a correct threading system working that could be built on,
and optimized, in newer versions of perl.
-Current the overhead of creating a thread is rather large,
+Currently the overhead of creating a thread is rather large,
also the cost of returning values can be large. These are areas
were there most likely will be work done to optimize what data
that needs to be cloned.
=for apidoc Am|void|StructCopy|type src|type dest|type
This is an architecture-independent macro to copy one structure to another.
-=cut
-*/
+=for apidoc Am|void|Poison|void* dest|int nitems|type
+
+Fill up memory with a pattern (byte 0xAB over and over again) that
+hopefully catches attempts to access uninitialized memory.
+
+=cut */
#ifndef lint
#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t))
+#define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
+
#else /* lint */
#define New(x,v,n,s) (v = Null(s *))
#define Move(s,d,n,t)
#define Copy(s,d,n,t)
#define Zero(d,n,t)
+#define Poison(d,n,t)
#define Safefree(d) (d) = (d)
#endif /* lint */
if ($cache && exists $cache{$cache_key} ) {
$wn = $cache{$cache_key};
} else {
- $wn = &runloop($n, ref( $code ) ? sub { undef } : '' );
+ $wn = &runloop($n, ref( $code ) ? sub { } : '' );
# Can't let our baseline have any iterations, or they get subtracted
# out of the result.
$wn->[5] = 0;
+5.95_01 Sat May 18 14:40:12 EDT 2002
+ - Fixed ExtUtils::testlib so it has a reasonable chance of working
+ under taint mode.
+
5.94_02 Fri May 17 17:16:04 EDT 2002
- Fixing Manifest.t test for relative @INC when core testing.
BEGIN {require 5.005_03;}
-$VERSION = "5.94_02";
+$VERSION = "5.95_01";
$Version_OK = "5.49"; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
-($Revision = substr(q$Revision: 1.51 $, 10)) =~ s/\s+$//;
+($Revision = substr(q$Revision: 1.53 $, 10)) =~ s/\s+$//;
require Exporter;
use Config;
$VERSION = '1.00';
*VERSION = \'1.01';
- ( $VERSION ) = '$Revision: 1.51 $ ' =~ /\$Revision:\s+([^\s]+)/;
+ ( $VERSION ) = '$Revision: 1.53 $ ' =~ /\$Revision:\s+([^\s]+)/;
$FOO::VERSION = '1.10';
*FOO::VERSION = \'1.11';
our $VERSION = 1.2.3; # new for perl5.6.0
-#!/usr/bin/perl -w
+#!/usr/bin/perl -Tw
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = '../lib';
}
else {
- unshift @INC, 't/lib';
+ # ./lib is there so t/lib can be seen even after we chdir.
+ unshift @INC, 't/lib', './lib';
}
}
chdir 't';
-use Test::More tests => 3;
+use Test::More tests => 4;
BEGIN {
# non-core tests will have blib in their path. We remove it
@blib_paths = grep { /blib/ } @INC;
is( @blib_paths, 2, 'ExtUtils::testlib added two @INC dirs!' );
+ok( !(grep !File::Spec->file_name_is_absolute($_), @blib_paths),
+ ' and theyre absolute');
package ExtUtils::testlib;
-$VERSION = 1.12_01;
+$VERSION = 1.13_01;
-# So the tests can chdir around and not break @INC.
+use Cwd;
use File::Spec;
-use lib map File::Spec->rel2abs($_), qw(blib/arch blib/lib);
+
+# So the tests can chdir around and not break @INC.
+# We use getcwd() because otherwise rel2abs will blow up under taint
+# mode pre-5.8
+use lib map File::Spec->rel2abs($_, getcwd()), qw(blib/arch blib/lib);
1;
__END__
open(POD, "<$$.pod") or die "$$.pod: $!";
open(IN, ">$$.in") or die "$$.in: $!";
while (<POD>) {
- s/[\r\n]+/\r/gs;
+ s/[\r\n]+/\r/g;
print IN $_;
}
close(POD);
open(POD, "<$$.pod") or die "$$.pod: $!";
open(IN, ">$$.in") or die "$$.in: $!";
while (<POD>) {
- s/[\r\n]+/\n/gs;
+ s/[\r\n]+/\n/g;
print IN $_;
}
close(POD);
open(POD, "<$$.pod") or die "$$.pod: $!";
open(IN, ">$$.in") or die "$$.in: $!";
while (<POD>) {
- s/[\r\n]+/\r\n/gs;
+ s/[\r\n]+/\r\n/g;
print IN $_;
}
close(POD);
use open ':encoding(iso-8859-7)';
use open IO => ':encoding(iso-8859-7)';
+The matching of encoding names is loose: case does not matter, and
+many encodings have several aliases. See L<Encode::Supported> for
+details and the list of supported locales.
+
+Note that C<:utf8> discipline must always be specified exactly like
+that, it is not subject to the loose matching of encoding names.
+
When open() is given an explicit list of layers they are appended to
the list declared using this pragma.
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file was created by warnings.pl
# Any changes made here will be lost.
#
use Carp ;
%Offsets = (
+
+ # Warnings Categories added in Perl 5.008
+
'all' => 0,
'closure' => 2,
'deprecated' => 4,
'reserved' => 74,
'semicolon' => 76,
'taint' => 78,
- 'uninitialized' => 80,
- 'unpack' => 82,
- 'untie' => 84,
- 'utf8' => 86,
- 'void' => 88,
- 'y2k' => 90,
+ 'threads' => 80,
+ 'uninitialized' => 82,
+ 'unpack' => 84,
+ 'untie' => 86,
+ 'utf8' => 88,
+ 'void' => 90,
+ 'y2k' => 92,
);
%Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
);
%DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 92 ;
+$LAST_BIT = 94 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
carp($message) ;
}
+
1;
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL16653"
+ ,"DEVEL16693"
,NULL
};
=for hackers
Found in file handy.h
+=item Poison
+
+Fill up memory with a pattern (byte 0xAB over and over again) that
+hopefully catches attempts to access uninitialized memory.
+
+ void Poison(void* dest, int nitems, type)
+
+=for hackers
+Found in file handy.h
+
=item Renew
The XSUB-writer's interface to the C C<realloc> function.
Note also the existence of C<sv_catpvf> and C<sv_vcatpvfn>, combining
concatenation with formatting.
+Sometimes instead of zeroing the allocated heap by using Newz() you
+should consider "poisoning" the data. This means writing a bit
+pattern into it that should be illegal as pointers (and floating point
+numbers), and also hopefully surprising enough as integers, so that
+any code attempting to use the data without forethought will break
+sooner rather than later. Poisoning can be done using the Poison()
+macro, which has similar arguments as Zero():
+
+ Poison(dst, n, t)
+
=head2 Character Class Tests
There are two types of character class tests that Perl implements: one
storage and retrieval of Perl data to and from files in a fast and
compact binary format. Because in effect Storable does serialisation
of Perl data structues, with it you can also clone deep, hierarchical
-datastructures. Storable was created by Raphael Manfredi but it is
-now maintained by the Perl development team. Storable has been
+datastructures. Storable was originally created by Raphael Manfredi,
+but it is now maintained by Abhijit Menon-Sen. Storable has been
enhanced to understand the two new hash features, Unicode keys and
restricted hashes. See L<Storable>.
=item *
caller() could cause core dumps in certain situations. Carp was sometimes
-affected by this problem.
+affected by this problem. In particular, caller() now returns a
+subroutine name of C<(unknown)> for subroutines that have been removed
+from the symbol table.
=item *
that it is simpler or backtracks less. (See L<perlfaq2> for information
on I<Mastering Regular Expressions>.)
+=item cond_broadcast() called on unlocked variable
+
+(W threads) Within a thread-enabled program, you tried to call
+cond_broadcast() on a variable which wasn't locked. The cond_broadcast()
+function is used to wake up another thread that is waiting in a
+cond_wait(). To ensure that the signal isn't sent before the other thread
+has a chance to enter the wait, it is usual for the signaling thread to
+first wait for a lock on variable. This lock attempt will only succeed
+after the other thread has entered cond_wait() and thus relinquished the
+lock.
+
+
+=item cond_signal() called on unlocked variable
+
+(W threads) Within a thread-enabled program, you tried to call
+cond_signal() on a variable which wasn't locked. The cond_signal()
+function is used to wake up another thread that is waiting in a
+cond_wait(). To ensure that the signal isn't sent before the other thread
+has a chance to enter the wait, it is usual for the signaling thread to
+first wait for a lock on variable. This lock attempt will only succeed
+after the other thread has entered cond_wait() and thus relinquished the
+lock.
+
=item connect() on closed socket %s
(W closed) You tried to do a connect on a closed socket. Did you forget
C<require> or C<use> statement, $evaltext contains the text of the
C<eval EXPR> statement. In particular, for an C<eval BLOCK> statement,
$filename is C<(eval)>, but $evaltext is undefined. (Note also that
-each C<use> statement creates a C<require> frame inside an C<eval EXPR>)
-frame. C<$hasargs> is true if a new instance of C<@_> was set up for the
-frame. C<$hints> and C<$bitmask> contain pragmatic hints that the caller
-was compiled with. The C<$hints> and C<$bitmask> values are subject to
-change between versions of Perl, and are not meant for external use.
+each C<use> statement creates a C<require> frame inside an C<eval EXPR>
+frame.) $subroutine may also be C<(unknown)> if this particular
+subroutine happens to have been deleted from the symbol table.
+C<$hasargs> is true if a new instance of C<@_> was set up for the frame.
+C<$hints> and C<$bitmask> contain pragmatic hints that the caller was
+compiled with. The C<$hints> and C<$bitmask> values are subject to change
+between versions of Perl, and are not meant for external use.
Furthermore, when called from within the DB package, caller returns more
detailed information: it sets the list variable C<@DB::args> to be the
Note: you can define up to 20 conversion shortcuts in the gdb
section.
+=item *
+
+If you see in a debugger a memory area mysteriously full of 0xabababab,
+you may be seeing the effect of the Poison() macro, see L<perlclib>.
+
=back
=head2 CONCLUSION
|
+- taint
|
+ +- threads
+ |
+- uninitialized
|
+- unpack
Get/set subroutine or variable attributes
+=item attrs
+
+Set/get attributes of a subroutine (deprecated)
+
=item autouse
Postpone load of modules until a function is used
=item charnames
-Define character names for C<\N{named}> string literal escapes.
+Define character names for C<\N{named}> string literal escapes
=item constant
=item encoding
-Pragma to control the conversion of legacy data into Unicode
+Allows you to write your script in non-ascii or non-utf8
=item fields
Set default disciplines for input and output
+=item ops
+
+Restrict unsafe operations when compiling
+
=item overload
Package for overloading perl operations
Predeclare sub names
+=item threads
+
+Perl extension allowing use of interpreter based threads from perl
+
=item utf8
Enable/disable UTF-8 (or UTF-EBCDIC) in source code
Split a package for autoloading
+=item B
+
+The Perl Compiler
+
+=item B::Asmdata
+
+Autogenerated data about Perl ops, used to generate bytecode
+
+=item B::Assembler
+
+Assemble Perl bytecode
+
+=item B::Bblock
+
+Walk basic blocks
+
+=item B::Bytecode
+
+Perl compiler's bytecode backend
+
+=item B::C
+
+Perl compiler's C backend
+
+=item B::CC
+
+Perl compiler's optimized C translation backend
+
+=item B::Concise
+
+Walk Perl syntax tree, printing concise info about ops
+
+=item B::Debug
+
+Walk Perl syntax tree, printing debug info about ops
+
+=item B::Deparse
+
+Perl compiler backend to produce perl code
+
+=item B::Disassembler
+
+Disassemble Perl bytecode
+
+=item B::Lint
+
+Perl lint
+
+=item B::Showlex
+
+Show lexical variables used in functions or files
+
+=item B::Stackobj
+
+Helper module for CC backend
+
+=item B::Stash
+
+Show what stashes are loaded
+
+=item B::Terse
+
+Walk Perl syntax tree, printing terse info about ops
+
+=item B::Xref
+
+Generates cross reference reports for Perl programs
+
=item Benchmark
Benchmark running times of Perl code
+=item ByteLoader
+
+Load byte compiled perl code
+
=item CGI
Simple Common Gateway Interface Class
Programmatic interface to the Perl debugging API (draft, subject to
+=item DB_File
+
+Perl5 access to Berkeley DB version 1.x
+
=item Devel::SelfStubber
Generate stubs for a SelfLoading module
Provides screen dump of Perl data.
+=item Encode
+
+Character encodings
+
=item English
Use nice English (or awk) names for ugly punctuation variables
Utilities to replace common UNIX commands in Makefiles etc.
+=item ExtUtils::Command::MM
+
+Commands for the MM's to use in Makefiles
+
=item ExtUtils::Constant
Generate XS code to import C header constants
Determine libraries to use and how to use them
+=item ExtUtils::MM
+
+OS adjusted ExtUtils::MakeMaker subclass
+
+=item ExtUtils::MM_Any
+
+Platform agnostic MM methods
+
=item ExtUtils::MM_BeOS
Methods to override UN*X behaviour in ExtUtils::MakeMaker
Methods to override UN*X behaviour in ExtUtils::MakeMaker
+=item ExtUtils::MM_DOS
+
+DOS specific subclass of ExtUtils::MM_Unix
+
+=item ExtUtils::MM_MacOS
+
+Methods to override UN*X behaviour in ExtUtils::MakeMaker
+
=item ExtUtils::MM_NW5
Methods to override UN*X behaviour in ExtUtils::MakeMaker
Methods to override UN*X behaviour in ExtUtils::MakeMaker
+=item ExtUtils::MM_UWIN
+
+U/WIN specific subclass of ExtUtils::MM_Unix
+
=item ExtUtils::MM_Unix
Methods used by ExtUtils::MakeMaker
Methods to override UN*X behaviour in ExtUtils::MakeMaker
+=item ExtUtils::MM_Win95
+
+Method to customize MakeMaker for Win9X
+
+=item ExtUtils::MY
+
+ExtUtils::MakeMaker subclass for customization
+
=item ExtUtils::MakeMaker
Create an extension Makefile
Replace functions with equivalents which succeed or die
+=item Fcntl
+
+Load the C Fcntl.h defines
+
=item File::Basename
Split a pathname into pieces
Tags and names for human languages
+=item IO
+
+Load various IO modules
+
=item IPC::Open2
Open a process for both reading and writing
=item Memoize
-Make your functions faster by trading space for time
+Make functions faster by trading space for time
=item Memoize::AnyDBM_File
Store Memoized data in Storable database
+=item NDBM_File
+
+Tied access to ndbm files
+
=item NEXT
Provide a pseudo-class NEXT that allows method redispatch
By-name interface to Perl's built-in getserv*() functions
+=item O
+
+Generic interface to Perl Compiler backends
+
+=item ODBM_File
+
+Tied access to odbm files
+
+=item Opcode
+
+Disable named opcodes when compiling perl code
+
+=item POSIX
+
+Perl interface to IEEE Std 1003.1
+
=item PerlIO
On demand loader for PerlIO layers and root of PerlIO::* name space
Test of various basic POD features in translators.
+=item SDBM_File
+
+Tied access to sdbm files
+
+=item Safe
+
+Compile and execute code in restricted compartments
+
=item Search::Dict
Search for key in dictionary file
Run shell commands transparently within perl
+=item Socket
+
+Load the C socket.h defines and structure manipulators
+
+=item Storable
+
+Persistence for Perl data structures
+
=item Switch
A switch statement for Perl
Manipulate threads in Perl
+=item Thread::Queue
+
+Thread-safe queues
+
+=item Thread::Semaphore
+
+Thread-safe semaphores
+
=item Tie::Array
Base class for tied arrays
=item Unicode::Collate
-Use UCA (Unicode Collation Algorithm)
+Unicode Collation Algorithm
=item Unicode::UCD
character classes via the new C<\p{}> (matches property) and C<\P{}>
(doesn't match property) constructs. For instance, C<\p{Lu}> matches any
character with the Unicode "Lu" (Letter, uppercase) property, while
-C<\p{M}> matches any character with a "M" (mark -- accents and such)
+C<\p{M}> matches any character with an "M" (mark -- accents and such)
property. Single letter properties may omit the brackets, so that can be
written C<\pM> also. Many predefined properties are available, such
as C<\p{Mirrored}> and C<\p{Tibetan}>.
U+0000..U+007F 00..7F
U+0080..U+07FF C2..DF 80..BF
- U+0800..U+0FFF E0 A0..BF 80..BFÂ Â
- U+1000..U+CFFF E1..EC 80..BF 80..BFÂ Â
- U+D000..U+D7FF ED 80..9F 80..BFÂ Â
+ U+0800..U+0FFF E0 A0..BF 80..BF
+ U+1000..U+CFFF E1..EC 80..BF 80..BF
+ U+D000..U+D7FF ED 80..9F 80..BF
U+D800..U+DFFF ******* ill-formed *******
- U+E000..U+FFFF EE..EF 80..BF 80..BFÂ Â
+ U+E000..U+FFFF EE..EF 80..BF 80..BF
U+10000..U+3FFFF F0 90..BF 80..BF 80..BF
U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF
U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
use them internally.)
UTF-16 is a 2 or 4 byte encoding. The Unicode code points
-0x0000..0xFFFF are stored in two 16-bit units, and the code points
-0x010000..0x10FFFF in two 16-bit units. The latter case is
+U+0000..U+FFFF are stored in a single 16-bit unit, and the code points
+U+10000..U+10FFFF in two 16-bit units. The latter case is
using I<surrogates>, the first 16-bit unit being the I<high
surrogate>, and the second being the I<low surrogate>.
-Surrogates are code points set aside to encode the 0x01000..0x10FFFF
+Surrogates are code points set aside to encode the U+10000..U+10FFFF
range of Unicode code points in pairs of 16-bit units. The I<high
-surrogates> are the range 0xD800..0xDBFF, and the I<low surrogates>
-are the range 0xDC00..0xDFFFF. The surrogate encoding is
+surrogates> are the range U+D800..U+DBFF, and the I<low surrogates>
+are the range U+DC00..U+DFFF. The surrogate encoding is
$hi = ($uni - 0x10000) / 0x400 + 0xD800;
$lo = ($uni - 0x10000) % 0x400 + 0xDC00;
is UTF-16, but you don't know which endianness? Byte Order Marks
(BOMs) are a solution to this. A special character has been reserved
in Unicode to function as a byte order marker: the character with the
-code point 0xFEFF is the BOM.
+code point U+FEFF is the BOM.
The trick is that if you read a BOM, you will know the byte order,
since if it was written on a big endian platform, you will read the
was writing in UTF-8, you will read the bytes 0xEF 0xBB 0xBF.)
The way this trick works is that the character with the code point
-0xFFFE is guaranteed not to be a valid Unicode character, so the
+U+FFFE is guaranteed not to be a valid Unicode character, so the
sequence of bytes 0xFF 0xFE is unambiguously "BOM, represented in
-little-endian format" and cannot be "0xFFFE, represented in big-endian
+little-endian format" and cannot be "U+FFFE, represented in big-endian
format".
=item *
UCS-2, UCS-4
Encodings defined by the ISO 10646 standard. UCS-2 is a 16-bit
-encoding. Unlike UTF-16, UCS-2 is not extensible beyond 0xFFFF,
+encoding. Unlike UTF-16, UCS-2 is not extensible beyond U+FFFF,
because it does not use surrogates. UCS-4 is a 32-bit encoding,
functionally identical to UTF-32.
desire (and to avoid the warning), open the stream with the desired
encoding. Some examples:
- open FH, ">:ucs2", "file"
- open FH, ">:utf8", "file";
- open FH, ">:Shift-JIS", "file";
+ open FH, ">:utf8", "file";
+
+ open FH, ">:encoding(ucs2)", "file";
+ open FH, ">:encoding(UTF-8)", "file";
+ open FH, ">:encoding(shift_jis)", "file";
and on already open streams use C<binmode()>:
- binmode(STDOUT, ":ucs2");
binmode(STDOUT, ":utf8");
- binmode(STDOUT, ":Shift-JIS");
-See documentation for the C<Encode> module for many supported encodings.
+ binmode(STDOUT, ":encoding(ucs2)");
+ binmode(STDOUT, ":encoding(UTF-8)");
+ binmode(STDOUT, ":encoding(shift_jis)");
+
+The matching of encoding names is loose: case does not matter, and
+many encodings have several aliases. Note that C<:utf8> discipline
+must always be specified exactly like that, it is not subject to the
+loose matching of encoding names.
+
+See L<PerlIO> for the C<:utf8> layer;
+L<PerlIO::encoding> and L<Encode::PerlIO> for the C<:encoding()> layer;
+L<Encode::Supported> for many encodings supported by the C<Encode> module.
Reading in a file that you know happens to be encoded in one of the
Unicode encodings does not magically turn the data into Unicode in
open(my $fh,'<:utf8', 'anything');
my $line_of_unicode = <$fh>;
- open(my $fh,'<:Big5', 'anything');
+ open(my $fh,'<:encoding(Big5)', 'anything');
my $line_of_unicode = <$fh>;
The I/O disciplines can also be specified more flexibly with
How Do I Display Unicode? How Do I Input Unicode?
-See http://www.hclrss.demon.co.uk/unicode/ and
+See http://www.alanwood.net/unicode/ and
http://www.cl.cam.ac.uk/~mgk25/unicode.html
=item
shows better the division of Unicode into blocks of 256 characters.
Hexadecimal is also simply shorter than decimal. You can use decimal
notation, too, but learning to use hexadecimal just makes life easier
-with the Unicode standard.
+with the Unicode standard. The "U+HHHH" notation uses hexadecimal,
+for example.
The C<0x> prefix means a hexadecimal number, the digits are 0-9 I<and>
a-f (or A-F, case doesn't matter). Each hexadecimal digit represents
Unicode and Multilingual Support in HTML, Fonts, Web Browsers and Other Applications
- http://www.hclrss.demon.co.uk/unicode/
+ http://www.alanwood.net/unicode/
=item *
perl "-V:installprivlib"
-Note that some of the files have been renamed from the Unicode
-standard since the Perl installation tries to live by the "8.3"
-filenaming restrictions. The renamings are shown in the
-accompanying F<rename> file.
-
You can explore various information from the Unicode data files using
the C<Unicode::UCD> module.
si->si_cxmax = cxitems - 1;
si->si_cxix = -1;
si->si_type = PERLSI_UNDEF;
- /* Needs to be Newz() because PUSHSUBST() in pp_subst()
- * might otherwise read uninitialized heap. */
- Newz(56, si->si_cxstack, cxitems, PERL_CONTEXT);
+ New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
+ /* Without any kind of initialising PUSHSUBST()
+ * in pp_subst() will read uninitialised heap. */
+ Poison(si->si_cxstack, cxitems, PERL_CONTEXT);
return si;
}
I32
Perl_cxinc(pTHX)
{
+ IV old_max = cxstack_max;
cxstack_max = GROW(cxstack_max);
Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
+ /* Without any kind of initialising deep enough recursion
+ * will end up reading uninitialised PERL_CONTEXTs. */
+ Poison(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
return cxstack_ix + 1;
}
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
# test recursive functions.
#
-print "1..25\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require "test.pl";
+ plan(tests => 26);
+}
+
+use strict;
-sub gcd ($$) {
+sub gcd {
return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]);
return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]);
$_[0];
}
-sub factorial ($) {
+sub factorial {
$_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1);
}
-sub fibonacci ($) {
+sub fibonacci {
$_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1);
}
# For example ackermann(4,1) will take quite a long time.
# It will simply eat away your memory. Trust me.
-sub ackermann ($$) {
+sub ackermann {
return $_[1] + 1 if ($_[0] == 0);
return ackermann($_[0] - 1, 1) if ($_[1] == 0);
ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1));
# Highly recursive, highly boring.
-sub takeuchi ($$$) {
+sub takeuchi {
$_[1] < $_[0] ?
takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]),
takeuchi($_[1] - 1, $_[2], $_[0]),
: $_[2];
}
-print 'not ' unless (($d = gcd(1147, 1271)) == 31);
-print "ok 1\n";
-print "# gcd(1147, 1271) = $d\n";
-
-print 'not ' unless (($d = gcd(1908, 2016)) == 36);
-print "ok 2\n";
-print "# gcd(1908, 2016) = $d\n";
+is(gcd(1147, 1271), 31, "gcd(1147, 1271) == 31");
-print 'not ' unless (($f = factorial(10)) == 3628800);
-print "ok 3\n";
-print "# factorial(10) = $f\n";
+is(gcd(1908, 2016), 36, "gcd(1908, 2016) == 36");
-print 'not ' unless (($f = factorial(factorial(3))) == 720);
-print "ok 4\n";
-print "# factorial(factorial(3)) = $f\n";
+is(factorial(10), 3628800, "factorial(10) == 3628800");
-print 'not ' unless (($f = fibonacci(10)) == 89);
-print "ok 5\n";
-print "# fibonacci(10) = $f\n";
+is(factorial(factorial(3)), 720, "factorial(factorial(3)) == 720");
-print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711);
-print "ok 6\n";
-print "# fibonacci(fibonacci(7)) = $f\n";
+is(fibonacci(10), 89, "fibonacci(10) == 89");
-$i = 7;
+is(fibonacci(fibonacci(7)), 17711, "fibonacci(fibonacci(7)) == 17711");
-@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61);
+my @ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61);
-for $x (0..3) {
- for $y (0..3) {
- $a = ackermann($x, $y);
- print 'not ' unless ($a == shift(@ack));
- print "ok ", $i++, "\n";
- print "# ackermann($x, $y) = $a\n";
+for my $x (0..3) {
+ for my $y (0..3) {
+ my $a = ackermann($x, $y);
+ is($a, shift(@ack), "ackermann($x, $y) == $a");
}
}
-($x, $y, $z) = (18, 12, 6);
+my ($x, $y, $z) = (18, 12, 6);
-print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1);
-print "ok ", $i++, "\n";
-print "# takeuchi($x, $y, $z) = $t\n";
+is(takeuchi($x, $y, $z), $z + 1, "takeuchi($x, $y, $z) == $z + 1");
{
sub get_first1 {
}
sub get_list1 {
- return [24] unless $_[0];
+ return [curr_test] unless $_[0];
my $u = get_first1(0);
[$u];
}
my $x = get_first1(1);
- print "ok $x\n";
+ ok($x, "premature FREETMPS (change 5699)");
}
{
}
sub get_list2 {
- return [25] unless $_[0];
+ return [curr_test] unless $_[0];
my $u = get_first2(0);
return [$u];
}
my $x = get_first2(1);
- print "ok $x\n";
+ ok($x, "premature FREETMPS (change 5699)");
+}
+
+{
+ local $^W = 0; # We do not need recursion depth warning.
+
+ sub sillysum {
+ return $_[0] + ($_[0] > 0 ? sillysum($_[0] - 1) : 0);
+ }
+
+ is(sillysum(1000), 1000*1001/2, "recursive sum of 1..1000");
}
-$i = 26;
+
+
+
SvCUR_set(sv, sizeof(struct perl_thread));
thr = (Thread) SvPVX(sv);
#ifdef DEBUGGING
- memset(thr, 0xab, sizeof(struct perl_thread));
+ Poison(thr, 1, struct perl_thread);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
+
+/* Warnings Categories added in Perl 5.008 */
+
#define WARN_ALL 0
#define WARN_CLOSURE 1
#define WARN_DEPRECATED 2
#define WARN_RESERVED 37
#define WARN_SEMICOLON 38
#define WARN_TAINT 39
-#define WARN_UNINITIALIZED 40
-#define WARN_UNPACK 41
-#define WARN_UNTIE 42
-#define WARN_UTF8 43
-#define WARN_VOID 44
-#define WARN_Y2K 45
+#define WARN_THREADS 40
+#define WARN_UNINITIALIZED 41
+#define WARN_UNPACK 42
+#define WARN_UNTIE 43
+#define WARN_UTF8 44
+#define WARN_VOID 45
+#define WARN_Y2K 46
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
my $tree = {
-'all' => {
- 'io' => { 'pipe' => DEFAULT_OFF,
- 'unopened' => DEFAULT_OFF,
- 'closed' => DEFAULT_OFF,
- 'newline' => DEFAULT_OFF,
- 'exec' => DEFAULT_OFF,
- 'layer' => DEFAULT_OFF,
- },
- 'syntax' => { 'ambiguous' => DEFAULT_OFF,
- 'semicolon' => DEFAULT_OFF,
- 'precedence' => DEFAULT_OFF,
- 'bareword' => DEFAULT_OFF,
- 'reserved' => DEFAULT_OFF,
- 'digit' => DEFAULT_OFF,
- 'parenthesis' => DEFAULT_OFF,
- 'printf' => DEFAULT_OFF,
- 'prototype' => DEFAULT_OFF,
- 'qw' => DEFAULT_OFF,
- },
- 'severe' => { 'inplace' => DEFAULT_ON,
- 'internal' => DEFAULT_ON,
- 'debugging' => DEFAULT_ON,
- 'malloc' => DEFAULT_ON,
- },
- 'deprecated' => DEFAULT_OFF,
- 'void' => DEFAULT_OFF,
- 'recursion' => DEFAULT_OFF,
- 'redefine' => DEFAULT_OFF,
- 'numeric' => DEFAULT_OFF,
- 'uninitialized' => DEFAULT_OFF,
- 'once' => DEFAULT_OFF,
- 'misc' => DEFAULT_OFF,
- 'regexp' => DEFAULT_OFF,
- 'glob' => DEFAULT_OFF,
- 'y2k' => DEFAULT_OFF,
- 'untie' => DEFAULT_OFF,
- 'substr' => DEFAULT_OFF,
- 'taint' => DEFAULT_OFF,
- 'signal' => DEFAULT_OFF,
- 'closure' => DEFAULT_OFF,
- 'overflow' => DEFAULT_OFF,
- 'portable' => DEFAULT_OFF,
- 'utf8' => DEFAULT_OFF,
- 'exiting' => DEFAULT_OFF,
- 'pack' => DEFAULT_OFF,
- 'unpack' => DEFAULT_OFF,
- #'default' => DEFAULT_ON,
- }
+'all' => [ 5.008, {
+ 'io' => [ 5.008, {
+ 'pipe' => [ 5.008, DEFAULT_OFF],
+ 'unopened' => [ 5.008, DEFAULT_OFF],
+ 'closed' => [ 5.008, DEFAULT_OFF],
+ 'newline' => [ 5.008, DEFAULT_OFF],
+ 'exec' => [ 5.008, DEFAULT_OFF],
+ 'layer' => [ 5.008, DEFAULT_OFF],
+ }],
+ 'syntax' => [ 5.008, {
+ 'ambiguous' => [ 5.008, DEFAULT_OFF],
+ 'semicolon' => [ 5.008, DEFAULT_OFF],
+ 'precedence' => [ 5.008, DEFAULT_OFF],
+ 'bareword' => [ 5.008, DEFAULT_OFF],
+ 'reserved' => [ 5.008, DEFAULT_OFF],
+ 'digit' => [ 5.008, DEFAULT_OFF],
+ 'parenthesis' => [ 5.008, DEFAULT_OFF],
+ 'printf' => [ 5.008, DEFAULT_OFF],
+ 'prototype' => [ 5.008, DEFAULT_OFF],
+ 'qw' => [ 5.008, DEFAULT_OFF],
+ }],
+ 'severe' => [ 5.008, {
+ 'inplace' => [ 5.008, DEFAULT_ON],
+ 'internal' => [ 5.008, DEFAULT_ON],
+ 'debugging' => [ 5.008, DEFAULT_ON],
+ 'malloc' => [ 5.008, DEFAULT_ON],
+ }],
+ 'deprecated' => [ 5.008, DEFAULT_OFF],
+ 'void' => [ 5.008, DEFAULT_OFF],
+ 'recursion' => [ 5.008, DEFAULT_OFF],
+ 'redefine' => [ 5.008, DEFAULT_OFF],
+ 'numeric' => [ 5.008, DEFAULT_OFF],
+ 'uninitialized' => [ 5.008, DEFAULT_OFF],
+ 'once' => [ 5.008, DEFAULT_OFF],
+ 'misc' => [ 5.008, DEFAULT_OFF],
+ 'regexp' => [ 5.008, DEFAULT_OFF],
+ 'glob' => [ 5.008, DEFAULT_OFF],
+ 'y2k' => [ 5.008, DEFAULT_OFF],
+ 'untie' => [ 5.008, DEFAULT_OFF],
+ 'substr' => [ 5.008, DEFAULT_OFF],
+ 'taint' => [ 5.008, DEFAULT_OFF],
+ 'signal' => [ 5.008, DEFAULT_OFF],
+ 'closure' => [ 5.008, DEFAULT_OFF],
+ 'overflow' => [ 5.008, DEFAULT_OFF],
+ 'portable' => [ 5.008, DEFAULT_OFF],
+ 'utf8' => [ 5.008, DEFAULT_OFF],
+ 'exiting' => [ 5.008, DEFAULT_OFF],
+ 'pack' => [ 5.008, DEFAULT_OFF],
+ 'unpack' => [ 5.008, DEFAULT_OFF],
+ 'threads' => [ 5.008, DEFAULT_OFF],
+ #'default' => [ 5.008, DEFAULT_ON ],
+ }],
} ;
-
###########################################################################
sub tab {
my($l, $t) = @_;
my %list ;
my %Value ;
+my %ValueToName ;
+my %NameToValue ;
my $index ;
+my %v_list = () ;
+
+sub valueWalk
+{
+ my $tre = shift ;
+ my @list = () ;
+ my ($k, $v) ;
+
+ foreach $k (sort keys %$tre) {
+ $v = $tre->{$k};
+ die "duplicate key $k\n" if defined $list{$k} ;
+ die "Value associated with key '$k' is not an ARRAY reference"
+ if !ref $v || ref $v ne 'ARRAY' ;
+
+ my ($ver, $rest) = @{ $v } ;
+ push @{ $v_list{$ver} }, $k;
+
+ if (ref $rest)
+ { valueWalk ($rest) }
+
+ }
+
+}
+
+sub orderValues
+{
+ my $index = 0;
+ foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
+ foreach my $name (@{ $v_list{$ver} } ) {
+ $ValueToName{ $index } = [ uc $name, $ver ] ;
+ $NameToValue{ uc $name } = $index ++ ;
+ }
+ }
+
+ return $index ;
+}
+
+###########################################################################
+
sub walk
{
my $tre = shift ;
foreach $k (sort keys %$tre) {
$v = $tre->{$k};
die "duplicate key $k\n" if defined $list{$k} ;
- $Value{$index} = uc $k ;
- push @{ $list{$k} }, $index ++ ;
- if (ref $v)
- { push (@{ $list{$k} }, walk ($v)) }
+ #$Value{$index} = uc $k ;
+ die "Can't find key '$k'"
+ if ! defined $NameToValue{uc $k} ;
+ push @{ $list{$k} }, $NameToValue{uc $k} ;
+ die "Value associated with key '$k' is not an ARRAY reference"
+ if !ref $v || ref $v ne 'ARRAY' ;
+
+ my ($ver, $rest) = @{ $v } ;
+ if (ref $rest)
+ { push (@{ $list{$k} }, walk ($rest)) }
+
push @list, @{ $list{$k} } ;
}
{
my $tre = shift ;
my $prefix = shift ;
- my $indent = shift ;
my ($k, $v) ;
my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
+ my @keys = sort keys %$tre ;
- $prefix .= " " x $indent ;
- foreach $k (sort keys %$tre) {
+ while ($k = shift @keys) {
$v = $tre->{$k};
- print $prefix . "|\n" ;
- print $prefix . "+- $k" ;
- if (ref $v)
+ die "Value associated with key '$k' is not an ARRAY reference"
+ if !ref $v || ref $v ne 'ARRAY' ;
+
+ my $offset ;
+ if ($tre ne $tree) {
+ print $prefix . "|\n" ;
+ print $prefix . "+- $k" ;
+ $offset = ' ' x ($max + 4) ;
+ }
+ else {
+ print $prefix . "$k" ;
+ $offset = ' ' x ($max + 1) ;
+ }
+
+ my ($ver, $rest) = @{ $v } ;
+ if (ref $rest)
{
- print " " . "-" x ($max - length $k ) . "+\n" ;
- printTree ($v, $prefix . "|" , $max + $indent - 1)
+ my $bar = @keys ? "|" : " ";
+ print " -" . "-" x ($max - length $k ) . "+\n" ;
+ printTree ($rest, $prefix . $bar . $offset )
}
else
{ print "\n" }
if (@ARGV && $ARGV[0] eq "tree")
{
- #print " all -+\n" ;
- printTree($tree, " ", 4) ;
+ printTree($tree, " ") ;
exit ;
}
$index = $offset ;
#@{ $list{"all"} } = walk ($tree) ;
-walk ($tree) ;
+valueWalk ($tree) ;
+my $index = orderValues();
die <<EOM if $index > 255 ;
Too many warnings categories -- max is 255
rewrite packWARN* & unpackWARN* macros
EOM
+walk ($tree) ;
+
$index *= 2 ;
my $warn_size = int($index / 8) + ($index % 8 != 0) ;
my $k ;
-foreach $k (sort { $a <=> $b } keys %Value) {
- print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
+my $last_ver = 0;
+foreach $k (sort { $a <=> $b } keys %ValueToName) {
+ my ($name, $version) = @{ $ValueToName{$k} };
+ print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
+ if $last_ver != $version ;
+ print WARN tab(5, "#define WARN_$name"), "$k\n" ;
+ $last_ver = $version ;
}
print WARN "\n" ;
#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
-#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
-
+$last_ver = 0;
print PM "%Offsets = (\n" ;
-foreach my $k (sort { $a <=> $b } keys %Value) {
- my $v = lc $Value{$k} ;
+foreach my $k (sort { $a <=> $b } keys %ValueToName) {
+ my ($name, $version) = @{ $ValueToName{$k} };
+ $name = lc $name;
$k *= 2 ;
- print PM tab(4, " '$v'"), "=> $k,\n" ;
+ if ( $last_ver != $version ) {
+ print PM "\n";
+ print PM tab(4, " # Warnings Categories added in Perl $version");
+ print PM "\n\n";
+ }
+ print PM tab(4, " '$name'"), "=> $k,\n" ;
+ $last_ver = $version;
}
print PM " );\n\n" ;
__END__
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file was created by warnings.pl
# Any changes made here will be lost.
#
carp($message) ;
}
+
1;
projects / p5sagit/p5-mst-13.2.git / commitdiff