cvs commit: ponie/perl/lib/ExtUtils/t Constant.t
[email protected] (Nicholas Clark) 19 Apr 2005 17:05:47 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 05/04/19 10:05:47
Modified: perl/ext/ByteLoader ByteLoader.pm byterun.c
perl/ext/Data/Dumper Dumper.pm Dumper.xs
perl/ext/Devel/Peek Peek.pm Peek.xs
perl/ext/DynaLoader dl_dyld.xs
perl/ext/Encode Encode.pm Encode.xs
perl/ext/List/Util/lib/List Util.pm
perl/ext/POSIX POSIX.pm POSIX.xs
perl/ext/PerlIO/encoding encoding.pm encoding.xs
perl/ext/PerlIO/scalar scalar.pm scalar.xs
perl/ext/Storable Storable.pm Storable.xs
perl/ext/threads threads.pm
perl/ext/threads/shared shared.pm shared.xs
perl/lib/ExtUtils/t Constant.t
Log:
Patches 24239 24240 24241 24243 24244 24245 24246 24248 24249
from blead (*_set macros)
Plus some fixups
Revision Changes Path
1.2 +2 -2 ponie/perl/ext/ByteLoader/ByteLoader.pm
Index: ByteLoader.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/ByteLoader/ByteLoader.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ByteLoader.pm 9 Sep 2003 11:58:59 -0000 1.1
+++ ByteLoader.pm 19 Apr 2005 17:05:45 -0000 1.2
@@ -2,7 +2,7 @@
use XSLoader ();
-our $VERSION = '0.05';
+our $VERSION = '0.06';
XSLoader::load 'ByteLoader', $VERSION;
@@ -15,7 +15,7 @@
=head1 SYNOPSIS
- use ByteLoader 0.04;
+ use ByteLoader 0.06;
<byte code>
or just
1.3 +5 -5 ponie/perl/ext/ByteLoader/byterun.c
Index: byterun.c
===================================================================
RCS file: /cvs/public/ponie/perl/ext/ByteLoader/byterun.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- byterun.c 10 Apr 2005 04:17:50 -0000 1.2
+++ byterun.c 19 Apr 2005 17:05:45 -0000 1.3
@@ -216,7 +216,7 @@
{
svindex arg;
BGET_svindex(arg);
- SvRV(bstate->bs_sv) = arg;
+ SvRV_set(bstate->bs_sv, arg);
break;
}
case INSN_XPV: /* 22 */
@@ -224,25 +224,25 @@
BSET_xpv(bstate->bs_sv);
break;
}
- case INSN_XPV_CUR: /* 23 */
+ case INSN_XPV_CUR: /* 23 */
{
STRLEN arg;
BGET_PADOFFSET(arg);
- SvCUR(bstate->bs_sv) = arg;
+ SvCUR_set(bstate->bs_sv, arg);
break;
}
case INSN_XPV_LEN: /* 24 */
{
STRLEN arg;
BGET_PADOFFSET(arg);
- SvLEN(bstate->bs_sv) = arg;
+ SvLEN_set(bstate->bs_sv, arg);
break;
}
case INSN_XIV: /* 25 */
{
IV arg;
BGET_IV(arg);
- SvIVX(bstate->bs_sv) = arg;
+ SvIV_set(bstate->bs_sv, arg);
break;
}
case INSN_XNV: /* 26 */
1.2 +46 -28 ponie/perl/ext/Data/Dumper/Dumper.pm
Index: Dumper.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Data/Dumper/Dumper.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Dumper.pm 9 Sep 2003 11:58:59 -0000 1.1
+++ Dumper.pm 19 Apr 2005 17:05:45 -0000 1.2
@@ -9,41 +9,50 @@
package Data::Dumper;
-$VERSION = '2.121';
+$VERSION = '2.121_05';
#$| = 1;
use 5.006_001;
require Exporter;
-use XSLoader ();
require overload;
use Carp;
-@ISA = qw(Exporter);
-@EXPORT = qw(Dumper);
-@EXPORT_OK = qw(DumperX);
+BEGIN {
+ @ISA = qw(Exporter);
+ @EXPORT = qw(Dumper);
+ @EXPORT_OK = qw(DumperX);
+
+ # if run under miniperl, or otherwise lacking dynamic loading,
+ # XSLoader should be attempted to load, or the pure perl flag
+ # toggled on load failure.
+ eval {
+ require XSLoader;
+ };
+ $Useperl = 1 if $@;
+}
-XSLoader::load 'Data::Dumper';
+XSLoader::load( 'Data::Dumper' ) unless $Useperl;
# module vars and their defaults
-$Indent = 2 unless defined $Indent;
-$Purity = 0 unless defined $Purity;
-$Pad = "" unless defined $Pad;
-$Varname = "VAR" unless defined $Varname;
-$Useqq = 0 unless defined $Useqq;
-$Terse = 0 unless defined $Terse;
-$Freezer = "" unless defined $Freezer;
-$Toaster = "" unless defined $Toaster;
-$Deepcopy = 0 unless defined $Deepcopy;
-$Quotekeys = 1 unless defined $Quotekeys;
-$Bless = "bless" unless defined $Bless;
-#$Expdepth = 0 unless defined $Expdepth;
-$Maxdepth = 0 unless defined $Maxdepth;
-$Pair = ' => ' unless defined $Pair;
-$Useperl = 0 unless defined $Useperl;
-$Sortkeys = 0 unless defined $Sortkeys;
-$Deparse = 0 unless defined $Deparse;
+$Indent = 2 unless defined $Indent;
+$Purity = 0 unless defined $Purity;
+$Pad = "" unless defined $Pad;
+$Varname = "VAR" unless defined $Varname;
+$Useqq = 0 unless defined $Useqq;
+$Terse = 0 unless defined $Terse;
+$Freezer = "" unless defined $Freezer;
+$Toaster = "" unless defined $Toaster;
+$Deepcopy = 0 unless defined $Deepcopy;
+$Quotekeys = 1 unless defined $Quotekeys;
+$Bless = "bless" unless defined $Bless;
+#$Expdepth = 0 unless defined $Expdepth;
+$Maxdepth = 0 unless defined $Maxdepth;
+$Pair = ' => ' unless defined $Pair;
+$Useperl = 0 unless defined $Useperl;
+$Sortkeys = 0 unless defined $Sortkeys;
+$Deparse = 0 unless defined $Deparse;
#
# expects an arrayref of values to be dumped.
@@ -231,9 +240,13 @@
if ($type) {
- # prep it, if it looks like an object
- if (my $freezer = $s->{freezer}) {
- $val->$freezer() if UNIVERSAL::can($val, $freezer);
+ # Call the freezer method if it's specified and the object has the
+ # method. Trap errors and warn() instead of die()ing, like the XS
+ # implementation.
+ my $freezer = $s->{freezer};
+ if ($freezer and UNIVERSAL::can($val, $freezer)) {
+ eval { $val->$freezer() };
+ warn "WARNING(Freezer method call failed): $@" if $@;
}
($realpack, $realtype, $id) =
@@ -381,7 +394,7 @@
if ($s->{deparse}) {
require B::Deparse;
my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
- $pad = $s->{sep} . $s->{pad} . $s->{xpad} . $s->{apad} . ' ';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
$sub =~ s/\n/$pad/gse;
$out .= $sub;
} else {
@@ -703,7 +716,8 @@
nested references to C<$VAR>I<n> will be undefined, since a recursive
structure cannot be constructed using one Perl statement. You should set the
C<Purity> flag to 1 to get additional statements that will correctly fill in
-these references.
+these references. Moreover, if C<eval>ed when strictures are in effect,
+you need to ensure that any variables it accesses are previously declared.
In the extended usage form, the references to be dumped can be given
user-specified names. If a name begins with a C<*>, the output will
@@ -886,6 +900,10 @@
only perl data types after the method has been called. Defaults to an empty
string.
+If an object does not support the method specified (determined using
+UNIVERSAL::can()) then the call will be skipped. If the method dies a
+warning will be generated.
+
=item *
$Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>)
1.2 +8 -8 ponie/perl/ext/Data/Dumper/Dumper.xs
Index: Dumper.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Data/Dumper/Dumper.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Dumper.xs 9 Sep 2003 11:59:00 -0000 1.1
+++ Dumper.xs 19 Apr 2005 17:05:45 -0000 1.2
@@ -215,7 +215,7 @@
SvGROW(sv, len*n + SvCUR(sv) + 1);
if (len == 1) {
char *start = SvPVX(sv) + SvCUR(sv);
- SvCUR(sv) += n;
+ SvCUR_set(sv, SvCUR(sv) + n);
start[n] = '\0';
while (n > 0)
start[--n] = str[0];
@@ -260,20 +260,20 @@
mg_get(val);
if (SvROK(val)) {
+ /* If a freeze method is provided and the object has it, call
+ it. Warn on errors. */
if (SvOBJECT(SvRV(val)) && freezer &&
- SvPOK(freezer) && SvCUR(freezer))
+ SvPOK(freezer) && SvCUR(freezer) &&
+ gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX(freezer),
+ SvCUR(freezer), -1) != NULL)
{
dSP; ENTER; SAVETMPS; PUSHMARK(sp);
XPUSHs(val); PUTBACK;
- i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
+ i = perl_call_method(SvPVX(freezer), G_EVAL|G_VOID);
SPAGAIN;
if (SvTRUE(ERRSV))
warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
- else if (i)
- val = newSVsv(POPs);
PUTBACK; FREETMPS; LEAVE;
- if (i)
- (void)sv_2mortal(val);
}
ival = SvRV(val);
@@ -855,7 +855,7 @@
av_push(postav, postentry);
e = newRV_inc(e);
- SvCUR(newapad) = 0;
+ SvCUR_set(newapad, 0);
if (indent >= 2)
(void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
1.2 +32 -20 ponie/perl/ext/Devel/Peek/Peek.pm
Index: Peek.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Devel/Peek/Peek.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Peek.pm 9 Sep 2003 11:59:00 -0000 1.1
+++ Peek.pm 19 Apr 2005 17:05:45 -0000 1.2
@@ -3,7 +3,7 @@
package Devel::Peek;
-$VERSION = '1.01';
+$VERSION = '1.03';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -391,29 +391,41 @@
The output:
- SV = RV(0xf041c)
- REFCNT = 1
- FLAGS = (ROK)
- RV = 0xb2850
- SV = PVHV(0xbd448)
- REFCNT = 1
- FLAGS = ()
- NV = 0
- ARRAY = 0xbd748
- KEYS = 1
- FILL = 1
- MAX = 7
- RITER = -1
- EITER = 0x0
- Elt "hello" => 0xbaaf0
- SV = IV(0xbe860)
- REFCNT = 1
- FLAGS = (IOK,pIOK)
- IV = 42
+ SV = RV(0x8177858) at 0x816a618
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0x814fc10
+ SV = PVHV(0x8167768) at 0x814fc10
+ REFCNT = 1
+ FLAGS = (SHAREKEYS)
+ IV = 1
+ NV = 0
+ ARRAY = 0x816c5b8 (0:7, 1:1)
+ hash quality = 100.0%
+ KEYS = 1
+ FILL = 1
+ MAX = 7
+ RITER = -1
+ EITER = 0x0
+ Elt "hello" HASH = 0xc8fd181b
+ SV = IV(0x816c030) at 0x814fcf4
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 42
This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a
hash. Fields RITER and EITER are used by C<L<each>>.
+The "quality" of a hash is defined as the total number of comparisons needed
+to access every element once, relative to the expected number needed for a
+random hash. The value can go over 100%.
+
+The total number of comparisons is equal to the sum of the squares of the
+number of entries in each bucket. For a random hash of C<<n>> keys into
+C<<k>> buckets, the expected value is:
+
+ n + n(n-1)/2k
+
=head2 Dumping a large array or hash
The C<Dump()> function, by default, dumps up to 4 elements from a
1.3 +1 -1 ponie/perl/ext/Devel/Peek/Peek.xs
Index: Peek.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Devel/Peek/Peek.xs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Peek.xs 19 Jun 2004 11:44:33 -0000 1.2
+++ Peek.xs 19 Apr 2005 17:05:45 -0000 1.3
@@ -245,7 +245,7 @@
if (!SvOK(*svp)) {
av = newAV();
(void)SvUPGRADE(*svp, SVt_RV);
- SvRV(*svp) = (SV*)av;
+ SvRV_set(*svp, (SV*)av);
SvROK_on(*svp);
} else
av = (AV*)SvRV(*svp);
1.2 +2 -3 ponie/perl/ext/DynaLoader/dl_dyld.xs
Index: dl_dyld.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/DynaLoader/dl_dyld.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- dl_dyld.xs 9 Sep 2003 11:59:01 -0000 1.1
+++ dl_dyld.xs 19 Apr 2005 17:05:45 -0000 1.2
@@ -98,8 +98,7 @@
path, number, type);
break;
}
- safefree(dl_last_error);
- dl_last_error = savepv(error);
+ sv_setpv(MY_CXT.x_dl_last_error, error);
}
static char *dlopen(char *path, int mode /* mode is ignored */)
@@ -113,7 +112,7 @@
TranslateError(path, OFImage, dyld_result);
else
{
- // NSLinkModule will cause the run to abort on any link error's
+ // NSLinkModule will cause the run to abort on any link errors
// not very friendly but the error recovery functionality is limited.
handle = NSLinkModule(ofile, path, TRUE);
NSDestroyObjectFileImage(ofile);
1.2 +54 -41 ponie/perl/ext/Encode/Encode.pm
Index: Encode.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Encode/Encode.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Encode.pm 9 Sep 2003 11:59:01 -0000 1.1
+++ Encode.pm 19 Apr 2005 17:05:45 -0000 1.2
@@ -3,7 +3,8 @@
#
package Encode;
use strict;
-our $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+# our $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = '2.0902_01';
sub DEBUG () { 0 }
use XSLoader ();
XSLoader::load(__PACKAGE__, $VERSION);
@@ -140,6 +141,7 @@
{
my ($name, $string, $check) = @_;
return undef unless defined $string;
+ $string .= '' if ref $string; # stringify;
$check ||=0;
my $enc = find_encoding($name);
unless(defined $enc){
@@ -155,6 +157,7 @@
{
my ($name,$octets,$check) = @_;
return undef unless defined $octets;
+ $octets .= '' if ref $octets;
$check ||=0;
my $enc = find_encoding($name);
unless(defined $enc){
@@ -195,11 +198,15 @@
return $str;
}
-sub decode_utf8($)
+sub decode_utf8($;$)
{
- my ($str) = @_;
- return undef unless utf8::decode($str);
- return $str;
+ my ($str, $check) = @_;
+ if ($check){
+ return decode("utf8", $str, $check);
+ }else{
+ return undef unless utf8::decode($str);
+ return $str;
+ }
}
predefine_encodings(1);
@@ -395,9 +402,7 @@
the result is always off, even when it contains completely valid utf8
string. See L</"The UTF-8 flag"> below.
-encode($valid_encoding, undef) is harmless but warns you for
-C<Use of uninitialized value in subroutine entry>.
-encode($valid_encoding, '') is harmless and warnless.
+If the $string is C<undef> or a reference then C<undef> is returned.
=item $string = decode(ENCODING, $octets [, CHECK])
@@ -417,15 +422,14 @@
ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag">
below.
-decode($valid_encoding, undef) is harmless but warns you for
-C<Use of uninitialized value in subroutine entry>.
-decode($valid_encoding, '') is harmless and warnless.
+If the $string is C<undef> or a reference then C<undef> is returned.
=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
Converts B<in-place> data between two encodings. The data in $octets
must be encoded as octets and not as characters in Perl's internal
-format. For example, to convert ISO-8859-1 data to Microsoft's CP1250 encoding:
+format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
+encoding:
from_to($octets, "iso-8859-1", "cp1250");
@@ -436,8 +440,8 @@
Note that because the conversion happens in place, the data to be
converted cannot be a string constant; it must be a scalar variable.
-from_to() returns the length of the converted string in octets on success, undef
-otherwise.
+from_to() returns the length of the converted string in octets on
+success, I<undef> on error.
B<CAVEAT>: The following operations look the same but are not quite so;
@@ -547,47 +551,56 @@
perlio_ok("euc-jp")
Fortunately, all encodings that come with Encode core are PerlIO-savvy
-except for hz and ISO-2022-kr. For gory details, see L<Encode::Encoding> and L<Encode::PerlIO>.
+except for hz and ISO-2022-kr. For gory details, see
+L<Encode::Encoding> and L<Encode::PerlIO>.
=head1 Handling Malformed Data
-The I<CHECK> argument is used as follows. When you omit it,
-the behaviour is the same as if you had passed a value of 0 for
-I<CHECK>.
+The optional I<CHECK> argument is used as follows. When you omit it,
+Encode::FB_DEFAULT ( == 0 ) is assumed.
+
+=over 2
+
+=item B<NOTE:> Not all encoding suppport this feature
+
+Some encodings ignore I<CHECK> argument. For example,
+L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
+
+=back
+
+Now here is the list of I<CHECK> values available
=over 2
=item I<CHECK> = Encode::FB_DEFAULT ( == 0)
-If I<CHECK> is 0, (en|de)code will put a I<substitution character>
-in place of a malformed character. For UCM-based encodings,
-E<lt>subcharE<gt> will be used. For Unicode, the code point C<0xFFFD> is used.
-If the data is supposed to be UTF-8, an optional lexical warning
+If I<CHECK> is 0, (en|de)code will put a I<substitution character> in
+place of a malformed character. When you encode, E<lt>subcharE<gt>
+will be used. When you decode the code point C<0xFFFD> is used. If
+the data is supposed to be UTF-8, an optional lexical warning
(category utf8) is given.
=item I<CHECK> = Encode::FB_CROAK ( == 1)
If I<CHECK> is 1, methods will die on error immediately with an error
message. Therefore, when I<CHECK> is set to 1, you should trap the
-fatal error with eval{} unless you really want to let it die on error.
+error with eval{} unless you really want to let it die.
=item I<CHECK> = Encode::FB_QUIET
If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately
-return the portion of the data that has been processed so far when
-an error occurs. The data argument will be overwritten with
-everything after that point (that is, the unprocessed part of data).
-This is handy when you have to call decode repeatedly in the case
-where your source data may contain partial multi-byte character
-sequences, for example because you are reading with a fixed-width
-buffer. Here is some sample code that does exactly this:
-
- my $data = ''; my $utf8 = '';
- while(defined(read $fh, $buffer, 256)){
- # buffer may end in a partial character so we append
- $data .= $buffer;
- $utf8 .= decode($encoding, $data, Encode::FB_QUIET);
- # $data now contains the unprocessed partial character
+return the portion of the data that has been processed so far when an
+error occurs. The data argument will be overwritten with everything
+after that point (that is, the unprocessed part of data). This is
+handy when you have to call decode repeatedly in the case where your
+source data may contain partial multi-byte character sequences,
+(i.e. you are reading with a fixed-width buffer). Here is a sample
+code that does exactly this:
+
+ my $buffer = ''; my $string = '';
+ while(read $fh, $buffer, 256, length($buffer)){
+ $string .= decode($encoding, $buffer, Encode::FB_QUIET);
+ # $buffer now contains the unprocessed partial character
}
=item I<CHECK> = Encode::FB_WARN
@@ -611,8 +624,8 @@
in the character repertoire of the encoding.
HTML/XML character reference modes are about the same, in place of
-C<\x{I<HHHH>}>, HTML uses C<&#I<NNNN>>; where I<NNNN> is a decimal digit and
-XML uses C<&#xI<HHHH>>; where I<HHHH> is the hexadecimal digit.
+C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and
+XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
=item The bitmask
@@ -739,7 +752,7 @@
If CHECK is true, also checks the data in STRING for being well-formed
UTF-8. Returns true if successful, false otherwise.
-As of perl 5.8.1, L<utf8> also has utf8::is_utif8().
+As of perl 5.8.1, L<utf8> also has utf8::is_utf8().
=item _utf8_on(STRING)
1.2 +52 -35 ponie/perl/ext/Encode/Encode.xs
Index: Encode.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Encode/Encode.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Encode.xs 9 Sep 2003 11:59:01 -0000 1.1
+++ Encode.xs 19 Apr 2005 17:05:45 -0000 1.2
@@ -157,24 +157,15 @@
if (check & ENCODE_RETURN_ON_ERR){
goto ENCODE_SET_SRC;
}
- if (check & ENCODE_PERLQQ){
- SV* perlqq =
- sv_2mortal(newSVpvf("\\x{%04"UVxf"}", (UV)ch));
+ if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
+ SV* subchar =
+ newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
+ check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
+ "&#x%" UVxf ";", (UV)ch);
sdone += slen + clen;
- ddone += dlen + SvCUR(perlqq);
- sv_catsv(dst, perlqq);
- }else if (check & ENCODE_HTMLCREF){
- SV* htmlcref =
- sv_2mortal(newSVpvf("&#%" UVuf ";", (UV)ch));
- sdone += slen + clen;
- ddone += dlen + SvCUR(htmlcref);
- sv_catsv(dst, htmlcref);
- }else if (check & ENCODE_XMLCREF){
- SV* xmlcref =
- sv_2mortal(newSVpvf("&#x%" UVxf ";", (UV)ch));
- sdone += slen + clen;
- ddone += dlen + SvCUR(xmlcref);
- sv_catsv(dst, xmlcref);
+ ddone += dlen + SvCUR(subchar);
+ sv_catsv(dst, subchar);
+ SvREFCNT_dec(subchar);
} else {
/* fallback char */
sdone += slen + clen;
@@ -200,11 +191,11 @@
}
if (check &
(ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* perlqq =
- sv_2mortal(newSVpvf("\\x%02" UVXf, (UV)s[slen]));
+ SV* subchar = newSVpvf("\\x%02" UVXf, (UV)s[slen]);
sdone += slen + 1;
- ddone += dlen + SvCUR(perlqq);
- sv_catsv(dst, perlqq);
+ ddone += dlen + SvCUR(subchar);
+ sv_catsv(dst, subchar);
+ SvREFCNT_dec(subchar);
} else {
sdone += slen + 1;
ddone += dlen + strlen(FBCHAR_UTF8);
@@ -261,14 +252,6 @@
PROTOTYPES: DISABLE
void
-Method_renew(obj)
-SV * obj
-CODE:
-{
- XSRETURN(1);
-}
-
-void
Method_decode_xs(obj,src,check = 0)
SV * obj
SV * src
@@ -279,6 +262,27 @@
U8 *s = (U8 *) SvPV(src, slen);
U8 *e = (U8 *) SvEND(src);
SV *dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
+
+ /*
+ * PerlO check -- we assume the object is of PerlIO if renewed
+ * and if so, we set RETURN_ON_ERR for partial character
+ */
+ int renewed = 0;
+ dSP; ENTER; SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(obj);
+ PUTBACK;
+ if (call_method("renewed",G_SCALAR) == 1) {
+ SPAGAIN;
+ renewed = POPi;
+ PUTBACK;
+#if 0
+ fprintf(stderr, "renewed == %d\n", renewed);
+#endif
+ }
+ FREETMPS; LEAVE;
+ /* end PerlIO check */
+
SvPOK_only(dst);
SvCUR_set(dst,0);
if (SvUTF8(src)) {
@@ -297,7 +301,9 @@
U8 skip = UTF8SKIP(s);
if ((s + skip) > e) {
/* Partial character - done */
- break;
+ if (renewed)
+ break;
+ goto decode_utf8_fallback;
}
else if (is_utf8_char(s)) {
/* Whole char is good */
@@ -313,6 +319,7 @@
/* Invalid start byte */
}
/* If we get here there is something wrong with alleged UTF-8 */
+ decode_utf8_fallback:
if (check & ENCODE_DIE_ON_ERR){
Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", (UV)*s);
XSRETURN(0);
@@ -325,9 +332,11 @@
break;
}
if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* perlqq = newSVpvf("\\x%02" UVXf, (UV)*s);
- sv_catsv(dst, perlqq);
- SvREFCNT_dec(perlqq);
+ SV* subchar = newSVpvf(check & ENCODE_PERLQQ ? "\\x%02" UVXf :
+ check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
+ "&#x%" UVxf ";", (UV)*s);
+ sv_catsv(dst, subchar);
+ SvREFCNT_dec(subchar);
} else {
sv_catpv(dst, FBCHAR_UTF8);
}
@@ -406,6 +415,14 @@
XSRETURN(1);
}
+int
+Method_renewed(obj)
+SV * obj
+CODE:
+ RETVAL = 0;
+OUTPUT:
+ RETVAL
+
void
Method_name(obj)
SV * obj
@@ -434,7 +451,7 @@
}
sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
&offset, term, &code));
- SvIVX(off) = (IV)offset;
+ SvIV_set(off, (IV)offset);
if (code == ENCODE_FOUND_TERM) {
ST(0) = &PL_sv_yes;
}else{
1.2 +3 -3 ponie/perl/ext/List/Util/lib/List/Util.pm
Index: Util.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/List/Util/lib/List/Util.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Util.pm 9 Sep 2003 11:59:14 -0000 1.1
+++ Util.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -1,6 +1,6 @@
# List::Util.pm
#
-# Copyright (c) 1997-2003 Graham Barr <[email protected]>. All rights reserved.
+# Copyright (c) 1997-2004 Graham Barr <[email protected]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -10,7 +10,7 @@
@ISA = qw(Exporter);
@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION = "1.12";
+$VERSION = "1.14_01";
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -250,7 +250,7 @@
=head1 COPYRIGHT
-Copyright (c) 1997-2003 Graham Barr <[email protected]>. All rights reserved.
+Copyright (c) 1997-2004 Graham Barr <[email protected]>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
1.2 +3 -2 ponie/perl/ext/POSIX/POSIX.pm
Index: POSIX.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/POSIX/POSIX.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- POSIX.pm 9 Sep 2003 11:59:15 -0000 1.1
+++ POSIX.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -2,7 +2,7 @@
our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = ();
-our $VERSION = "1.06" ;
+our $VERSION = "1.09";
use AutoLoader;
@@ -623,7 +623,7 @@
}
sub chown {
- usage "chown(filename, uid, gid)" if @_ != 3;
+ usage "chown(uid, gid, filename)" if @_ != 3;
CORE::chown($_[0], $_[1], $_[2]);
}
@@ -921,6 +921,7 @@
gmtime
isatty
kill
+ lchown
link
localtime
log
1.2 +113 -45 ponie/perl/ext/POSIX/POSIX.xs
Index: POSIX.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/POSIX/POSIX.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- POSIX.xs 9 Sep 2003 11:59:15 -0000 1.1
+++ POSIX.xs 19 Apr 2005 17:05:46 -0000 1.2
@@ -842,10 +842,12 @@
int
isalnum(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalnum(*s))
RETVAL = 0;
@@ -854,10 +856,12 @@
int
isalpha(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalpha(*s))
RETVAL = 0;
@@ -866,10 +870,12 @@
int
iscntrl(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!iscntrl(*s))
RETVAL = 0;
@@ -878,10 +884,12 @@
int
isdigit(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isdigit(*s))
RETVAL = 0;
@@ -890,10 +898,12 @@
int
isgraph(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isgraph(*s))
RETVAL = 0;
@@ -902,10 +912,12 @@
int
islower(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!islower(*s))
RETVAL = 0;
@@ -914,10 +926,12 @@
int
isprint(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isprint(*s))
RETVAL = 0;
@@ -926,10 +940,12 @@
int
ispunct(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!ispunct(*s))
RETVAL = 0;
@@ -938,10 +954,12 @@
int
isspace(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isspace(*s))
RETVAL = 0;
@@ -950,10 +968,12 @@
int
isupper(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isupper(*s))
RETVAL = 0;
@@ -962,10 +982,12 @@
int
isxdigit(charstring)
- unsigned char * charstring
+ SV * charstring
+ PREINIT:
+ STRLEN len;
CODE:
- unsigned char *s = charstring;
- unsigned char *e = s + SvCUR(ST(0));
+ unsigned char *s = (unsigned char *) SvPV(charstring, len);
+ unsigned char *e = s + len;
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isxdigit(*s))
RETVAL = 0;
@@ -991,6 +1013,7 @@
#ifdef HAS_LOCALECONV
struct lconv *lcbuf;
RETVAL = newHV();
+ sv_2mortal((SV*)RETVAL);
if ((lcbuf = localeconv())) {
/* the strings */
if (lcbuf->decimal_point && *lcbuf->decimal_point)
@@ -1367,20 +1390,25 @@
SysRet
sigprocmask(how, sigset, oldsigset = 0)
int how
- POSIX::SigSet sigset
+ POSIX::SigSet sigset = NO_INIT
POSIX::SigSet oldsigset = NO_INIT
INIT:
- if ( items < 3 ) {
- oldsigset = 0;
+ if (! SvOK(ST(1))) {
+ sigset = NULL;
+ } else if (sv_isa(ST(1), "POSIX::SigSet")) {
+ IV tmp = SvIV((SV*)SvRV(ST(1)));
+ sigset = INT2PTR(POSIX__SigSet,tmp);
+ } else {
+ croak("sigset is not of type POSIX::SigSet");
}
- else if (sv_derived_from(ST(2), "POSIX::SigSet")) {
+
+ if (items < 3 || ! SvOK(ST(2))) {
+ oldsigset = NULL;
+ } else if (sv_isa(ST(2), "POSIX::SigSet")) {
IV tmp = SvIV((SV*)SvRV(ST(2)));
oldsigset = INT2PTR(POSIX__SigSet,tmp);
- }
- else {
- New(0, oldsigset, 1, sigset_t);
- sigemptyset(oldsigset);
- sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset);
+ } else {
+ croak("oldsigset is not of type POSIX::SigSet");
}
SysRet
@@ -1448,7 +1476,7 @@
char * buffer = sv_grow( sv_buffer, nbytes+1 );
CLEANUP:
if (RETVAL >= 0) {
- SvCUR(sv_buffer) = RETVAL;
+ SvCUR_set(sv_buffer, RETVAL);
SvPOK_only(sv_buffer);
*SvEND(sv_buffer) = '\0';
SvTAINTED_on(sv_buffer);
@@ -1624,7 +1652,7 @@
strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
dstlen--;
}
- SvCUR(ST(0)) = dstlen;
+ SvCUR_set(ST(0), dstlen);
SvPOK_only(ST(0));
}
@@ -1783,7 +1811,18 @@
char *
ctermid(s = 0)
- char * s = 0;
+ char * s = 0;
+ CODE:
+#ifdef HAS_CTERMID_R
+ s = safemalloc((size_t) L_ctermid);
+#endif
+ RETVAL = ctermid(s);
+ OUTPUT:
+ RETVAL
+ CLEANUP:
+#ifdef HAS_CTERMID_R
+ Safefree(s);
+#endif
char *
cuserid(s = 0)
@@ -1805,10 +1844,24 @@
SysRet
setgid(gid)
Gid_t gid
+ CLEANUP:
+#ifndef WIN32
+ if (RETVAL >= 0) {
+ PL_gid = getgid();
+ PL_egid = getegid();
+ }
+#endif
SysRet
setuid(uid)
Uid_t uid
+ CLEANUP:
+#ifndef WIN32
+ if (RETVAL >= 0) {
+ PL_uid = getuid();
+ PL_euid = geteuid();
+ }
+#endif
SysRetLong
sysconf(name)
@@ -1827,3 +1880,18 @@
XSprePUSH; PUSHTARG;
}
+SysRet
+lchown(uid, gid, path)
+ Uid_t uid
+ Gid_t gid
+ char * path
+ CODE:
+#ifdef HAS_LCHOWN
+ /* yes, the order of arguments is different,
+ * but consistent with CORE::chown() */
+ RETVAL = lchown(path, uid, gid);
+#else
+ RETVAL = not_here("lchown");
+#endif
+ OUTPUT:
+ RETVAL
1.2 +1 -1 ponie/perl/ext/PerlIO/encoding/encoding.pm
Index: encoding.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/PerlIO/encoding/encoding.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- encoding.pm 9 Sep 2003 11:59:15 -0000 1.1
+++ encoding.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -1,6 +1,6 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.07';
+our $VERSION = '0.08';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
1.2 +4 -4 ponie/perl/ext/PerlIO/encoding/encoding.xs
Index: encoding.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/PerlIO/encoding/encoding.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- encoding.xs 9 Sep 2003 11:59:15 -0000 1.1
+++ encoding.xs 19 Apr 2005 17:05:46 -0000 1.2
@@ -321,8 +321,8 @@
use = e->base.bufsiz;
}
}
- SvPVX(e->dataSV) = (char *) ptr;
- SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
+ SvPV_set(e->dataSV, (char *) ptr);
+ SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
@@ -462,8 +462,8 @@
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
- SvPVX(str) = (char*)e->base.ptr;
- SvLEN(str) = 0;
+ SvPV_set(str, (char*)e->base.ptr);
+ SvLEN_set(str, 0);
SvCUR_set(str, e->base.end - e->base.ptr);
SvPOK_only(str);
SvUTF8_on(str);
1.2 +1 -1 ponie/perl/ext/PerlIO/scalar/scalar.pm
Index: scalar.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/PerlIO/scalar/scalar.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- scalar.pm 9 Sep 2003 11:59:15 -0000 1.1
+++ scalar.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -1,5 +1,5 @@
package PerlIO::scalar;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
use XSLoader ();
XSLoader::load 'PerlIO::scalar';
1;
1.2 +2 -2 ponie/perl/ext/PerlIO/scalar/scalar.xs
Index: scalar.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/PerlIO/scalar/scalar.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- scalar.xs 9 Sep 2003 11:59:15 -0000 1.1
+++ scalar.xs 19 Apr 2005 17:05:46 -0000 1.2
@@ -39,8 +39,8 @@
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
- if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
- SvCUR(s->var) = 0;
+ if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
+ SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
1.2 +9 -4 ponie/perl/ext/Storable/Storable.pm
Index: Storable.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Storable/Storable.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Storable.pm 9 Sep 2003 11:59:16 -0000 1.1
+++ Storable.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -21,7 +21,7 @@
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.08';
+$VERSION = '2.15';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
@@ -47,6 +47,11 @@
}
}
+sub CLONE {
+ # clone context under threads
+ Storable::init_perinterp();
+}
+
# Can't Autoload cleanly as this clashes 8.3 with &retrieve
sub retrieve_fd { &fd_retrieve } # Backward compatibility
@@ -786,10 +791,10 @@
%color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);
- store(\%color, '/tmp/colors') or die "Can't store %a in /tmp/colors!\n";
+ store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n";
- $colref = retrieve('/tmp/colors');
- die "Unable to retrieve from /tmp/colors!\n" unless defined $colref;
+ $colref = retrieve('mycolors');
+ die "Unable to retrieve from mycolors!\n" unless defined $colref;
printf "Blue is still %lf\n", $colref->{'Blue'};
$colref2 = dclone(\%color);
1.4 +7 -7 ponie/perl/ext/Storable/Storable.xs
Index: Storable.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/Storable/Storable.xs,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- Storable.xs 4 Apr 2005 17:46:15 -0000 1.3
+++ Storable.xs 19 Apr 2005 17:05:46 -0000 1.4
@@ -972,7 +972,7 @@
stash = gv_stashpv((p), TRUE); \
ref = newRV_noinc(s); \
(void) sv_bless(ref, stash); \
- SvRV(ref) = 0; \
+ SvRV_set(ref, NULL); \
SvREFCNT_dec(ref); \
} STMT_END
/*
@@ -2848,7 +2848,7 @@
ref = newRV_noinc(sv); /* Temporary reference */
av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
- SvRV(ref) = 0;
+ SvRV_set(ref, NULL);
SvREFCNT_dec(ref); /* Reclaim temporary reference */
count = AvFILLp(av) + 1;
@@ -4302,7 +4302,7 @@
sv_upgrade(rv, SVt_RV);
}
- SvRV(rv) = sv; /* $rv = \$sv */
+ SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
@@ -4362,7 +4362,7 @@
*/
sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv; /* $rv = \$sv */
+ SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
/*
@@ -5884,9 +5884,9 @@
bytes_from_utf8 returned us. */
SvUPGRADE(in, SVt_PV);
SvPOK_on(in);
- SvPVX(in) = asbytes;
- SvLEN(in) = klen_tmp;
- SvCUR(in) = klen_tmp - 1;
+ SvPV_set(in, asbytes);
+ SvLEN_set(in, klen_tmp);
+ SvCUR_set(in, klen_tmp - 1);
}
}
#endif
1.2 +9 -13 ponie/perl/ext/threads/threads.pm
Index: threads.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/threads/threads.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- threads.pm 9 Sep 2003 11:59:17 -0000 1.1
+++ threads.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -31,8 +31,6 @@
'==' => \&equal,
'fallback' => 1;
-#use threads::Shared;
-
BEGIN {
warn "Warning, threads::shared has already been loaded. ".
"To enable shared variables for these modules 'use threads' ".
@@ -52,18 +50,15 @@
our @EXPORT = qw(
async
);
-our $VERSION = '1.00';
+our $VERSION = '1.06';
-sub equal {
- return 1 if($_[0]->tid() == $_[1]->tid());
- return 0;
-}
+# || 0 to ensure compatibility with previous versions
+sub equal { ($_[0]->tid == $_[1]->tid) || 0 }
-sub async (&;@) {
- my $cref = shift;
- return threads->new($cref,@_);
-}
+# use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
+# should also be faster
+sub async (&;@) { unshift @_,'threads'; goto &new }
sub object {
return undef unless @_ > 1;
@@ -144,7 +139,8 @@
This will create a new thread with the entry point function and give
it LIST as parameters. It will return the corresponding threads
-object. The new() method is an alias for create().
+object, or C<undef> if thread creation failed. The new() method is an
+alias for create().
=item $thread->join
@@ -274,7 +270,7 @@
=head1 AUTHOR and COPYRIGHT
-Arthur Bergman E<lt>arthur at contiller.seE<gt>
+Arthur Bergman E<lt>sky at nanisky.comE<gt>
threads is released under the same license as Perl.
1.2 +53 -9 ponie/perl/ext/threads/shared/shared.pm
Index: shared.pm
===================================================================
RCS file: /cvs/public/ponie/perl/ext/threads/shared/shared.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- shared.pm 9 Sep 2003 11:59:17 -0000 1.1
+++ shared.pm 19 Apr 2005 17:05:46 -0000 1.2
@@ -6,11 +6,12 @@
BEGIN {
require Exporter;
our @ISA = qw(Exporter);
- our @EXPORT = qw(share cond_wait cond_broadcast cond_signal);
- our $VERSION = '0.91';
+ our @EXPORT = qw(share cond_wait cond_timedwait cond_broadcast cond_signal);
+ our $VERSION = '0.93';
if ($threads::threads) {
*cond_wait = \&cond_wait_enabled;
+ *cond_timedwait = \&cond_timedwait_enabled;
*cond_signal = \&cond_signal_enabled;
*cond_broadcast = \&cond_broadcast_enabled;
require XSLoader;
@@ -24,10 +25,11 @@
# saves on average about 4K of memory per thread.
eval <<'EOD';
-sub cond_wait (\[$@%]) { undef }
-sub cond_signal (\[$@%]) { undef }
-sub cond_broadcast (\[$@%]) { undef }
-sub share (\[$@%]) { return $_[0] }
+sub cond_wait (\[$@%];\[$@%]) { undef }
+sub cond_timedwait (\[$@%]$;\[$@%]) { undef }
+sub cond_signal (\[$@%]) { undef }
+sub cond_broadcast (\[$@%]) { undef }
+sub share (\[$@%]) { return $_[0] }
EOD
}
}
@@ -62,9 +64,15 @@
{ lock(%hash); ... }
cond_wait($scalar);
+ cond_timedwait($scalar, time() + 30);
cond_broadcast(@array);
cond_signal(%hash);
+ my $lockvar : shared;
+ # condition var != lock var
+ cond_wait($var, $lockvar);
+ cond_timedwait($var, time()+30, $lockvar);
+
=head1 DESCRIPTION
By default, variables are private to each thread, and each newly created
@@ -74,7 +82,7 @@
=head1 EXPORT
-C<share>, C<cond_wait>, C<cond_signal>, C<cond_broadcast>
+C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>
Note that if this module is imported when C<threads> has not yet been
loaded, then these functions all become no-ops. This makes it possible
@@ -122,6 +130,8 @@
=item cond_wait VARIABLE
+=item cond_wait CONDVAR, LOCKVAR
+
The C<cond_wait> function takes a B<locked> variable as a parameter,
unlocks the variable, and blocks until another thread does a
C<cond_signal> or C<cond_broadcast> for that same locked variable.
@@ -131,13 +141,47 @@
to reacquire the lock on the variable. (So if 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 are atomic, the two actions of exiting from the
blocked wait state and relocking the variable are not.
+In its second form, C<cond_wait> takes a shared, B<unlocked> variable
+followed by a shared, B<locked> variable. The second variable is
+unlocked and thread execution suspended until another thread signals
+the first variable.
+
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 important to check the value of the variable and
-go back to waiting if the requirement is not fulfilled.
+go back to waiting if the requirement is not fulfilled. For example,
+to pause until a shared counter drops to zero:
+
+ { lock($counter); cond_wait($count) until $counter == 0; }
+
+=item cond_timedwait VARIABLE, ABS_TIMEOUT
+
+=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR
+
+In its two-argument form, C<cond_timedwait> takes a B<locked> variable
+and an absolute timeout as parameters, unlocks the variable, and blocks
+until the timeout is reached or another thread signals the variable. A
+false value is returned if the timeout is reached, and a true value
+otherwise. In either case, the variable is re-locked upon return.
+
+Like C<cond_wait>, this function may take a shared, B<locked> variable
+as an additional parameter; in this case the first parameter is an
+B<unlocked> condition variable protected by a distinct lock variable.
+
+Again like C<cond_wait>, waking up and reacquiring the lock are not
+atomic, and you should always check your desired condition after this
+function returns. Since the timeout is an absolute value, however, it
+does not have to be recalculated with each pass:
+
+ lock($var);
+ my $abs = time() + 15;
+ until ($ok = desired_condition($var)) {
+ last if !cond_timedwait($var, $abs);
+ }
+ # we got it if $ok, otherwise we timed out!
=item cond_signal VARIABLE
1.2 +199 -22 ponie/perl/ext/threads/shared/shared.xs
Index: shared.xs
===================================================================
RCS file: /cvs/public/ponie/perl/ext/threads/shared/shared.xs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- shared.xs 9 Sep 2003 11:59:17 -0000 1.1
+++ shared.xs 19 Apr 2005 17:05:46 -0000 1.2
@@ -27,13 +27,29 @@
*/
PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
/* To access shared space we fake aTHX in this scope and thread's context */
-#define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
+
+/* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with
+ * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created
+ * while in the shared interpreter context don't languish */
+
+#define SHARED_CONTEXT \
+ STMT_START { \
+ PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \
+ ENTER; \
+ SAVETMPS; \
+ } STMT_END
/* So we need a way to switch back to the caller's context... */
/* So we declare _another_ copy of the aTHX variable ... */
#define dTHXc PerlInterpreter *caller_perl = aTHX
+
/* and use it to switch back */
-#define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl))
+#define CALLER_CONTEXT \
+ STMT_START { \
+ FREETMPS; \
+ LEAVE; \
+ PERL_SET_CONTEXT((aTHX = caller_perl)); \
+ } STMT_END
/*
* Only one thread at a time is allowed to mess with shared space.
@@ -61,6 +77,7 @@
COND_INIT(&lock->cond);
}
+void
recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
{
MUTEX_DESTROY(&lock->mutex);
@@ -307,6 +324,8 @@
if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
SHARED_CONTEXT;
sv_upgrade(ssv, SvTYPE(*psv));
+ if (SvTYPE(ssv) == SVt_PVAV) /* #24061 */
+ AvREAL_on(ssv);
CALLER_CONTEXT;
}
@@ -342,7 +361,7 @@
char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
SvOBJECT_on(sv);
- SvSTASH(sv) = (HV*)SvREFCNT_inc(stash);
+ SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
}
}
break;
@@ -399,6 +418,77 @@
}
}
+#if defined(WIN32) || defined(OS2)
+# define ABS2RELMILLI(abs) \
+ do { \
+ abs -= (double)time(NULL); \
+ if (abs > 0) { abs *= 1000; } \
+ else { abs = 0; } \
+ } while (0)
+#endif /* WIN32 || OS2 */
+
+bool
+Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
+{
+#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
+ Perl_croak_nocontext("cond_timedwait not supported on this platform");
+#else
+# ifdef WIN32
+ int got_it = 0;
+
+ ABS2RELMILLI(abs);
+
+ cond->waiters++;
+ MUTEX_UNLOCK(mut);
+ /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
+ switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
+ case WAIT_OBJECT_0: got_it = 1; break;
+ case WAIT_TIMEOUT: break;
+ default:
+ /* WAIT_FAILED? WAIT_ABANDONED? others? */
+ Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
+ break;
+ }
+ MUTEX_LOCK(mut);
+ cond->waiters--;
+ return got_it;
+# else
+# ifdef OS2
+ int rc, got_it = 0;
+ STRLEN n_a;
+
+ ABS2RELMILLI(abs);
+
+ if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
+ Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
+ MUTEX_UNLOCK(mut);
+ if (CheckOSError(DosWaitEventSem(*cond,abs))
+ && (rc != ERROR_INTERRUPT))
+ croak_with_os2error("panic: cond_timedwait");
+ if (rc == ERROR_INTERRUPT) errno = EINTR;
+ MUTEX_LOCK(mut);
+ return got_it;
+# else /* hope you're I_PTHREAD! */
+ struct timespec ts;
+ int got_it = 0;
+
+ ts.tv_sec = (long)abs;
+ abs -= (NV)ts.tv_sec;
+ ts.tv_nsec = (long)(abs * 1000000000.0);
+
+ switch (pthread_cond_timedwait(cond, mut, &ts)) {
+ case 0: got_it = 1; break;
+ case ETIMEDOUT: break;
+ default:
+ Perl_croak_nocontext("panic: cond_timedwait");
+ break;
+ }
+ return got_it;
+# endif /* OS2 */
+# endif /* WIN32 */
+#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
+}
+
/* MAGIC (in mg.h sense) hooks */
int
@@ -413,7 +503,7 @@
SV *obj = Nullsv;
Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
sv_setsv_nomg(sv, &PL_sv_undef);
- SvRV(sv) = obj;
+ SvRV_set(sv, obj);
SvROK_on(sv);
}
@@ -441,7 +531,7 @@
if(SvOBJECT(SvRV(sv))) {
SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
SvOBJECT_on(SHAREDSvPTR(target));
- SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
+ SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash);
}
CALLER_CONTEXT;
}
@@ -456,7 +546,7 @@
if(SvOBJECT(sv)) {
SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
SvOBJECT_on(SHAREDSvPTR(shared));
- SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
+ SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash);
}
CALLER_CONTEXT;
}
@@ -549,8 +639,18 @@
CALLER_CONTEXT;
if (svp) {
/* Exists in the array */
- target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
- sv_setsv(sv, *svp);
+ if (SvROK(*svp)) {
+ SV *obj = Nullsv;
+ Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL);
+ sv_setsv_nomg(sv, &PL_sv_undef);
+ SvRV_set(sv, obj);
+ SvROK_on(sv);
+ SvSETMAGIC(sv);
+ }
+ else {
+ target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
+ sv_setsv(sv, *svp);
+ }
}
else {
/* Not in the array */
@@ -599,9 +699,12 @@
sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
+ MAGIC *shmg;
shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
ENTER_LOCK;
sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
+ if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
+ sharedsv_scalar_mg_get(aTHX_ sv, shmg);
if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
SHARED_CONTEXT;
av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
@@ -889,13 +992,14 @@
CODE:
dTHXc;
bool exists;
- SHARED_EDIT;
if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
+ SHARED_EDIT;
exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
}
else {
STRLEN len;
char *key = SvPV(index,len);
+ SHARED_EDIT;
exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
}
SHARED_RELEASE;
@@ -1017,19 +1121,36 @@
Perl_sharedsv_lock(aTHX_ shared);
void
-cond_wait_enabled(SV *ref)
- PROTOTYPE: \[$@%]
- CODE:
+cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
+ PROTOTYPE: \[$@%];\[$@%]
+ PREINIT:
shared_sv* shared;
+ perl_cond* user_condition;
int locks;
- if(!SvROK(ref))
+ int same = 0;
+
+ CODE:
+ if (!ref_lock || ref_lock == ref_cond) same = 1;
+
+ if(!SvROK(ref_cond))
Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
- ref = SvRV(ref);
- if(SvROK(ref))
- ref = SvRV(ref);
- shared = Perl_sharedsv_find(aTHX_ ref);
+ ref_cond = SvRV(ref_cond);
+ if(SvROK(ref_cond))
+ ref_cond = SvRV(ref_cond);
+ shared = Perl_sharedsv_find(aTHX_ ref_cond);
if(!shared)
croak("cond_wait can only be used on shared values");
+
+ user_condition = &shared->user_cond;
+ if (! same) {
+ if (!SvROK(ref_lock))
+ Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
+ ref_lock = SvRV(ref_lock);
+ if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
+ shared = Perl_sharedsv_find(aTHX_ ref_lock);
+ if (!shared)
+ croak("cond_wait lock must be a shared value");
+ }
if(shared->lock.owner != aTHX)
croak("You need a lock before you can cond_wait");
/* Stealing the members of the lock object worries me - NI-S */
@@ -1041,14 +1162,70 @@
/* since we are releasing the lock here we need to tell other
people that is ok to go ahead and use it */
COND_SIGNAL(&shared->lock.cond);
- COND_WAIT(&shared->user_cond, &shared->lock.mutex);
+ COND_WAIT(user_condition, &shared->lock.mutex);
while(shared->lock.owner != NULL) {
- COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
- }
+ /* OK -- must reacquire the lock */
+ COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
+ }
+ shared->lock.owner = aTHX;
+ shared->lock.locks = locks;
+ MUTEX_UNLOCK(&shared->lock.mutex);
+
+int
+cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
+ PROTOTYPE: \[$@%]$;\[$@%]
+ PREINIT:
+ shared_sv* shared;
+ perl_cond* user_condition;
+ int locks;
+ int same = 0;
+
+ CODE:
+ if (!ref_lock || ref_cond == ref_lock) same = 1;
+
+ if(!SvROK(ref_cond))
+ Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
+ ref_cond = SvRV(ref_cond);
+ if(SvROK(ref_cond))
+ ref_cond = SvRV(ref_cond);
+ shared = Perl_sharedsv_find(aTHX_ ref_cond);
+ if(!shared)
+ croak("cond_timedwait can only be used on shared values");
+
+ user_condition = &shared->user_cond;
+ if (! same) {
+ if (!SvROK(ref_lock))
+ Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
+ ref_lock = SvRV(ref_lock);
+ if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
+ shared = Perl_sharedsv_find(aTHX_ ref_lock);
+ if (!shared)
+ croak("cond_timedwait lock must be a shared value");
+ }
+ if(shared->lock.owner != aTHX)
+ croak("You need a lock before you can cond_wait");
+
+ MUTEX_LOCK(&shared->lock.mutex);
+ shared->lock.owner = NULL;
+ locks = shared->lock.locks;
+ shared->lock.locks = 0;
+ /* since we are releasing the lock here we need to tell other
+ people that is ok to go ahead and use it */
+ COND_SIGNAL(&shared->lock.cond);
+ RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
+ while (shared->lock.owner != NULL) {
+ /* OK -- must reacquire the lock... */
+ COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
+ }
shared->lock.owner = aTHX;
shared->lock.locks = locks;
MUTEX_UNLOCK(&shared->lock.mutex);
+ if (RETVAL == 0)
+ XSRETURN_UNDEF;
+ OUTPUT:
+ RETVAL
+
void
cond_signal_enabled(SV *ref)
PROTOTYPE: \[$@%]
@@ -1060,11 +1237,11 @@
if(SvROK(ref))
ref = SvRV(ref);
shared = Perl_sharedsv_find(aTHX_ ref);
+ if(!shared)
+ croak("cond_signal can only be used on shared values");
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);
void
1.2 +28 -1 ponie/perl/lib/ExtUtils/t/Constant.t
Index: Constant.t
===================================================================
RCS file: /cvs/public/ponie/perl/lib/ExtUtils/t/Constant.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Constant.t 9 Sep 2003 11:59:24 -0000 1.1
+++ Constant.t 19 Apr 2005 17:05:46 -0000 1.2
@@ -125,6 +125,33 @@
if ($^O eq 'VMS') { $make .= ' all'; }
+ # Sometimes it seems that timestamps can get confused
+
+ # make failed: 256
+ # Makefile out-of-date with respect to Makefile.PL
+ # Cleaning current config before rebuilding Makefile...
+ # make -f Makefile.old clean > /dev/null 2>&1 || /bin/sh -c true
+ # ../../perl "-I../../../lib" "-I../../../lib" Makefile.PL "PERL_CORE=1"
+ # Checking if your kit is complete...
+ # Looks good
+ # Writing Makefile for ExtTest
+ # ==> Your Makefile has been rebuilt. <==
+ # ==> Please rerun the make command. <==
+ # false
+
+ my $timewarp = (-M "Makefile.PL") - (-M "$makefile$makefile_ext");
+ # Convert from days to seconds
+ $timewarp *= 86400;
+ print "# Makefile.PL is $timewarp second(s) older than $makefile$makefile_ext\n";
+ if ($timewarp < 0) {
+ # Sleep for a while to catch up.
+ $timewarp = -$timewarp;
+ $timewarp+=2;
+ $timewarp = 10 if $timewarp > 10;
+ print "# Sleeping for $timewarp second(s) to try to resolve this\n";
+ sleep $timewarp;
+ }
+
print "# make = '$make'\n";
@makeout = `$make`;
if ($?) {
@@ -481,7 +508,7 @@
{name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
. "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
- . "SvIVX(temp_sv) = 1149;"},
+ . "SvIV_set(temp_sv, 1149);"},
);
push @items, $_ foreach keys %compass;