X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=b8b15dedc2676722fddf05d7581a834f775b18d2;hb=1a6108908b085da4d14ad0cdf8549f193a6fb877;hp=4622fb9b88df54c4702d475d38a91f22b8b5024a;hpb=2e5b91de24d62e1e2bf0fd32a1d4d1d849cafc82;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/dump.c b/dump.c
index 4622fb9..b8b15de 100644
--- a/dump.c
+++ b/dump.c
@@ -1,7 +1,7 @@
 /*    dump.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
@@ -29,10 +29,10 @@
 
 static const char* const svtypenames[SVt_LAST] = {
     "NULL",
+    "BIND",
     "IV",
     "NV",
     "RV",
-    "BIND",
     "PV",
     "PVIV",
     "PVNV",
@@ -49,10 +49,10 @@ static const char* const svtypenames[SVt_LAST] = {
 
 static const char* const svshorttypenames[SVt_LAST] = {
     "UNDEF",
+    "BIND",
     "IV",
     "NV",
     "RV",
-    "BIND",
     "PV",
     "PVIV",
     "PVNV",
@@ -192,6 +192,10 @@ sequence. Thus the output will either be a single char,
 an octal escape sequence, a special escape like C<\n> or a 3 or 
 more digit hex value. 
 
+If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
+not a '\\'. This is because regexes very often contain backslashed
+sequences, whereas '%' is not a particularly common character in patterns.
+
 Returns a pointer to the escaped text as held by dsv.
 
 =cut
@@ -203,14 +207,16 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
                 const STRLEN count, const STRLEN max, 
                 STRLEN * const escaped, const U32 flags ) 
 {
-    char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
-    char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+    char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
+    char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
+    char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
     STRLEN wrote = 0;    /* chars written so far */
     STRLEN chsize = 0;   /* size of data to be written */
     STRLEN readsize = 1; /* size of data just read */
     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
     const char *pv  = str;
     const char *end = pv + count; /* end of string */
+    octbuf[0] = esc;
 
     if (!flags & PERL_PV_ESCAPE_NOCLEAR) 
 	    sv_setpvn(dsv, "", 0);
@@ -228,42 +234,49 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
                                       "%"UVxf, u);
             else
                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                      "\\x{%"UVxf"}", u);
+                                      "%cx{%"UVxf"}", esc, u);
         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
             chsize = 1;            
         } else {         
-            if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
-	    chsize = 2;
+            if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
+	        chsize = 2;
                 switch (c) {
-		case '\\' : octbuf[1] = '\\'; break;
+                
+		case '\\' : /* fallthrough */
+		case '%'  : if ( c == esc )  {
+		                octbuf[1] = esc;  
+		            } else {
+		                chsize = 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 '"'  : 
+                case '"'  : 
                         if ( dq == '"' ) 
 				octbuf[1] = '"';
                         else 
                             chsize = 1;
-				break;
+                        break;
 		default:
                         if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                                  "\\%03o", c);
-			    else
+                                                  "%c%03o", esc, c);
+			else
                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                                  "\\%o", c);
+                                                  "%c%o", esc, c);
                 }
             } else {
-                chsize=1;
+                chsize = 1;
             }
