Change 30057 by [EMAIL PROTECTED] on 2007/01/29 15:55:07
Integrate:
[ 28877]
Subject: [PATCH] deal with some gcc warnings
From: Jarkko Hietaniemi <[EMAIL PROTECTED]>
Date: Thu, 21 Sep 2006 09:08:47 +0300
Message-ID: <[EMAIL PROTECTED]>
[ 28910]
In pp_binmode, call mode_from_discipline() once and remember the result.
[ 28911]
In PerlIO_debug(), if tainting or set*id, set PL_perlio_debug_fd to -1
first time through to reduce the checks on subsequent calls.
[ 28947]
Don't bother generating the "Operation \"%s\": no method found..."
message text if we're not going to use it.
[ 28950]
Generate the overload enum and names array programatically, which
allows experimentation with the order. The new order shaves nearly
900 bytes from gv.o, because the compiler can make smaller branch
tables for switch statements.
[ 28951]
Fix typo spotted by Rafael. Close the file handle explicity and check
for errors. Add overload.pl to regen.pl
[ 28952]
Make the executable slightly smaller by using PL_hexdigit in
Perl_sv_vcatpvfn.
[ 28961]
Make reference stringification (blessed and unblessed) about as fast as
is possible, because I'm told it's used quite frequently.
[ 29015]
Use Perl_croak_nocontext() rather than Perl_croak() for the snprintf()
and vsnprintf() macros.
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#298 integrate
... //depot/maint-5.8/perl/doio.c#102 integrate
... //depot/maint-5.8/perl/gv.c#97 integrate
... //depot/maint-5.8/perl/overload.h#1 add
... //depot/maint-5.8/perl/overload.pl#1 add
... //depot/maint-5.8/perl/perl.h#149 integrate
... //depot/maint-5.8/perl/perlio.c#100 integrate
... //depot/maint-5.8/perl/pp_sys.c#139 integrate
... //depot/maint-5.8/perl/reentr.c#21 integrate
... //depot/maint-5.8/perl/reentr.pl#28 integrate
... //depot/maint-5.8/perl/regen.pl#4 integrate
... //depot/maint-5.8/perl/sv.c#329 integrate
... //depot/maint-5.8/perl/util.c#137 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#298 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#297~30055~ 2007-01-28 15:54:52.000000000 -0800
+++ perl/MANIFEST 2007-01-29 07:55:07.000000000 -0800
@@ -2290,6 +2290,8 @@
os2/perl2cmd.pl Corrects installed binaries under OS/2
os2/perlrexx.c Support perl interpreter embedded in REXX
os2/perlrexx.cmd Test perl interpreter embedded in REXX
+overload.h generated overload enum and name table
+overload.pl generate overload.h
pad.c Scratchpad functions
pad.h Scratchpad headers
patchlevel.h The current patch level of perl
==== //depot/maint-5.8/perl/doio.c#102 (text) ====
Index: perl/doio.c
--- perl/doio.c#101~30048~ 2007-01-27 16:08:17.000000000 -0800
+++ perl/doio.c 2007-01-29 07:55:07.000000000 -0800
@@ -1317,6 +1317,8 @@
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
return PL_laststatval;
}
+ /* Should we warn/croak here? Or do something smart/useful? */
+ return (PL_laststatval = -1);
}
==== //depot/maint-5.8/perl/gv.c#97 (text) ====
Index: perl/gv.c
--- perl/gv.c#96~30033~ 2007-01-27 08:40:35.000000000 -0800
+++ perl/gv.c 2007-01-29 07:55:07.000000000 -0800
@@ -1800,6 +1800,9 @@
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
+ } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+ /* Skip generating the "no method found" message. */
+ return NULL;
} else {
SV *msg;
if (off==-1) off=method;
==== //depot/maint-5.8/perl/overload.h#1 (text+w) ====
Index: perl/overload.h
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/overload.h 2007-01-29 07:55:07.000000000 -0800
@@ -0,0 +1,166 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * overload.h
+ *
+ * Copyright (C) 1997, 1998, 2000, 2001, 2005 and 2006 by Larry Wall and
+ * others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by overload.pl
+ */
+
+enum {
+ fallback_amg,
+ to_sv_amg,
+ to_av_amg,
+ to_hv_amg,
+ to_gv_amg,
+ to_cv_amg,
+ inc_amg,
+ dec_amg,
+ bool__amg,
+ numer_amg,
+ string_amg,
+ not_amg,
+ copy_amg,
+ abs_amg,
+ neg_amg,
+ iter_amg,
+ int_amg,
+ lt_amg,
+ le_amg,
+ gt_amg,
+ ge_amg,
+ eq_amg,
+ ne_amg,
+ slt_amg,
+ sle_amg,
+ sgt_amg,
+ sge_amg,
+ seq_amg,
+ sne_amg,
+ nomethod_amg,
+ add_amg,
+ add_ass_amg,
+ subtr_amg,
+ subtr_ass_amg,
+ mult_amg,
+ mult_ass_amg,
+ div_amg,
+ div_ass_amg,
+ modulo_amg,
+ modulo_ass_amg,
+ pow_amg,
+ pow_ass_amg,
+ lshift_amg,
+ lshift_ass_amg,
+ rshift_amg,
+ rshift_ass_amg,
+ band_amg,
+ band_ass_amg,
+ bor_amg,
+ bor_ass_amg,
+ bxor_amg,
+ bxor_ass_amg,
+ ncmp_amg,
+ scmp_amg,
+ compl_amg,
+ atan2_amg,
+ cos_amg,
+ sin_amg,
+ exp_amg,
+ log_amg,
+ sqrt_amg,
+ repeat_amg,
+ repeat_ass_amg,
+ concat_amg,
+ concat_ass_amg,
+ DESTROY_amg,
+ max_amg_code
+ /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
+};
+
+
+#define NofAMmeth max_amg_code
+#define AMG_id2name(id) (PL_AMG_names[id]+1)
+
+#ifdef DOINIT
+EXTCONST char * const PL_AMG_names[NofAMmeth] = {
+ /* Names kept in the symbol table. fallback => "()", the rest has
+ "(" prepended. The only other place in perl which knows about
+ this convention is AMG_id2name (used for debugging output and
+ 'nomethod' only), the only other place which has it hardwired is
+ overload.pm. */
+ "()",
+ "(${}",
+ "(@{}",
+ "(%{}",
+ "(*{}",
+ "(&{}",
+ "(++",
+ "(--",
+ "(bool",
+ "(0+",
+ "(\"\"",
+ "(!",
+ "(=",
+ "(abs",
+ "(neg",
+ "(<>",
+ "(int",
+ "(<",
+ "(<=",
+ "(>",
+ "(>=",
+ "(==",
+ "(!=",
+ "(lt",
+ "(le",
+ "(gt",
+ "(ge",
+ "(eq",
+ "(ne",
+ "(nomethod",
+ "(+",
+ "(+=",
+ "(-",
+ "(-=",
+ "(*",
+ "(*=",
+ "(/",
+ "(/=",
+ "(%",
+ "(%=",
+ "(**",
+ "(**=",
+ "(<<",
+ "(<<=",
+ "(>>",
+ "(>>=",
+ "(&",
+ "(&=",
+ "(|",
+ "(|=",
+ "(^",
+ "(^=",
+ "(<=>",
+ "(cmp",
+ "(~",
+ "(atan2",
+ "(cos",
+ "(sin",
+ "(exp",
+ "(log",
+ "(sqrt",
+ "(x",
+ "(x=",
+ "(.",
+ "(.=",
+ "DESTROY"
+};
+#else
+EXTCONST char * PL_AMG_names[NofAMmeth];
+#endif /* def INITAMAGIC */
==== //depot/maint-5.8/perl/overload.pl#1 (text) ====
Index: perl/overload.pl
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/overload.pl 2007-01-29 07:55:07.000000000 -0800
@@ -0,0 +1,157 @@
+#!/usr/bin/perl -w
+
+#
+# Generate overload.h
+# This allows the order of overloading constants to be changed.
+#
+
+BEGIN {
+ # Get function prototypes
+ require 'regen_lib.pl';
+}
+
+use strict;
+
+my (@enums, @names);
+while (<DATA>) {
+ next if /^#/;
+ next if /^$/;
+ my ($enum, $name) = /^(\S+)\s+(\S+)/ or die "Can't parse $_";
+ # No smart match in 5.8.x
+ next if $enum eq 'smart';
+ push @enums, $enum;
+ push @names, $name;
+}
+
+safer_unlink 'overload.h';
+die "overload.h: $!" unless open(H, ">overload.h");
+binmode H;
+select H;
+print <<'EOF';
+/* -*- buffer-read-only: t -*-
+ *
+ * overload.h
+ *
+ * Copyright (C) 1997, 1998, 2000, 2001, 2005 and 2006 by Larry Wall and
+ * others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by overload.pl
+ */
+
+enum {
+EOF
+
+print " ${_}_amg,\n", foreach @enums;
+
+print <<'EOF';
+ max_amg_code
+ /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
+};
+
+
+#define NofAMmeth max_amg_code
+#define AMG_id2name(id) (PL_AMG_names[id]+1)
+
+#ifdef DOINIT
+EXTCONST char * const PL_AMG_names[NofAMmeth] = {
+ /* Names kept in the symbol table. fallback => "()", the rest has
+ "(" prepended. The only other place in perl which knows about
+ this convention is AMG_id2name (used for debugging output and
+ 'nomethod' only), the only other place which has it hardwired is
+ overload.pm. */
+EOF
+
+my $last = pop @names;
+print " \"$_\",\n" foreach map { s/(["\\"])/\\$1/g; $_ } @names;
+
+print <<"EOT";
+ "$last"
+};
+#else
+EXTCONST char * PL_AMG_names[NofAMmeth];
+#endif /* def INITAMAGIC */
+EOT
+
+close H or die $!;
+
+__DATA__
+# Fallback should be the first
+fallback ()
+
+# These 5 are the most common in the fallback switch statement in amagic_call
+to_sv (${}
+to_av (@{}
+to_hv (%{}
+to_gv (*{}
+to_cv (&{}
+
+# These have non-default cases in that switch statement
+inc (++
+dec (--
+bool_ (bool
+numer (0+
+string (""
+not (!
+copy (=
+abs (abs
+neg (neg
+iter (<>
+int (int
+
+# These 12 feature in the next switch statement
+lt (<
+le (<=
+gt (>
+ge (>=
+eq (==
+ne (!=
+slt (lt
+sle (le
+sgt (gt
+sge (ge
+seq (eq
+sne (ne
+
+nomethod (nomethod
+add (+
+add_ass (+=
+subtr (-
+subtr_ass (-=
+mult (*
+mult_ass (*=
+div (/
+div_ass (/=
+modulo (%
+modulo_ass (%=
+pow (**
+pow_ass (**=
+lshift (<<
+lshift_ass (<<=
+rshift (>>
+rshift_ass (>>=
+band (&
+band_ass (&=
+bor (|
+bor_ass (|=
+bxor (^
+bxor_ass (^=
+ncmp (<=>
+scmp (cmp
+compl (~
+atan2 (atan2
+cos (cos
+sin (sin
+exp (exp
+log (log
+sqrt (sqrt
+repeat (x
+repeat_ass (x=
+concat (.
+concat_ass (.=
+smart (~~
+# Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
+DESTROY DESTROY
==== //depot/maint-5.8/perl/perl.h#149 (text) ====
Index: perl/perl.h
--- perl/perl.h#148~30046~ 2007-01-27 15:25:32.000000000 -0800
+++ perl/perl.h 2007-01-29 07:55:07.000000000 -0800
@@ -1432,7 +1432,7 @@
#if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) &&
!(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) &&
!defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer,
len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak(aTHX_
"panic: snprintf buffer overflow"); __len__; })
+# define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer,
len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len))
Perl_croak_nocontext("panic: snprintf buffer overflow"); __len__; })
# define PERL_MY_SNPRINTF_GUARDED
# else
# define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__)
@@ -1444,7 +1444,7 @@
#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) &&
!(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) &&
!defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define my_vsnprintf(buffer, len, ...) ({ int __len__ =
vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len))
Perl_croak(aTHX_ "panic: vsnprintf buffer overflow"); __len__; })
+# define my_vsnprintf(buffer, len, ...) ({ int __len__ =
vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len))
Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; })
# define PERL_MY_VSNPRINTF_GUARDED
# else
# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__)
@@ -4850,92 +4850,7 @@
);
#endif
-
-enum {
- fallback_amg, abs_amg,
- bool__amg, nomethod_amg,
- string_amg, numer_amg,
- add_amg, add_ass_amg,
- subtr_amg, subtr_ass_amg,
- mult_amg, mult_ass_amg,
- div_amg, div_ass_amg,
- modulo_amg, modulo_ass_amg,
- pow_amg, pow_ass_amg,
- lshift_amg, lshift_ass_amg,
- rshift_amg, rshift_ass_amg,
- band_amg, band_ass_amg,
- bor_amg, bor_ass_amg,
- bxor_amg, bxor_ass_amg,
- lt_amg, le_amg,
- gt_amg, ge_amg,
- eq_amg, ne_amg,
- ncmp_amg, scmp_amg,
- slt_amg, sle_amg,
- sgt_amg, sge_amg,
- seq_amg, sne_amg,
- not_amg, compl_amg,
- inc_amg, dec_amg,
- atan2_amg, cos_amg,
- sin_amg, exp_amg,
- log_amg, sqrt_amg,
- repeat_amg, repeat_ass_amg,
- concat_amg, concat_ass_amg,
- copy_amg, neg_amg,
- to_sv_amg, to_av_amg,
- to_hv_amg, to_gv_amg,
- to_cv_amg, iter_amg,
- int_amg, DESTROY_amg,
- max_amg_code
- /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
-};
-
-#define NofAMmeth max_amg_code
-#define AMG_id2name(id) (PL_AMG_names[id]+1)
-
-#ifdef DOINIT
-EXTCONST char * PL_AMG_names[NofAMmeth] = {
- /* Names kept in the symbol table. fallback => "()", the rest has
- "(" prepended. The only other place in perl which knows about
- this convention is AMG_id2name (used for debugging output and
- 'nomethod' only), the only other place which has it hardwired is
- overload.pm. */
- "()", "(abs", /* "fallback" should be the
first. */
- "(bool", "(nomethod",
- "(\"\"", "(0+",
- "(+", "(+=",
- "(-", "(-=",
- "(*", "(*=",
- "(/", "(/=",
- "(%", "(%=",
- "(**", "(**=",
- "(<<", "(<<=",
- "(>>", "(>>=",
- "(&", "(&=",
- "(|", "(|=",
- "(^", "(^=",
- "(<", "(<=",
- "(>", "(>=",
- "(==", "(!=",
- "(<=>", "(cmp",
- "(lt", "(le",
- "(gt", "(ge",
- "(eq", "(ne",
- "(!", "(~",
- "(++", "(--",
- "(atan2", "(cos",
- "(sin", "(exp",
- "(log", "(sqrt",
- "(x", "(x=",
- "(.", "(.=",
- "(=", "(neg",
- "(${}", "(@{}",
- "(%{}", "(*{}",
- "(&{}", "(<>",
- "(int", "DESTROY",
-};
-#else
-EXTCONST char * PL_AMG_names[NofAMmeth];
-#endif /* def INITAMAGIC */
+#include "overload.h"
END_EXTERN_C
==== //depot/maint-5.8/perl/perlio.c#100 (text) ====
Index: perl/perlio.c
--- perl/perlio.c#99~30048~ 2007-01-27 16:08:17.000000000 -0800
+++ perl/perlio.c 2007-01-29 07:55:07.000000000 -0800
@@ -472,12 +472,18 @@
va_list ap;
dSYS;
va_start(ap, fmt);
- if (!dbg && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
- const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
- if (s && *s)
- dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
- else
+ if (!dbg) {
+ if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
+ const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
+ if (s && *s)
+ dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
+ else
+ dbg = -1;
+ } else {
+ /* tainting or set*id, so ignore the environment, and ensure we
+ skip these tests next time through. */
dbg = -1;
+ }
}
if (dbg > 0) {
dTHX;
==== //depot/maint-5.8/perl/pp_sys.c#139 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#138~30045~ 2007-01-27 15:04:25.000000000 -0800
+++ perl/pp_sys.c 2007-01-29 07:55:07.000000000 -0800
@@ -762,22 +762,23 @@
}
PUTBACK;
- if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
- (discp) ? SvPV_nolen_const(discp) : NULL)) {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
- mode_from_discipline(discp),
- (discp) ? SvPV_nolen_const(discp) : NULL)) {
- SPAGAIN;
- RETPUSHUNDEF;
- }
+ {
+ const int mode = mode_from_discipline(discp);
+ const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+ if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
+ SPAGAIN;
+ RETPUSHUNDEF;
+ }
+ }
+ SPAGAIN;
+ RETPUSHYES;
+ }
+ else {
+ SPAGAIN;
+ RETPUSHUNDEF;
}
- SPAGAIN;
- RETPUSHYES;
- }
- else {
- SPAGAIN;
- RETPUSHUNDEF;
}
}
==== //depot/maint-5.8/perl/reentr.c#21 (text) ====
Index: perl/reentr.c
--- perl/reentr.c#20~30040~ 2007-01-27 10:56:32.000000000 -0800
+++ perl/reentr.c 2007-01-29 07:55:07.000000000 -0800
@@ -44,7 +44,7 @@
#ifdef HAS_GETGRNAM_R
# if defined(HAS_SYSCONF) && defined(_SC_GETGR_R_SIZE_MAX) &&
!defined(__GLIBC__)
PL_reentrant_buffer->_grent_size = sysconf(_SC_GETGR_R_SIZE_MAX);
- if (PL_reentrant_buffer->_grent_size == -1)
+ if ((IV)PL_reentrant_buffer->_grent_size == (IV)-1)
PL_reentrant_buffer->_grent_size = REENTRANTUSUALSIZE;
# else
# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
@@ -79,7 +79,7 @@
#ifdef HAS_GETPWNAM_R
# if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) &&
!defined(__GLIBC__)
PL_reentrant_buffer->_pwent_size = sysconf(_SC_GETPW_R_SIZE_MAX);
- if (PL_reentrant_buffer->_pwent_size == -1)
+ if ((IV)PL_reentrant_buffer->_pwent_size == (IV)-1)
PL_reentrant_buffer->_pwent_size = REENTRANTUSUALSIZE;
# else
# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
@@ -101,7 +101,7 @@
#ifdef HAS_GETSPNAM_R
# if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) &&
!defined(__GLIBC__)
PL_reentrant_buffer->_spent_size = sysconf(_SC_GETPW_R_SIZE_MAX);
- if (PL_reentrant_buffer->_spent_size == -1)
+ if ((IV)PL_reentrant_buffer->_spent_size == (IV)-1)
PL_reentrant_buffer->_spent_size = REENTRANTUSUALSIZE;
# else
# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
==== //depot/maint-5.8/perl/reentr.pl#28 (text) ====
Index: perl/reentr.pl
--- perl/reentr.pl#27~30040~ 2007-01-27 10:56:32.000000000 -0800
+++ perl/reentr.pl 2007-01-29 07:55:07.000000000 -0800
@@ -541,7 +541,7 @@
push @size, <<EOF;
# if defined(HAS_SYSCONF) && defined($sc) && !defined(__GLIBC__)
PL_reentrant_buffer->$sz = sysconf($sc);
- if (PL_reentrant_buffer->$sz == -1)
+ if ((IV)PL_reentrant_buffer->$sz == (IV)-1)
PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE;
# else
# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
==== //depot/maint-5.8/perl/regen.pl#4 (text) ====
Index: perl/regen.pl
--- perl/regen.pl#3~25408~ 2005-09-13 15:19:30.000000000 -0700
+++ perl/regen.pl 2007-01-29 07:55:07.000000000 -0800
@@ -27,7 +27,8 @@
'opcode.pl' => [qw[opcode.h opnames.h pp_proto.h pp.sym]],
'regcomp.pl' => [qw[regnodes.h]],
'warnings.pl' => [qw[warnings.h lib/warnings.pm]],
- 'reentr.pl' => [qw[reentr.c reentr.h]],
+ 'reentr.pl' => [qw[reentr.c reentr.h]],
+ 'overload.pl' => [qw[overload.h]],
);
sub do_cksum {
==== //depot/maint-5.8/perl/sv.c#329 (text) ====
Index: perl/sv.c
--- perl/sv.c#328~30040~ 2007-01-27 10:56:32.000000000 -0800
+++ perl/sv.c 2007-01-29 07:55:07.000000000 -0800
@@ -1782,6 +1782,7 @@
STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
+ PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf"
NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv),
(UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
@@ -2644,12 +2645,15 @@
}
}
{
- SV *tsv;
+ STRLEN len;
+ char *retval;
+ char *buffer;
MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvs("NULLREF"));
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_PVMG
&& ((SvFLAGS(referent) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
@@ -2658,21 +2662,66 @@
return stringify_regexp(sv, mg, lp);
} else {
const char *const typestr = sv_reftype((SV *) referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
- tsv = sv_newmortal();
if (SvOBJECT(referent)) {
- const char *const name = HvNAME_get(SvSTASH(referent));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr,
- PTR2UV(referent));
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
+ } else {
+ SvUTF8_off(sv);
+ }
+ } else {
+ stashname = "__ANON__";
+ stashnamelen = 8;
+ }
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
- PTR2UV(referent));
+
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
+ }
+ /* retval may not neccesarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
@@ -8439,8 +8488,7 @@
switch (base) {
unsigned dig;
case 16:
- p = (char*)((c == 'X')
- ? "0123456789ABCDEF" : "0123456789abcdef");
+ p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
do {
dig = uv & 15;
*--ptr = p[dig];
==== //depot/maint-5.8/perl/util.c#137 (text) ====
Index: perl/util.c
--- perl/util.c#136~30036~ 2007-01-27 09:35:47.000000000 -0800
+++ perl/util.c 2007-01-29 07:55:07.000000000 -0800
@@ -5040,7 +5040,7 @@
char *buf = (char*)safesysmalloc(bufsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
- int l = e ? e - *environ : strlen(*environ);
+ int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
bsiz = l + 1; /* + 1 for the \0. */
End of Patch.
