Change 29980 by [EMAIL PROTECTED] on 2007/01/25 21:15:39
Integrate:
[ 28144]
In Perl_Gv_AMupdate(), there's no need to call sv_unmagic() if we know
the magic isn't there.
[ 28145]
Simplify the non-printable name error reporting code in Perl_allocmy().
[ 28176]
Subject: [PATCH] Speed up utf8.c a bit
From: [EMAIL PROTECTED] (Andy Lester)
Date: Thu, 11 May 2006 22:41:01 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 28178]
The upgrade/croak order in Perl_sv_utf8_encode() seemed utterly
backwards. It now checks for readonly *first*.
[ 28179]
Subject: [PATCH] Proper use of static funcs in toke.c and pp_sys.c
From: [EMAIL PROTECTED] (Andy Lester)
Date: Tue, 9 May 2006 12:27:30 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 28180]
Subject: [PATCH] upgrade bytes_to_uni
From: [EMAIL PROTECTED] (Andy Lester)
Date: Fri, 12 May 2006 00:21:23 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 28194]
Subject: [PATCH] S_reguni should return its length
From: [EMAIL PROTECTED] (Andy Lester)
Date: Sun, 14 May 2006 09:46:32 -0500
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/embed.fnc#190 integrate
... //depot/maint-5.8/perl/embed.h#143 integrate
... //depot/maint-5.8/perl/gv.c#92 integrate
... //depot/maint-5.8/perl/op.c#181 integrate
... //depot/maint-5.8/perl/pp_pack.c#50 integrate
... //depot/maint-5.8/perl/pp_sys.c#131 integrate
... //depot/maint-5.8/perl/proto.h#180 integrate
... //depot/maint-5.8/perl/regcomp.c#89 integrate
... //depot/maint-5.8/perl/sv.c#317 integrate
... //depot/maint-5.8/perl/toke.c#148 integrate
... //depot/maint-5.8/perl/utf8.c#71 integrate
... //depot/perl/warnings.h#35 edit
... //depot/perl/warnings.pl#56 edit
Differences ...
==== //depot/maint-5.8/perl/embed.fnc#190 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#189~29974~ 2007-01-25 09:04:16.000000000 -0800
+++ perl/embed.fnc 2007-01-25 13:15:39.000000000 -0800
@@ -1179,6 +1179,7 @@
|char ender
s |const char *|get_num |NN const char *ppat|NN I32 *lenptr
sR |char * |sv_exp_grow |NN SV *sv|STRLEN needed
+sR |char * |bytes_to_uni |NN const U8 *start|STRLEN len|NN char *dest
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
@@ -1237,7 +1238,7 @@
Es |regnode*|reganode |NN struct RExC_state_t *state|U8 op|U32 arg
Es |regnode*|regatom |NN struct RExC_state_t *state|NN I32 *flagp
Es |regnode*|regbranch |NN struct RExC_state_t *state|NN I32
*flagp|I32 first
-Es |void |reguni |NN const struct RExC_state_t *state|UV uv|NN
char *s|NN STRLEN *lenp
+Es |STRLEN |reguni |NN const struct RExC_state_t *state|UV uv|NN
char *s
Es |regnode*|regclass |NN struct RExC_state_t *state
ERsn |I32 |regcurly |NN const char *
Es |regnode*|reg_node |NN struct RExC_state_t *state|U8 op
@@ -1385,6 +1386,7 @@
# endif
# if defined(DEBUGGING)
s |int |tokereport |I32 rv
+s |void |printbuf |NN const char* fmt|NN const char* s
# endif
#endif
==== //depot/maint-5.8/perl/embed.h#143 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#142~29974~ 2007-01-25 09:04:16.000000000 -0800
+++ perl/embed.h 2007-01-25 13:15:39.000000000 -0800
@@ -1188,6 +1188,7 @@
#define group_end S_group_end
#define get_num S_get_num
#define sv_exp_grow S_sv_exp_grow
+#define bytes_to_uni S_bytes_to_uni
#endif
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
@@ -1416,6 +1417,7 @@
# if defined(DEBUGGING)
#ifdef PERL_CORE
#define tokereport S_tokereport
+#define printbuf S_printbuf
#endif
# endif
#endif
@@ -3271,6 +3273,7 @@
#define group_end(a,b,c) S_group_end(aTHX_ a,b,c)
#define get_num(a,b) S_get_num(aTHX_ a,b)
#define sv_exp_grow(a,b) S_sv_exp_grow(aTHX_ a,b)
+#define bytes_to_uni(a,b,c) S_bytes_to_uni(aTHX_ a,b,c)
#endif
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
@@ -3341,7 +3344,7 @@
#define reganode(a,b,c) S_reganode(aTHX_ a,b,c)
#define regatom(a,b) S_regatom(aTHX_ a,b)
#define regbranch(a,b,c) S_regbranch(aTHX_ a,b,c)
-#define reguni(a,b,c,d) S_reguni(aTHX_ a,b,c,d)
+#define reguni(a,b,c) S_reguni(aTHX_ a,b,c)
#define regclass(a) S_regclass(aTHX_ a)
#define regcurly S_regcurly
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
@@ -3498,6 +3501,7 @@
# if defined(DEBUGGING)
#ifdef PERL_CORE
#define tokereport(a) S_tokereport(aTHX_ a)
+#define printbuf(a,b) S_printbuf(aTHX_ a,b)
#endif
# endif
#endif
==== //depot/maint-5.8/perl/gv.c#92 (text) ====
Index: perl/gv.c
--- perl/gv.c#91~29971~ 2007-01-25 03:59:28.000000000 -0800
+++ perl/gv.c 2007-01-25 13:15:39.000000000 -0800
@@ -1447,13 +1447,16 @@
Perl_Gv_AMupdate(pTHX_ HV *stash)
{
MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
- AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- if (mg && amtp->was_ok_am == PL_amagic_generation
- && amtp->was_ok_sub == PL_sub_generation)
- return (bool)AMT_OVERLOADED(amtp);
- sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
+ if (mg) {
+ const AMT * const amtp = (AMT*)mg->mg_ptr;
+ if (amtp->was_ok_am == PL_amagic_generation
+ && amtp->was_ok_sub == PL_sub_generation) {
+ return (bool)AMT_OVERLOADED(amtp);
+ }
+ sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
+ }
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package
%s\n",HvNAME_get(stash)) );
==== //depot/maint-5.8/perl/op.c#181 (text) ====
Index: perl/op.c
--- perl/op.c#180~29978~ 2007-01-25 13:01:04.000000000 -0800
+++ perl/op.c 2007-01-25 13:15:39.000000000 -0800
@@ -220,30 +220,11 @@
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- /* 1999-02-27 [EMAIL PROTECTED] */
- char *p;
- p = strchr(name, '\0');
- assert(p);
- /* The next block assumes the buffer is at least 205 chars
- long. At present, it's always at least 256 chars. */
- if (p - name > 200) {
-#ifdef HAS_STRLCPY
- strlcpy(name + 200, "...", 4);
-#else
- strcpy(name + 200, "...");
-#endif
- p = name + 199;
- }
- else {
- p[1] = '\0';
- }
- /* Move everything else down one character */
- for (; p-name > 2; p--)
- *p = *(p-1);
- name[2] = toCTRL(name[1]);
- name[1] = '^';
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
+ name[0], toCTRL(name[1]), name + 2));
+ } else {
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
/* check for duplicate declaration */
pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
==== //depot/maint-5.8/perl/pp_pack.c#50 (text) ====
Index: perl/pp_pack.c
--- perl/pp_pack.c#49~29965~ 2007-01-24 16:07:28.000000000 -0800
+++ perl/pp_pack.c 2007-01-25 13:15:39.000000000 -0800
@@ -716,21 +716,21 @@
return TRUE;
}
-STATIC void
-bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char **dest) {
- U8 buffer[UTF8_MAXLEN];
+STATIC char *
+S_bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char *dest) {
const U8 * const end = start + len;
- char *d = *dest;
+
while (start < end) {
+ U8 buffer[UTF8_MAXLEN];
const int length =
uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer;
switch(length) {
case 1:
- *d++ = buffer[0];
+ *dest++ = buffer[0];
break;
case 2:
- *d++ = buffer[0];
- *d++ = buffer[1];
+ *dest++ = buffer[0];
+ *dest++ = buffer[1];
break;
default:
Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes",
@@ -738,12 +738,13 @@
}
start++;
}
- *dest = d;
+ return dest;
}
#define PUSH_BYTES(utf8, cur, buf, len) \
STMT_START { \
- if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \
+ if (utf8) \
+ (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \
else { \
Copy(buf, cur, len, char); \
(cur) += (len); \
@@ -778,7 +779,7 @@
STMT_START { \
if (utf8) { \
const U8 au8 = (byte); \
- bytes_to_uni(aTHX_ &au8, 1, &(s)); \
+ (s) = bytes_to_uni(&au8, 1, (s)); \
} else *(U8 *)(s)++ = (byte); \
} STMT_END
@@ -3168,7 +3169,7 @@
len+(endb-buffer)*UTF8_EXPAND);
end = start+SvLEN(cat);
}
- bytes_to_uni(aTHX_ buffer, endb-buffer, &cur);
+ cur = bytes_to_uni(buffer, endb-buffer, cur);
} else {
if (cur >= end) {
*cur = '\0';
==== //depot/maint-5.8/perl/pp_sys.c#131 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#130~29974~ 2007-01-25 09:04:16.000000000 -0800
+++ perl/pp_sys.c 2007-01-25 13:15:39.000000000 -0800
@@ -4597,7 +4597,7 @@
if (hent) {
PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
- PUSHs(S_space_join_names_mortal(aTHX_ hent->h_aliases));
+ PUSHs(space_join_names_mortal(hent->h_aliases));
PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
len = hent->h_length;
PUSHs(sv_2mortal(newSViv((IV)len)));
@@ -4680,7 +4680,7 @@
if (nent) {
PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
- PUSHs(S_space_join_names_mortal(aTHX_ nent->n_aliases));
+ PUSHs(space_join_names_mortal(nent->n_aliases));
PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
}
@@ -4741,7 +4741,7 @@
if (pent) {
PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
- PUSHs(S_space_join_names_mortal(aTHX_ pent->p_aliases));
+ PUSHs(space_join_names_mortal(pent->p_aliases));
PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
}
@@ -4811,7 +4811,7 @@
if (sent) {
PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
- PUSHs(S_space_join_names_mortal(aTHX_ sent->s_aliases));
+ PUSHs(space_join_names_mortal(sent->s_aliases));
#ifdef HAS_NTOHS
PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
#else
@@ -5228,7 +5228,7 @@
* but the gr_mem is poisonous anyway.
* So yes, you cannot get the list of group
* members if building multithreaded in UNICOS/mk. */
- PUSHs(S_space_join_names_mortal(aTHX_ grent->gr_mem));
+ PUSHs(space_join_names_mortal(grent->gr_mem));
#endif
}
==== //depot/maint-5.8/perl/proto.h#180 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#179~29979~ 2007-01-25 13:01:25.000000000 -0800
+++ perl/proto.h 2007-01-25 13:15:39.000000000 -0800
@@ -1717,6 +1717,9 @@
STATIC char * S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed)
__attribute__warn_unused_result__;
+STATIC char * S_bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char *dest)
+ __attribute__warn_unused_result__;
+
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
@@ -1808,7 +1811,7 @@
STATIC regnode* S_reganode(pTHX_ struct RExC_state_t *state, U8 op, U32
arg);
STATIC regnode* S_regatom(pTHX_ struct RExC_state_t *state, I32 *flagp);
STATIC regnode* S_regbranch(pTHX_ struct RExC_state_t *state, I32
*flagp, I32 first);
-STATIC void S_reguni(pTHX_ const struct RExC_state_t *state, UV uv, char
*s, STRLEN *lenp);
+STATIC STRLEN S_reguni(pTHX_ const struct RExC_state_t *state, UV uv, char
*s);
STATIC regnode* S_regclass(pTHX_ struct RExC_state_t *state);
STATIC I32 S_regcurly(const char *)
__attribute__warn_unused_result__;
@@ -2002,6 +2005,7 @@
# endif
# if defined(DEBUGGING)
STATIC int S_tokereport(pTHX_ I32 rv);
+STATIC void S_printbuf(pTHX_ const char* fmt, const char* s);
# endif
#endif
==== //depot/maint-5.8/perl/regcomp.c#89 (text) ====
Index: perl/regcomp.c
--- perl/regcomp.c#88~29964~ 2007-01-24 15:53:28.000000000 -0800
+++ perl/regcomp.c 2007-01-25 13:15:39.000000000 -0800
@@ -3209,8 +3209,6 @@
if (len)
p = oldp;
else if (UTF) {
- STRLEN unilen;
-
if (FOLD) {
/* Emit all the Unicode characters. */
STRLEN numlen;
@@ -3219,7 +3217,7 @@
foldlen -= numlen) {
ender = utf8_to_uvchr(foldbuf, &numlen);
if (numlen > 0) {
- reguni(pRExC_state, ender, s, &unilen);
+ const STRLEN unilen =
reguni(pRExC_state, ender, s);
s += unilen;
len += unilen;
/* In EBCDIC the numlen
@@ -3233,7 +3231,7 @@
}
}
else {
- reguni(pRExC_state, ender, s, &unilen);
+ const STRLEN unilen = reguni(pRExC_state, ender,
s);
if (unilen > 0) {
s += unilen;
len += unilen;
@@ -3247,8 +3245,6 @@
break;
}
if (UTF) {
- STRLEN unilen;
-
if (FOLD) {
/* Emit all the Unicode characters. */
STRLEN numlen;
@@ -3257,7 +3253,7 @@
foldlen -= numlen) {
ender = utf8_to_uvchr(foldbuf, &numlen);
if (numlen > 0) {
- reguni(pRExC_state, ender, s, &unilen);
+ const STRLEN unilen = reguni(pRExC_state,
ender, s);
len += unilen;
s += unilen;
/* In EBCDIC the numlen
@@ -3271,7 +3267,7 @@
}
}
else {
- reguni(pRExC_state, ender, s, &unilen);
+ const STRLEN unilen = reguni(pRExC_state, ender, s);
if (unilen > 0) {
s += unilen;
len += unilen;
@@ -4429,10 +4425,10 @@
/*
- reguni - emit (if appropriate) a Unicode character
*/
-STATIC void
-S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
+STATIC STRLEN
+S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
{
- *lenp = SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
+ return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
}
/*
==== //depot/maint-5.8/perl/sv.c#317 (text) ====
Index: perl/sv.c
--- perl/sv.c#316~29974~ 2007-01-25 09:04:16.000000000 -0800
+++ perl/sv.c 2007-01-25 13:15:39.000000000 -0800
@@ -3007,13 +3007,13 @@
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
- (void) sv_utf8_upgrade(sv);
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv)) {
Perl_croak(aTHX_ PL_no_modify);
}
+ (void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
==== //depot/maint-5.8/perl/toke.c#148 (text) ====
Index: perl/toke.c
--- perl/toke.c#147~29964~ 2007-01-24 15:53:28.000000000 -0800
+++ perl/toke.c 2007-01-25 13:15:39.000000000 -0800
@@ -3084,9 +3084,7 @@
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_
- "### Saw unary minus before =>, forcing word %s\n", s);
- } );
+ DEBUG_T( { printbuf("### Saw unary minus before =>, forcing
word %s\n", s); } );
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
@@ -3966,14 +3964,14 @@
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &yylval);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
@@ -3990,7 +3988,7 @@
case '"':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
@@ -4015,7 +4013,7 @@
case '`':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s);
} );
+ DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
==== //depot/maint-5.8/perl/utf8.c#71 (text) ====
Index: perl/utf8.c
--- perl/utf8.c#70~29964~ 2007-01-24 15:53:28.000000000 -0800
+++ perl/utf8.c 2007-01-25 13:15:39.000000000 -0800
@@ -332,13 +332,12 @@
const U8* x = s;
const U8* send;
STRLEN c;
+ STRLEN outlen = 0;
PERL_UNUSED_CONTEXT;
if (!len)
len = strlen((const char *)s);
send = s + len;
- if (el)
- *el = 0;
while (x < send) {
/* Inline the easy bits of is_utf8_char() here for speed... */
@@ -362,17 +361,16 @@
goto out;
}
x += c;
- if (el)
- (*el)++;
+ outlen++;
}
out:
+ if (el)
+ *el = outlen;
+
if (ep)
*ep = x;
- if (x != send)
- return FALSE;
-
- return TRUE;
+ return (x == send);
}
/*
==== //depot/perl/warnings.h#35 (text+w) ====
Index: perl/warnings.h
--- perl/warnings.h#34~29717~ 2007-01-08 02:35:04.000000000 -0800
+++ perl/warnings.h 2007-01-25 13:15:39.000000000 -0800
@@ -25,7 +25,7 @@
(x) == pWARN_NONE)
/* if PL_warnhook is set to this value, then warnings die */
-#define PERL_WARNHOOK_FATAL (((SV*)0) + 1)
+#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
/* Warnings Categories added in Perl 5.008 */
==== //depot/perl/warnings.pl#56 (text) ====
Index: perl/warnings.pl
--- perl/warnings.pl#55~29717~ 2007-01-08 02:35:04.000000000 -0800
+++ perl/warnings.pl 2007-01-25 13:15:39.000000000 -0800
@@ -284,7 +284,7 @@
(x) == pWARN_NONE)
/* if PL_warnhook is set to this value, then warnings die */
-#define PERL_WARNHOOK_FATAL (((SV*)0) + 1)
+#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
EOM
my $offset = 0 ;
End of Patch.
