Change 29955 by [EMAIL PROTECTED] on 2007/01/24 18:58:36
Integrate:
[ 27896]
Calling cv_undef() on the CV created by newCONSTSUB() would leak like
a Jumblie's preferred maritime craft. To free CvFILE for this case,
take advantage of the 0 length prototype that will also be there,
and hang it from the prototype. To do this properly means changing
code to actually pay attention to SvCUR() on prototypes. It turns out
that we always know the length of the prototype string, so this may
be faster. Certainly, it's a memory saving (even ignoring the leak).
[ 27898]
Avoid temporarily writing over the prototype when reporting an error.
(And beef up the relevant tests to really check that it all works).
[ 27900]
Oops. Need a macro to convert cv_ckproto() to cv_ckproto_len().
[ 27901]
newCONSTSUB needs to be robust in case CopFILE is NULL.
[ 29954]
Wrap the macro arguments for ck_proto in ().
Affected files ...
... //depot/maint-5.8/perl/dump.c#66 integrate
... //depot/maint-5.8/perl/embed.fnc#184 integrate
... //depot/maint-5.8/perl/embed.h#138 integrate
... //depot/maint-5.8/perl/global.sym#53 integrate
... //depot/maint-5.8/perl/mathoms.c#21 integrate
... //depot/maint-5.8/perl/op.c#172 integrate
... //depot/maint-5.8/perl/op.h#31 edit
... //depot/maint-5.8/perl/pod/perlapi.pod#88 integrate
... //depot/maint-5.8/perl/proto.h#173 integrate
... //depot/maint-5.8/perl/sv.c#311 integrate
... //depot/maint-5.8/perl/t/comp/proto.t#3 integrate
... //depot/maint-5.8/perl/util.c#126 integrate
Differences ...
==== //depot/maint-5.8/perl/dump.c#66 (text) ====
Index: perl/dump.c
--- perl/dump.c#65~29952~ 2007-01-24 08:46:32.000000000 -0800
+++ perl/dump.c 2007-01-24 10:58:36.000000000 -0800
@@ -1346,8 +1346,12 @@
}
break;
case SVt_PVCV:
- if (SvPOK(sv))
- Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
SvPV_nolen_const(sv));
+ if (SvPOK(sv)) {
+ STRLEN len;
+ const char *const proto = SvPV_const(sv, len);
+ Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
+ (int) len, proto);
+ }
/* FALL THROUGH */
case SVt_PVFM:
do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
==== //depot/maint-5.8/perl/embed.fnc#184 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#183~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/embed.fnc 2007-01-24 10:58:36.000000000 -0800
@@ -160,7 +160,9 @@
Afnp |int |fprintf_nocontext|NN PerlIO* stream|NN const char* fmt|...
Afnp |int |printf_nocontext|NN const char* fmt|...
#endif
-p |void |cv_ckproto |NN CV* cv|NULLOK GV* gv|NULLOK char* p
+pb |void |cv_ckproto |NN CV* cv|NULLOK GV* gv|NULLOK char* p
+p |void |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\
+ |NULLOK const char* p|const STRLEN len
pd |CV* |cv_clone |NN CV* proto
ApdR |SV* |gv_const_sv |NN GV* gv
ApdR |SV* |cv_const_sv |NULLOK CV* cv
==== //depot/maint-5.8/perl/embed.h#138 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#137~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/embed.h 2007-01-24 10:58:36.000000000 -0800
@@ -127,6 +127,7 @@
#endif
#ifdef PERL_CORE
#define cv_ckproto Perl_cv_ckproto
+#define cv_ckproto_len Perl_cv_ckproto_len
#define cv_clone Perl_cv_clone
#endif
#define gv_const_sv Perl_gv_const_sv
@@ -2213,6 +2214,7 @@
#endif
#ifdef PERL_CORE
#define cv_ckproto(a,b,c) Perl_cv_ckproto(aTHX_ a,b,c)
+#define cv_ckproto_len(a,b,c,d) Perl_cv_ckproto_len(aTHX_ a,b,c,d)
#define cv_clone(a) Perl_cv_clone(aTHX_ a)
#endif
#define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a)
==== //depot/maint-5.8/perl/global.sym#53 (text+w) ====
Index: perl/global.sym
--- perl/global.sym#52~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/global.sym 2007-01-24 10:58:36.000000000 -0800
@@ -81,6 +81,7 @@
Perl_sv_setpvf_mg_nocontext
Perl_fprintf_nocontext
Perl_printf_nocontext
+Perl_cv_ckproto
Perl_gv_const_sv
Perl_cv_const_sv
Perl_cv_undef
==== //depot/maint-5.8/perl/mathoms.c#21 (text) ====
Index: perl/mathoms.c
--- perl/mathoms.c#20~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/mathoms.c 2007-01-24 10:58:36.000000000 -0800
@@ -1223,6 +1223,12 @@
sv_usepvn_flags(sv,ptr,len, 0);
}
+void
+Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
+{
+ cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
+}
+
/*
=for apidoc unpack_str
@@ -1244,7 +1250,6 @@
/* Whilst this should really be STATIC, it was not in 5.8.7, hence something
may have linked against it. */
-void
S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
{
}
==== //depot/maint-5.8/perl/op.c#172 (text) ====
Index: perl/op.c
--- perl/op.c#171~29949~ 2007-01-24 07:28:38.000000000 -0800
+++ perl/op.c 2007-01-24 10:58:36.000000000 -0800
@@ -4190,14 +4190,20 @@
}
void
-Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len)
{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) &&
ckWARN_d(WARN_PROTOTYPE)) {
+ /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+ relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
+ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
+ || (p && (len != SvCUR(cv) /* Not the same length. */
+ || memNE(p, SvPVX_const(cv), len))))
+ && ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
if (gv)
- gv_efullname3(name = sv_newmortal(), gv, NULL);
+ gv_efullname3(name = sv_newmortal(), (GV *)gv, NULL);
sv_setpv(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
@@ -4207,7 +4213,7 @@
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+ Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
@@ -4371,7 +4377,7 @@
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway
prototype");
}
- cv_ckproto((CV*)gv, NULL, (char *)ps);
+ cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
}
if (ps)
sv_setpvn((SV*)gv, ps, ps_len);
@@ -4410,7 +4416,7 @@
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto(cv, gv, (char *)ps);
+ cv_ckproto_len(cv, gv, ps, ps_len);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if (!block && !attrs) {
@@ -4685,6 +4691,15 @@
Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
{
CV* cv;
+#ifdef USE_ITHREADS
+ const char *const temp_p = CopFILE(PL_curcop);
+ const STRLEN len = temp_p ? strlen(temp_p) : 0;
+#else
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ STRLEN len;
+ const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+ char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
@@ -4701,10 +4716,18 @@
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+ /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ and so doesn't get free()d. (It's expected to be from the C pre-
+ processor __FILE__ directive). But we need a dynamically allocated one,
+ and we need it to get freed. So we cheat, and take advantage of the
+ fact that the first 0 bytes of any string always look the same. */
+ cv = newXS(name, const_sv_xsub, file);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+ /* prototype is "". But this gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
+ /* This gives us a prototype of "", rather than the file name. */
+ SvCUR_set(cv, 0);
#ifdef USE_ITHREADS
if (stash)
@@ -6307,7 +6330,8 @@
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
OP *cvop;
- char *proto = NULL;
+ const char *proto = NULL;
+ const char *proto_end = NULL;
CV *cv = NULL;
GV *namegv = NULL;
int optional = 0;
@@ -6328,8 +6352,10 @@
if (!cv)
tmpop->op_private |= OPpEARLY_CV;
else if (SvPOK(cv)) {
+ STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV_nolen((SV*)cv);
+ proto = SvPV((SV*)cv, len);
+ proto_end = proto + len;
}
}
}
@@ -6347,9 +6373,10 @@
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
if (proto) {
- switch (*proto) {
- case '\0':
+ if (proto >= proto_end)
return too_many_arguments(o, gv_ename(namegv));
+
+ switch (*proto) {
case ';':
optional = 1;
proto++;
@@ -6427,15 +6454,13 @@
break;
case ']':
if (contextclass) {
- /* XXX We shouldn't be modifying proto, so we can
const proto */
- char *p = proto;
- const char s = *p;
+ const char *p = proto;
+ const char *const end = proto;
contextclass = 0;
- *p = '\0';
while (*--p != '[');
- bad_type(arg, Perl_form(aTHX_ "one of %s", p),
- gv_ename(namegv), o2);
- *proto = s;
+ bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ (int)(end - p), p),
+ gv_ename(namegv), o2);
} else
goto oops;
break;
@@ -6512,8 +6537,8 @@
prev = o2;
o2 = o2->op_sibling;
} /* while */
- if (proto && !optional &&
- (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ if (proto && !optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
return o;
}
==== //depot/maint-5.8/perl/op.h#31 (text) ====
Index: perl/op.h
--- perl/op.h#30~29888~ 2007-01-19 13:24:46.000000000 -0800
+++ perl/op.h 2007-01-24 10:58:36.000000000 -0800
@@ -512,6 +512,12 @@
/* used in perly.y */
#define ref(o, type) doref(o, type, TRUE)
+/* no longer used anywhere in core */
+#ifndef PERL_CORE
+#define cv_ckproto(cv, gv, p) \
+ cv_ckproto_len((CV *)(cv), (GV *)(gv), (char *)(p), (p) ? strlen(p) : 0)
+#endif
+
#ifdef USE_REENTRANT_API
#include "reentr.h"
#endif
==== //depot/maint-5.8/perl/pod/perlapi.pod#88 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod#87~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/pod/perlapi.pod 2007-01-24 10:58:36.000000000 -0800
@@ -2103,8 +2103,8 @@
Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
char* savepvn(const char* pv, I32 len)
@@ -5601,7 +5601,7 @@
If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>)
void sv_usepvn_flags(SV* sv, char* ptr, STRLEN len, U32 flags)
==== //depot/maint-5.8/perl/proto.h#173 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#172~29951~ 2007-01-24 08:24:04.000000000 -0800
+++ perl/proto.h 2007-01-24 10:58:36.000000000 -0800
@@ -206,6 +206,7 @@
#endif
PERL_CALLCONV void Perl_cv_ckproto(pTHX_ CV* cv, GV* gv, char* p);
+PERL_CALLCONV void Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv,
const char* p, const STRLEN len);
PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto);
PERL_CALLCONV SV* Perl_gv_const_sv(pTHX_ GV* gv)
__attribute__warn_unused_result__;
==== //depot/maint-5.8/perl/sv.c#311 (text) ====
Index: perl/sv.c
--- perl/sv.c#310~29952~ 2007-01-24 08:46:32.000000000 -0800
+++ perl/sv.c 2007-01-24 10:58:36.000000000 -0800
@@ -3218,8 +3218,10 @@
}
}
if (!intro)
- cv_ckproto(cv, (GV*)dstr,
- SvPOK(sref) ? (char *)SvPVX_const(sref) : NULL);
+ cv_ckproto_len(cv, (GV*)dstr,
+ SvPOK(sref)
+ ? (char *) SvPVX_const(sref) : NULL,
+ SvPOK(sref) ? SvCUR(sref) : 0);
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
@@ -3625,7 +3627,7 @@
If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>)
=cut
@@ -3651,7 +3653,10 @@
allocate = (flags & SV_HAS_TRAILING_NUL)
? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
- if (!(flags & SV_HAS_TRAILING_NUL)) {
+ if (flags & SV_HAS_TRAILING_NUL) {
+ /* It's long enough - do nothing.
+ Specfically Perl_newCONSTSUB is relying on this. */
+ } else {
ptr = saferealloc (ptr, allocate);
}
SvPV_set(sv, ptr);
==== //depot/maint-5.8/perl/t/comp/proto.t#3 (xtext) ====
Index: perl/t/comp/proto.t
--- perl/t/comp/proto.t#2~21594~ 2003-10-31 12:28:11.000000000 -0800
+++ perl/t/comp/proto.t 2007-01-24 10:58:36.000000000 -0800
@@ -585,20 +585,25 @@
print "ok ", $i++, "\n";
eval q/sub multi1 ([EMAIL PROTECTED]) { 1 } multi1 $myvar;/;
- print "not " unless $@ =~ /Type of arg 1 to main::multi1 must be one of/;
+ print "not "
+ unless $@ =~ /Type of arg 1 to main::multi1 must be one of [EMAIL
PROTECTED] /;
print "ok ", $i++, "\n";
eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
- print "not " unless $@ =~ /Type of arg 1 to main::multi2 must be one of/;
+ print "not "
+ unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
print "ok ", $i++, "\n";
eval q/sub multi3 ([EMAIL PROTECTED]) { 1 } multi3 %myhash;/;
- print "not " unless $@ =~ /Type of arg 1 to main::multi3 must be one of/;
+ print "not "
+ unless $@ =~ /Type of arg 1 to main::multi3 must be one of [EMAIL
PROTECTED] /;
print "ok ", $i++, "\n";
eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
- print "not " unless $@ =~ /Type of arg 2 to main::multi4 must be one of/;
+ print "not "
+ unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
print "ok ", $i++, "\n";
eval q/sub multi5 ([EMAIL PROTECTED]) { 1 } multi5 *myglob;/;
- print "not " unless $@ =~ /Type of arg 1 to main::multi5 must be one of/
- && $@ =~ /Not enough arguments/;
+ print "not "
+ unless $@ =~ /Type of arg 1 to main::multi5 must be one of [EMAIL
PROTECTED] /
+ && $@ =~ /Not enough arguments/;
print "ok ", $i++, "\n";
}
==== //depot/maint-5.8/perl/util.c#126 (text) ====
Index: perl/util.c
--- perl/util.c#125~29952~ 2007-01-24 08:46:32.000000000 -0800
+++ perl/util.c 2007-01-24 10:58:36.000000000 -0800
@@ -889,8 +889,8 @@
Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
=cut
*/
End of Patch.