-	    }
-	    if ( max && (wrote + chsize > max) ) {
-		break;
+	}
+	if ( max && (wrote + chsize > max) ) {
+	    break;
         } else if (chsize > 1) {
-		sv_catpvn(dsv, octbuf, chsize);
-		wrote += chsize;
+            sv_catpvn(dsv, octbuf, chsize);
+            wrote += chsize;
 	} else {
             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 	    wrote++;
@@ -308,7 +321,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
   const STRLEN max, char const * const start_color, char const * const end_color, 
   const U32 flags ) 
 {
-    U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+    U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
     STRLEN escaped;
     
     if ( dq == '"' )
@@ -739,7 +752,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #ifdef DUMPADDR
     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 #endif
-    if (o->op_flags || o->op_latefree || o->op_latefreed) {
+    if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
 	SV * const tmpsv = newSVpvs("");
 	switch (o->op_flags & OPf_WANT) {
 	case OPf_WANT_VOID:
@@ -771,6 +784,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 	    sv_catpv(tmpsv, ",LATEFREE");
 	if (o->op_latefreed)
 	    sv_catpv(tmpsv, ",LATEFREED");
+	if (o->op_attached)
+	    sv_catpv(tmpsv, ",ATTACHED");
 	Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 	SvREFCNT_dec(tmpsv);
     }
@@ -908,10 +923,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 	    if (o->op_private & OPpSORT_REVERSE)
 		sv_catpv(tmpsv, ",REVERSE");
 	}
-	else if (optype == OP_THREADSV) {
-	    if (o->op_private & OPpDONE_SVREF)
-		sv_catpv(tmpsv, ",SVREF");
-	}
 	else if (optype == OP_OPEN || optype == OP_BACKTICK) {
 	    if (o->op_private & OPpOPEN_IN_RAW)
 		sv_catpv(tmpsv, ",IN_RAW");
@@ -1127,7 +1138,6 @@ static const struct { const char type; const char *name; } magic_names[] = {
 	{ PERL_MAGIC_sv,             "sv(\\0)" },
 	{ PERL_MAGIC_arylen,         "arylen(#)" },
 	{ PERL_MAGIC_rhash,          "rhash(%)" },
-	{ PERL_MAGIC_regdata_names,  "regdata_names(+)" },
 	{ PERL_MAGIC_pos,            "pos(.)" },
 	{ PERL_MAGIC_symtab,         "symtab(:)" },
 	{ PERL_MAGIC_backref,        "backref(<)" },
@@ -1380,13 +1390,18 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     if (flags & SVf_OOK)	sv_catpv(d, "OOK,");
     if (flags & SVf_FAKE)	sv_catpv(d, "FAKE,");
     if (flags & SVf_READONLY)	sv_catpv(d, "READONLY,");
+    if (flags & SVf_BREAK)	sv_catpv(d, "BREAK,");
 
     if (flags & SVf_AMAGIC)	sv_catpv(d, "OVERLOAD,");
     if (flags & SVp_IOK)	sv_catpv(d, "pIOK,");
     if (flags & SVp_NOK)	sv_catpv(d, "pNOK,");
     if (flags & SVp_POK)	sv_catpv(d, "pPOK,");
-    if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv))
+    if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
+	if (SvPCS_IMPORTED(sv))
+				sv_catpv(d, "PCS_IMPORTED,");
+	else
 				sv_catpv(d, "SCREAM,");
+    }
 
     switch (type) {
     case SVt_PVCV:
@@ -1444,8 +1459,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     case SVt_PVMG:
 	if (SvPAD_TYPED(sv))	sv_catpv(d, "TYPED,");
 	if (SvPAD_OUR(sv))	sv_catpv(d, "OUR,");
-	if (SvPAD_STATE(sv))	sv_catpv(d, "STATE,");
-	break;
+	/* FALL THROUGH */
     case SVt_PVNV:
 	if (SvPAD_STATE(sv))	sv_catpv(d, "STATE,");
 	goto evaled_or_uv;
@@ -1505,9 +1519,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 #endif
 	PerlIO_putc(file, '\n');
     }
-    if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
-	 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
-	|| type == SVt_NV) {
+    if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
+	Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
+			 (UV) COP_SEQ_RANGE_LOW(sv));
+	Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
+			 (UV) COP_SEQ_RANGE_HIGH(sv));
+    } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
+		&& type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
+	       || type == SVt_NV) {
 	STORE_NUMERIC_LOCAL_SET_STANDARD();
 	/* %Vg doesn't work? --jhi */
 #ifdef USE_LONG_DOUBLE
@@ -1542,8 +1561,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	    Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
     }
     if (type >= SVt_PVMG) {
-	if (SvMAGIC(sv))
-            do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
+	if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+	    HV *ost = SvOURSTASH(sv);
+	    if (ost)
+		do_hv_dump(level, file, "  OURSTASH", ost);
+	} else {
+	    if (SvMAGIC(sv))
+		do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
+	}
 	if (SvSTASH(sv))
 	    do_hv_dump(level, file, "  STASH", SvSTASH(sv));
     }
@@ -2636,10 +2661,6 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
 	    if (o->op_private & OPpSORT_REVERSE)
 		sv_catpv(tmpsv, ",REVERSE");
 	}
-	else if (o->op_type == OP_THREADSV) {
-	    if (o->op_private & OPpDONE_SVREF)
-		sv_catpv(tmpsv, ",SVREF");
-	}
 	else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
 	    if (o->op_private & OPpOPEN_IN_RAW)
 		sv_catpv(tmpsv, ",IN_RAW");