op_dump(PL_eval_root);
}
-char *
-Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
-{
- const bool nul_terminated = len > cur && pv[cur] == '\0';
- bool truncated = 0;
- sv_setpvn(dsv, "\"", 1);
- for (; cur--; pv++) {
- if (pvlim && SvCUR(dsv) >= pvlim) {
- truncated = 1;
- break;
- }
- switch (*pv) {
- case '\t': sv_catpvs(dsv, "\\t"); break;
- case '\n': sv_catpvs(dsv, "\\n"); break;
- case '\r': sv_catpvs(dsv, "\\r"); break;
- case '\f': sv_catpvs(dsv, "\\f"); break;
- case '"': sv_catpvs(dsv, "\\\""); break;
- case '\\': sv_catpvs(dsv, "\\\\"); break;
- default:
- if (isPRINT(*pv))
- sv_catpvn(dsv, pv, 1);
- else if (cur && isDIGIT(*(pv+1)))
- Perl_sv_catpvf(aTHX_ dsv, "\\%03o", (U8)*pv);
- else
- Perl_sv_catpvf(aTHX_ dsv, "\\%o", (U8)*pv);
- }
+/*
+=for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char *pv|const STRLEN count|const STRLEN max|const U32 flags
+
+Escapes at most the first "count" chars of pv and puts the results into
+buf such that the size of the escaped string will not exceed "max" chars
+and will not contain any incomplete escape sequences.
+
+If flags contains PERL_PV_ESCAPE_QUOTE then the string will have quotes
+placed around it; moreover, if the number of chars converted was less than
+"count" then a trailing elipses (...) will be added after the closing
+quote.
+
+If PERL_PV_ESCAPE_QUOTE is not set, but PERL_PV_ESCAPE_PADR is, then the
+returned string will be right padded with spaces such that it is max chars
+long.
+
+Normally the SV will be cleared before the escaped string is prepared,
+but when PERL_PV_ESCAPE_CAT is set this will not occur.
+
+Returns a pointer to the string contained by SV.
+
+=cut
+*/
+
+char *
+Perl_pv_escape( pTHX_ SV *dsv, const char *pv, const STRLEN count, const STRLEN max, const U32 flags ) {
+ char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
+ char octbuf[8] = "\\0123456";
+ STRLEN wrote = 0;
+ STRLEN chsize = 0;
+ const char *end = pv + count;
+
+ if (flags & PERL_PV_ESCAPE_CAT) {
+ if ( dq == '"' )
+ sv_catpvn(dsv, "\"", 1);
+ } else {
+ if ( dq == '"' )
+ sv_setpvn(dsv, "\"", 1);
+ else
+ sv_setpvn(dsv, "", 0);
+ }
+ for ( ; (pv < end && (!max || (wrote < max))) ; pv++ ) {
+ if ( (*pv == dq) || (*pv == '\\') || isCNTRL(*pv) ) {
+ chsize = 2;
+ switch (*pv) {
+ case '\\' : octbuf[1] = '\\'; break;
+ case '\v' : octbuf[1] = 'v'; break;
+ case '\t' : octbuf[1] = 't'; break;
+ case '\r' : octbuf[1] = 'r'; break;
+ case '\n' : octbuf[1] = 'n'; break;
+ case '\f' : octbuf[1] = 'f'; break;
+ case '"' : if ( dq == *pv ) {
+ octbuf[1] = '"';
+ break;
+ }
+ default:
+ /* note the (U8*) casts here are important.
+ * if they are omitted we can produce the octal
+ * for a negative number which could produce a
+ * buffer overrun in octbuf, with it on we are
+ * guaranteed that the longest the string could be
+ * is 5, (we reserve 8 just because its the first
+ * power of 2 larger than 5.)*/
+ if ( (pv < end) && isDIGIT(*(pv+1)) )
+ chsize = sprintf( octbuf, "\\%03o", (U8)*pv);
+ else
+ chsize = sprintf( octbuf, "\\%o", (U8)*pv);
+ }
+ if ( max && (wrote + chsize > max) ) {
+ break;
+ } else {
+ sv_catpvn(dsv, octbuf, chsize);
+ wrote += chsize;
+ }
+ } else {
+ sv_catpvn(dsv, pv, 1);
+ wrote++;
+ }
}
- sv_catpvs(dsv, "\"");
- if (truncated)
- sv_catpvs(dsv, "...");
- if (nul_terminated)
- sv_catpvs(dsv, "\\0");
+ if ( dq == '"' ) {
+ sv_catpvn( dsv, "\"", 1 );
+ if ( pv < end )
+ sv_catpvn( dsv, "...", 3 );
+ } else if ( max && (flags & PERL_PV_ESCAPE_PADR) ) {
+ for ( ; wrote < max ; wrote++ )
+ sv_catpvn( dsv, " ", 1 );
+ }
+ return SvPVX(dsv);
+}
+
+/*
+=for apidoc pv_display
+ char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
+ STRLEN pvlim, U32 flags)
+
+Similar to
+
+ pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
+
+except that an additional "\0" will be appended to the string when
+len > cur and pv[cur] is "\0".
+
+Note that the final string may be up to 7 chars longer than pvlim.
+
+=cut
+*/
+
+char *
+Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+{
+ pv_escape( dsv, pv, cur, pvlim, PERL_PV_ESCAPE_QUOTE);
+ if (len > cur && pv[cur] == '\0')
+ sv_catpvn( dsv, "\\0", 2 );
return SvPVX(dsv);
}
Apd |void |sv_setsv_mg |NN SV *dstr|NULLOK SV *sstr
Apdbm |void |sv_usepvn_mg |NN SV *sv|NULLOK char *ptr|STRLEN len
ApR |MGVTBL*|get_vtbl |int vtbl_id
-Ap |char* |pv_display |NN SV *dsv|NN const char *pv|STRLEN cur|STRLEN len \
+Apd |char* |pv_display |NN SV *dsv|NN const char *pv|STRLEN cur|STRLEN len \
|STRLEN pvlim
+Apd |char* |pv_escape |NN SV *dsv|NN const char *pv|const STRLEN count \
+ |const STRLEN max|const U32 flags
Afp |void |dump_indent |I32 level|NN PerlIO *file|NN const char* pat|...
Ap |void |dump_vindent |I32 level|NN PerlIO *file|NN const char* pat \
|NULLOK va_list *args
#define sv_setsv_mg Perl_sv_setsv_mg
#define get_vtbl Perl_get_vtbl
#define pv_display Perl_pv_display
+#define pv_escape Perl_pv_escape
#define dump_indent Perl_dump_indent
#define dump_vindent Perl_dump_vindent
#define do_gv_dump Perl_do_gv_dump
#define sv_setsv_mg(a,b) Perl_sv_setsv_mg(aTHX_ a,b)
#define get_vtbl(a) Perl_get_vtbl(aTHX_ a)
#define pv_display(a,b,c,d,e) Perl_pv_display(aTHX_ a,b,c,d,e)
+#define pv_escape(a,b,c,d,e) Perl_pv_escape(aTHX_ a,b,c,d,e)
#define dump_vindent(a,b,c,d) Perl_dump_vindent(aTHX_ a,b,c,d)
#define do_gv_dump(a,b,c,d) Perl_do_gv_dump(aTHX_ a,b,c,d)
#define do_gvgv_dump(a,b,c,d) Perl_do_gvgv_dump(aTHX_ a,b,c,d)
Perl_sv_usepvn_mg
Perl_get_vtbl
Perl_pv_display
+Perl_pv_escape
Perl_dump_indent
Perl_dump_vindent
Perl_do_gv_dump
so that Configure picks them up. */
+/* these are used by Perl_pv_escape() and are here so that they
+ * are available throughout the core */
+
+#define PERL_PV_ESCAPE_QUOTE 1
+#define PERL_PV_ESCAPE_PADR 2
+#define PERL_PV_ESCAPE_CAT 4
+
#endif /* Include guard */
=back
+=head1 Functions in file dump.c
+
+
+=over 8
+
+=item pv_display
+X<pv_display>
+
+ char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
+ STRLEN pvlim, U32 flags)
+
+Similar to
+
+ pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
+
+except that an additional "\0" will be appended to the string when
+len > cur and pv[cur] is "\0".
+
+Note that the final string may be up to 7 chars longer than pvlim.
+
+ char* pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+
+=for hackers
+Found in file dump.c
+
+=item pv_escape
+X<pv_escape>
+
+Escapes at most the first "count" chars of pv and puts the results into
+buf such that the size of the escaped string will not exceed "max" chars
+and will not contain any incomplete escape sequences.
+
+If flags contains PERL_PV_ESCAPE_QUOTE then the string will have quotes
+placed around it; moreover, if the number of chars converted was less than
+"count" then a trailing elipses (...) will be added after the closing
+quote.
+
+If PERL_PV_ESCAPE_QUOTE is not set, but PERL_PV_ESCAPE_PADR is, then the
+returned string will be right padded with spaces such that it is max chars
+long.
+
+Normally the SV will be cleared before the escaped string is prepared,
+but when PERL_PV_ESCAPE_CAT is set this will not occur.
+
+Returns a pointer to the string contained by SV.
+
+NOTE: the perl_ form of this function is deprecated.
+
+ char* pv_escape(SV *dsv, const char *pv, const STRLEN count, const STRLEN max, const U32 flags)
+
+=for hackers
+Found in file dump.c
+
+
+=back
+
=head1 Functions in file mathoms.c
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
+PERL_CALLCONV char* Perl_pv_escape(pTHX_ SV *dsv, const char *pv, const STRLEN count, const STRLEN max, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+
PERL_CALLCONV void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
__attribute__format__(__printf__,pTHX_3,pTHX_4)
__attribute__nonnull__(pTHX_2)
#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 == -1U)
+ if (PL_reentrant_buffer->_grent_size == -1)
PL_reentrant_buffer->_grent_size = REENTRANTUSUALSIZE;
# else
# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
#define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
-#ifdef DEBUGGING
-STATIC void
+#ifdef DEBUGGING
+
+STATIC void
S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
{
const int docolor = *PL_colors[0];
if (pref0_len > pref_len)
pref0_len = pref_len;
{
- const char * const s0 =
- do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
- pref0_len, 60, UNI_DISPLAY_REGEX) :
- locinput - pref_len;
- const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
- const char * const s1 = do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(1),
- (U8*)(locinput - pref_len + pref0_len),
- pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
- locinput - pref_len + pref0_len;
- const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
- const char * const s2 = do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
- PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
- locinput;
- const int len2 = do_utf8 ? (int)strlen(s2) : l;
- PerlIO_printf(Perl_debug_log,
+ const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
+ const char * const s0 = is_uni ?
+ pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
+ pref0_len, 60, UNI_DISPLAY_REGEX) :
+ pv_escape(PERL_DEBUG_PAD(0), (locinput - pref_len),
+ pref0_len, 60, 0);
+
+ const int len0 = strlen(s0);
+ const char * const s1 = is_uni ?
+ pv_uni_display(PERL_DEBUG_PAD(1),
+ (U8*)(locinput - pref_len + pref0_len),
+ pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
+ pv_escape(PERL_DEBUG_PAD(1),
+ (locinput - pref_len + pref0_len),
+ pref_len - pref0_len, 60, 0);
+
+ const int len1 = (int)strlen(s1);
+ const char * const s2 = is_uni ?
+ pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
+ PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
+ pv_escape(PERL_DEBUG_PAD(2), locinput,
+ PL_regeol - locinput, 60, 0);
+ const int len2 = (int)strlen(s2);
+ PerlIO_printf(Perl_debug_log,
"%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
(IV)(locinput - PL_bostr),
PL_colors[4],
"");
}
}
+
#endif
STATIC I32 /* 0 failure, 1 success */
my %h = ("\0011\002\r\n\t\f\"\\abcdefghijklmnopqrstuvwxyz", undef);
$v = join '', %h;
EXPECT
-Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\abcdefghijkl"...} in join or string at - line 6.
+Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\abcdefghijklm"...} in join or string at - line 6.
########
use warnings 'uninitialized';
my ($m1, $v);
projects / p5sagit/p5-mst-13.2.git / commitdiff