| File: | obj/gnu/usr.bin/perl/dist/Data-Dumper/Dumper.c |
| Warning: | line 682, column 13 Value stored to 'i' is never read |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
| 1 | /* |
| 2 | * This file was generated automatically by ExtUtils::ParseXS version 3.40 from the |
| 3 | * contents of Dumper.xs. Do not edit this file, edit Dumper.xs instead. |
| 4 | * |
| 5 | * ANY CHANGES MADE HERE WILL BE LOST! |
| 6 | * |
| 7 | */ |
| 8 | |
| 9 | #line 1 "Dumper.xs" |
| 10 | #define PERL_NO_GET_CONTEXT |
| 11 | #include "EXTERN.h" |
| 12 | #include "perl.h" |
| 13 | #include "XSUB.h" |
| 14 | #ifdef USE_PPPORT_H |
| 15 | # define NEED_my_snprintf |
| 16 | # define NEED_sv_2pv_flags |
| 17 | # include "ppport.h" |
| 18 | #endif |
| 19 | |
| 20 | #if PERL_VERSION32 < 8 |
| 21 | # define DD_USE_OLD_ID_FORMAT |
| 22 | #endif |
| 23 | |
| 24 | #ifndef strlcpy |
| 25 | # ifdef my_strlcpystrlcpy |
| 26 | # define strlcpy(d,s,l)strlcpy(d,s,l) my_strlcpy(d,s,l)strlcpy(d,s,l) |
| 27 | # else |
| 28 | # define strlcpy(d,s,l)strlcpy(d,s,l) strcpy(d,s) |
| 29 | # endif |
| 30 | #endif |
| 31 | |
| 32 | /* These definitions are ASCII only. But the pure-perl .pm avoids |
| 33 | * calling this .xs file for releases where they aren't defined */ |
| 34 | |
| 35 | #ifndef isASCII |
| 36 | # define isASCII(c)((U64)((c) | 0) < 128) (((UV) (c)) < 128) |
| 37 | #endif |
| 38 | |
| 39 | #ifndef ESC_NATIVE0x1B /* \e */ |
| 40 | # define ESC_NATIVE0x1B 27 |
| 41 | #endif |
| 42 | |
| 43 | #ifndef isPRINT |
| 44 | # define isPRINT(c)( ( (sizeof(c) == sizeof(U8)) ? ( (((U64) (((((U8) (c)))) - ( ((' ')) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( sizeof(c) == sizeof(U32)) ? ( (((U64) (((((U32) (c)))) - (((' ' )) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( ( (( (U64) (((((U64) (c)))) - (((' ')) | 0))) <= (((U64) ((((0x7e ) - (' '))) | 0)))))))) (((UV) (c)) >= ' ' && ((UV) (c)) < 127) |
| 45 | #endif |
| 46 | |
| 47 | #ifndef isALPHA |
| 48 | # define isALPHA(c)( ( (sizeof((~('A' ^ 'a') & (c))) == sizeof(U8)) ? ( (((U64 ) (((((U8) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0))))) : (sizeof((~('A' ^ 'a') & (c))) == sizeof(U32)) ? ( (((U64) (((((U32) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0))))) : ( ( (((U64) (((((U64) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0)))))) )) ( (((UV) (c)) >= 'a' && ((UV) (c)) <= 'z') \ |
| 49 | || (((UV) (c)) <= 'Z' && ((UV) (c)) >= 'A')) |
| 50 | #endif |
| 51 | |
| 52 | #ifndef isIDFIRST |
| 53 | # define isIDFIRST(c)(( (sizeof(c) == 1) || !(((U64)((c) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (c)] & ((1U << (16)) | (1U << (14)))) == ((1U << (16)) | (1U << (14))))) (isALPHA(c)( ( (sizeof((~('A' ^ 'a') & (c))) == sizeof(U8)) ? ( (((U64 ) (((((U8) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0))))) : (sizeof((~('A' ^ 'a') & (c))) == sizeof(U32)) ? ( (((U64) (((((U32) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0))))) : ( ( (((U64) (((((U64) ((~('A' ^ 'a') & (c)))))) - ((('A')) | 0))) <= (((U64) (((('Z') - ('A'))) | 0)))))) )) || (c) == '_') |
| 54 | #endif |
| 55 | |
| 56 | #ifndef isWORDCHAR |
| 57 | # define isWORDCHAR(c)(( (sizeof(c) == 1) || !(((U64)((c) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (c)] & ((1U << (0)) | (1U << (14)))) == ((1U << (0)) | (1U << (14))))) (isIDFIRST(c)(( (sizeof(c) == 1) || !(((U64)((c) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (c)] & ((1U << (16)) | (1U << (14)))) == ((1U << (16)) | (1U << (14))))) \ |
| 58 | || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) |
| 59 | #endif |
| 60 | |
| 61 | /* SvPVCLEAR only from perl 5.25.6 */ |
| 62 | #ifndef SvPVCLEAR |
| 63 | # define SvPVCLEAR(sv)Perl_sv_setpv_bufsize( sv,0,0) sv_setpvs((sv), "")Perl_sv_setpvn( (sv), ("" "" ""), (sizeof("")-1)) |
| 64 | #endif |
| 65 | |
| 66 | #ifndef memBEGINs |
| 67 | # define memBEGINs(s1, l, s2)( (l) >= sizeof(s2) - 1 && (memcmp(((const void *) (s1)), ((const void *) ("" s2 "")), sizeof(s2)-1) == 0)) \ |
| 68 | ( (l) >= sizeof(s2) - 1 \ |
| 69 | && memEQ(s1, "" s2 "", sizeof(s2)-1)(memcmp(((const void *) (s1)), ((const void *) ("" s2 "")), sizeof (s2)-1) == 0)) |
| 70 | #endif |
| 71 | |
| 72 | /* This struct contains almost all the user's desired configuration, and it |
| 73 | * is treated as mostly constant (except for maxrecursed) by the recursive |
| 74 | * function. This arrangement has the advantage of needing less memory |
| 75 | * than passing all of them on the stack all the time (as was the case in |
| 76 | * an earlier implementation). */ |
| 77 | typedef struct { |
| 78 | SV *pad; |
| 79 | SV *xpad; |
| 80 | SV *sep; |
| 81 | SV *pair; |
| 82 | SV *sortkeys; |
| 83 | SV *freezer; |
| 84 | SV *toaster; |
| 85 | SV *bless; |
| 86 | IV maxrecurse; |
| 87 | bool_Bool maxrecursed; /* at some point we exceeded the maximum recursion level */ |
| 88 | I32 indent; |
| 89 | I32 purity; |
| 90 | I32 deepcopy; |
| 91 | I32 quotekeys; |
| 92 | I32 maxdepth; |
| 93 | I32 useqq; |
| 94 | int use_sparse_seen_hash; |
| 95 | int trailingcomma; |
| 96 | int deparse; |
| 97 | } Style; |
| 98 | |
| 99 | static STRLEN num_q (const char *s, STRLEN slen); |
| 100 | static STRLEN esc_q (char *dest, const char *src, STRLEN slen); |
| 101 | static STRLEN esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq); |
| 102 | static bool_Bool globname_needs_quote(const char *s, STRLEN len); |
| 103 | #ifndef GvNAMEUTF8 |
| 104 | static bool_Bool globname_supra_ascii(const char *s, STRLEN len); |
| 105 | #endif |
| 106 | static bool_Bool key_needs_quote(const char *s, STRLEN len); |
| 107 | static bool_Bool safe_decimal_number(const char *p, STRLEN len); |
| 108 | static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n); |
| 109 | static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, |
| 110 | HV *seenhv, AV *postav, const I32 level, SV *apad, |
| 111 | Style *style); |
| 112 | |
| 113 | #ifndef HvNAME_get |
| 114 | #define HvNAME_get HvNAME |
| 115 | #endif |
| 116 | |
| 117 | /* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a |
| 118 | * length parameter. This wrongly allowed reading beyond the end of buffer |
| 119 | * given malformed input */ |
| 120 | |
| 121 | #if PERL_VERSION32 <= 6 /* Perl 5.6 and earlier */ |
| 122 | |
| 123 | UV |
| 124 | Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) |
| 125 | { |
| 126 | const UV uv = utf8_to_uv(s, send - s, retlen, |
| 127 | ckWARN(WARN_UTF8)Perl_ckwarn( (44 )) ? 0 : UTF8_ALLOW_ANY( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080)); |
| 128 | return UNI_TO_NATIVE(uv)((UV) ((uv) | 0)); |
| 129 | } |
| 130 | |
| 131 | # if !defined(PERL_IMPLICIT_CONTEXT) |
| 132 | # define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf |
| 133 | # else |
| 134 | # define utf8_to_uvchr_buf(a,b,c)Perl_utf8_to_uvchr_buf_helper( (const U8 *) (a),(const U8 *) b ,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) |
| 135 | # endif |
| 136 | |
| 137 | #endif /* PERL_VERSION <= 6 */ |
| 138 | |
| 139 | /* Perl 5.7 through part of 5.15 */ |
| 140 | #if PERL_VERSION32 > 6 && PERL_VERSION32 <= 15 && ! defined(utf8_to_uvchr_buf) |
| 141 | |
| 142 | UV |
| 143 | Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) |
| 144 | { |
| 145 | /* We have to discard <send> for these versions; hence can read off the |
| 146 | * end of the buffer if there is a malformation that indicates the |
| 147 | * character is longer than the space available */ |
| 148 | |
| 149 | return utf8_to_uvchr(s, retlen)Perl_utf8_to_uvchr( s,retlen); |
| 150 | } |
| 151 | |
| 152 | # if !defined(PERL_IMPLICIT_CONTEXT) |
| 153 | # define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf |
| 154 | # else |
| 155 | # define utf8_to_uvchr_buf(a,b,c)Perl_utf8_to_uvchr_buf_helper( (const U8 *) (a),(const U8 *) b ,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) |
| 156 | # endif |
| 157 | |
| 158 | #endif /* PERL_VERSION > 6 && <= 15 */ |
| 159 | |
| 160 | /* Changes in 5.7 series mean that now IOK is only set if scalar is |
| 161 | precisely integer but in 5.6 and earlier we need to do a more |
| 162 | complex test */ |
| 163 | #if PERL_VERSION32 <= 6 |
| 164 | #define DD_is_integer(sv)((sv)->sv_flags & 0x00000100) (SvIOK(sv)((sv)->sv_flags & 0x00000100) && (SvIsUV(val)((val)->sv_flags & 0x80000000) ? SvUV(sv)((((sv)->sv_flags & (0x00000100|0x80000000|0x00200000) ) == (0x00000100|0x80000000)) ? ((XPVUV*) (sv)->sv_any)-> xuv_u.xivu_uv : Perl_sv_2uv_flags( sv,2)) == SvNV(sv)((((sv)->sv_flags & (0x00000200|0x00200000)) == 0x00000200 ) ? ((XPVNV*) (sv)->sv_any)->xnv_u.xnv_nv : Perl_sv_2nv_flags ( sv,2)) : SvIV(sv)((((sv)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (sv)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( sv,2)) == SvNV(sv)((((sv)->sv_flags & (0x00000200|0x00200000)) == 0x00000200 ) ? ((XPVNV*) (sv)->sv_any)->xnv_u.xnv_nv : Perl_sv_2nv_flags ( sv,2)))) |
| 165 | #else |
| 166 | #define DD_is_integer(sv)((sv)->sv_flags & 0x00000100) SvIOK(sv)((sv)->sv_flags & 0x00000100) |
| 167 | #endif |
| 168 | |
| 169 | /* does a glob name need to be protected? */ |
| 170 | static bool_Bool |
| 171 | globname_needs_quote(const char *ss, STRLEN len) |
| 172 | { |
| 173 | const U8 *s = (const U8 *) ss; |
| 174 | const U8 *send = s+len; |
| 175 | TOP: |
| 176 | if (s[0] == ':') { |
| 177 | if (++s<send) { |
| 178 | if (*s++ != ':') |
| 179 | return TRUE(1); |
| 180 | } |
| 181 | else |
| 182 | return TRUE(1); |
| 183 | } |
| 184 | if (isIDFIRST(*s)(( (sizeof(*s) == 1) || !(((U64)((*s) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (*s)] & ((1U << (16)) | (1U << (14)))) == ((1U << (16)) | (1U << (14)))))) { |
| 185 | while (++s<send) |
| 186 | if (!isWORDCHAR(*s)(( (sizeof(*s) == 1) || !(((U64)((*s) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (*s)] & ((1U << (0)) | (1U << (14)))) == ((1U << (0)) | (1U << (14)))))) { |
| 187 | if (*s == ':') |
| 188 | goto TOP; |
| 189 | else |
| 190 | return TRUE(1); |
| 191 | } |
| 192 | } |
| 193 | else |
| 194 | return TRUE(1); |
| 195 | |
| 196 | return FALSE(0); |
| 197 | } |
| 198 | |
| 199 | #ifndef GvNAMEUTF8 |
| 200 | /* does a glob name contain supra-ASCII characters? */ |
| 201 | static bool_Bool |
| 202 | globname_supra_ascii(const char *ss, STRLEN len) |
| 203 | { |
| 204 | const U8 *s = (const U8 *) ss; |
| 205 | const U8 *send = s+len; |
| 206 | while (s < send) { |
| 207 | if (!isASCII(*s)((U64)((*s) | 0) < 128)) |
| 208 | return TRUE(1); |
| 209 | s++; |
| 210 | } |
| 211 | return FALSE(0); |
| 212 | } |
| 213 | #endif |
| 214 | |
| 215 | /* does a hash key need to be quoted (to the left of => ). |
| 216 | Previously this used (globname_)needs_quote() which accepted strings |
| 217 | like '::foo', but these aren't safe as unquoted keys under strict. |
| 218 | */ |
| 219 | static bool_Bool |
| 220 | key_needs_quote(const char *s, STRLEN len) { |
| 221 | const char *send = s+len; |
| 222 | |
| 223 | if (safe_decimal_number(s, len)) { |
| 224 | return FALSE(0); |
| 225 | } |
| 226 | else if (isIDFIRST(*s)(( (sizeof(*s) == 1) || !(((U64)((*s) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (*s)] & ((1U << (16)) | (1U << (14)))) == ((1U << (16)) | (1U << (14)))))) { |
| 227 | while (++s<send) |
| 228 | if (!isWORDCHAR(*s)(( (sizeof(*s) == 1) || !(((U64)((*s) | 0)) & ~0xFF)) && ((PL_charclass[(U8) (*s)] & ((1U << (0)) | (1U << (14)))) == ((1U << (0)) | (1U << (14)))))) |
| 229 | return TRUE(1); |
| 230 | } |
| 231 | else |
| 232 | return TRUE(1); |
| 233 | |
| 234 | return FALSE(0); |
| 235 | } |
| 236 | |
| 237 | /* Check that the SV can be represented as a simple decimal integer. |
| 238 | * |
| 239 | * The perl code does this by matching against /^(?:0|-?[1-9]\d{0,8})\z/ |
| 240 | */ |
| 241 | static bool_Bool |
| 242 | safe_decimal_number(const char *p, STRLEN len) { |
| 243 | if (len == 1 && *p == '0') |
| 244 | return TRUE(1); |
| 245 | |
| 246 | if (len && *p == '-') { |
| 247 | ++p; |
| 248 | --len; |
| 249 | } |
| 250 | |
| 251 | if (len == 0 || *p < '1' || *p > '9') |
| 252 | return FALSE(0); |
| 253 | |
| 254 | ++p; |
| 255 | --len; |
| 256 | |
| 257 | if (len > 8) |
| 258 | return FALSE(0); |
| 259 | |
| 260 | while (len > 0) { |
| 261 | /* the perl code checks /\d/ but we don't want unicode digits here */ |
| 262 | if (*p < '0' || *p > '9') |
| 263 | return FALSE(0); |
| 264 | ++p; |
| 265 | --len; |
| 266 | } |
| 267 | return TRUE(1); |
| 268 | } |
| 269 | |
| 270 | /* count the number of "'"s and "\"s in string */ |
| 271 | static STRLEN |
| 272 | num_q(const char *s, STRLEN slen) |
| 273 | { |
| 274 | STRLEN ret = 0; |
| 275 | |
| 276 | while (slen > 0) { |
| 277 | if (*s == '\'' || *s == '\\') |
| 278 | ++ret; |
| 279 | ++s; |
| 280 | --slen; |
| 281 | } |
| 282 | return ret; |
| 283 | } |
| 284 | |
| 285 | |
| 286 | /* returns number of chars added to escape "'"s and "\"s in s */ |
| 287 | /* slen number of characters in s will be escaped */ |
| 288 | /* destination must be long enough for additional chars */ |
| 289 | static STRLEN |
| 290 | esc_q(char *d, const char *s, STRLEN slen) |
| 291 | { |
| 292 | STRLEN ret = 0; |
| 293 | |
| 294 | while (slen > 0) { |
| 295 | switch (*s) { |
| 296 | case '\'': |
| 297 | case '\\': |
| 298 | *d = '\\'; |
| 299 | ++d; ++ret; |
| 300 | /* FALLTHROUGH */ |
| 301 | default: |
| 302 | *d = *s; |
| 303 | ++d; ++s; --slen; |
| 304 | break; |
| 305 | } |
| 306 | } |
| 307 | return ret; |
| 308 | } |
| 309 | |
| 310 | /* this function is also misused for implementing $Useqq */ |
| 311 | static STRLEN |
| 312 | esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) |
| 313 | { |
| 314 | char *r, *rstart; |
| 315 | const char *s = src; |
| 316 | const char * const send = src + slen; |
| 317 | STRLEN j, cur = SvCUR(sv)((XPV*) (sv)->sv_any)->xpv_cur; |
| 318 | /* Could count 128-255 and 256+ in two variables, if we want to |
| 319 | be like &qquote and make a distinction. */ |
| 320 | STRLEN grow = 0; /* bytes needed to represent chars 128+ */ |
| 321 | /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */ |
| 322 | STRLEN backslashes = 0; |
| 323 | STRLEN single_quotes = 0; |
| 324 | STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ |
| 325 | STRLEN normal = 0; |
| 326 | int increment; |
| 327 | |
| 328 | for (s = src; s < send; s += increment) { /* Sizing pass */ |
| 329 | UV k = *(U8*)s; |
| 330 | |
| 331 | increment = 1; /* Will override if necessary for utf-8 */ |
| 332 | |
| 333 | if (isPRINT(k)( ( (sizeof(k) == sizeof(U8)) ? ( (((U64) (((((U8) (k)))) - ( ((' ')) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( sizeof(k) == sizeof(U32)) ? ( (((U64) (((((U32) (k)))) - (((' ' )) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( ( (( (U64) (((((U64) (k)))) - (((' ')) | 0))) <= (((U64) ((((0x7e ) - (' '))) | 0))))))))) { |
| 334 | if (k == '\\') { |
| 335 | backslashes++; |
| 336 | } else if (k == '\'') { |
| 337 | single_quotes++; |
| 338 | } else if (k == '"' || k == '$' || k == '@') { |
| 339 | qq_escapables++; |
| 340 | } else { |
| 341 | normal++; |
| 342 | } |
| 343 | } |
| 344 | else if (! isASCII(k)((U64)((k) | 0) < 128) && k > ' ') { |
| 345 | /* High ordinal non-printable code point. (The test that k is |
| 346 | * above SPACE should be optimized out by the compiler on |
| 347 | * non-EBCDIC platforms; otherwise we could put an #ifdef around |
| 348 | * it, but it's better to have just a single code path when |
| 349 | * possible. All but one of the non-ASCII EBCDIC controls are low |
| 350 | * ordinal; that one is the only one above SPACE.) |
| 351 | * |
| 352 | * If UTF-8, output as hex, regardless of useqq. This means there |
| 353 | * is an overhead of 4 chars '\x{}'. Then count the number of hex |
| 354 | * digits. */ |
| 355 | if (do_utf8) { |
| 356 | k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL)Perl_utf8_to_uvchr_buf_helper( (const U8 *) ((U8*)s),(const U8 *) (U8*) send,((void*)0)); |
| 357 | |
| 358 | /* treat invalid utf8 byte by byte. This loop iteration gets the |
| 359 | * first byte */ |
| 360 | increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)]; |
| 361 | |
| 362 | grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : |
| 363 | #if UVSIZE8 == 4 |
| 364 | 8 /* We may allocate a bit more than the minimum here. */ |
| 365 | #else |
| 366 | k <= 0xFFFFFFFF ? 8 : UVSIZE8 * 4 |
| 367 | #endif |
| 368 | ); |
| 369 | } |
| 370 | else if (useqq) { /* Not utf8, must be <= 0xFF, hence 2 hex |
| 371 | * digits. */ |
| 372 | grow += 4 + 2; |
| 373 | } |
| 374 | else { /* Non-qq generates 3 octal digits plus backslash */ |
| 375 | grow += 4; |
| 376 | } |
| 377 | } /* End of high-ordinal non-printable */ |
| 378 | else if (! useqq) { /* Low ordinal, non-printable, non-qq just |
| 379 | * outputs the raw char */ |
| 380 | normal++; |
| 381 | } |
| 382 | else { /* Is qq, low ordinal, non-printable. Output escape |
| 383 | * sequences */ |
| 384 | if ( k == '\a' || k == '\b' || k == '\t' || k == '\n' || k == '\r' |
| 385 | || k == '\f' || k == ESC_NATIVE0x1B) |
| 386 | { |
| 387 | grow += 2; /* 1 char plus backslash */ |
| 388 | } |
| 389 | else /* The other low ordinals are output as an octal escape |
| 390 | * sequence */ |
| 391 | if (s + 1 >= send || ( *(U8*)(s+1) >= '0' |
| 392 | && *(U8*)(s+1) <= '9')) |
| 393 | { |
| 394 | /* When the following character is a digit, use 3 octal digits |
| 395 | * plus backslash, as using fewer digits would concatenate the |
| 396 | * following char into this one */ |
| 397 | grow += 4; |
| 398 | } |
| 399 | else if (k <= 7) { |
| 400 | grow += 2; /* 1 octal digit, plus backslash */ |
| 401 | } |
| 402 | else if (k <= 077) { |
| 403 | grow += 3; /* 2 octal digits plus backslash */ |
| 404 | } |
| 405 | else { |
| 406 | grow += 4; /* 3 octal digits plus backslash */ |
| 407 | } |
| 408 | } |
| 409 | } /* End of size-calculating loop */ |
| 410 | |
| 411 | if (grow || useqq) { |
| 412 | /* We have something needing hex. 3 is ""\0 */ |
| 413 | sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotesPerl_sv_grow( sv,cur + 3 + grow + 2*backslashes + single_quotes + 2*qq_escapables + normal) |
| 414 | + 2*qq_escapables + normal)Perl_sv_grow( sv,cur + 3 + grow + 2*backslashes + single_quotes + 2*qq_escapables + normal); |
| 415 | rstart = r = SvPVX(sv)((sv)->sv_u.svu_pv) + cur; |
| 416 | |
| 417 | *r++ = '"'; |
| 418 | |
| 419 | for (s = src; s < send; s += increment) { |
| 420 | U8 c0 = *(U8 *)s; |
| 421 | UV k; |
| 422 | |
| 423 | if (do_utf8 |
| 424 | && ! isASCII(c0)((U64)((c0) | 0) < 128) |
| 425 | /* Exclude non-ASCII low ordinal controls. This should be |
| 426 | * optimized out by the compiler on ASCII platforms; if not |
| 427 | * could wrap it in a #ifdef EBCDIC, but better to avoid |
| 428 | * #if's if possible */ |
| 429 | && c0 > ' ' |
| 430 | ) { |
| 431 | |
| 432 | /* When in UTF-8, we output all non-ascii chars as \x{} |
| 433 | * reqardless of useqq, except for the low ordinal controls on |
| 434 | * EBCDIC platforms */ |
| 435 | k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL)Perl_utf8_to_uvchr_buf_helper( (const U8 *) ((U8*)s),(const U8 *) (U8*) send,((void*)0)); |
| 436 | |
| 437 | /* treat invalid utf8 byte by byte. This loop iteration gets the |
| 438 | * first byte */ |
| 439 | increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)]; |
| 440 | |
| 441 | #if PERL_VERSION32 < 10 |
| 442 | sprintf(r, "\\x{%" UVxf"lx" "}", k); |
| 443 | r += strlen(r); |
| 444 | /* my_sprintf is not supported by ppport.h */ |
| 445 | #else |
| 446 | r = r + my_sprintfsprintf(r, "\\x{%" UVxf"lx" "}", k); |
| 447 | #endif |
| 448 | continue; |
| 449 | } |
| 450 | |
| 451 | /* Here 1) isn't UTF-8; or |
| 452 | * 2) the current character is ASCII; or |
| 453 | * 3) it is an EBCDIC platform and is a low ordinal |
| 454 | * non-ASCII control. |
| 455 | * In each case the character occupies just one byte */ |
| 456 | k = *(U8*)s; |
| 457 | increment = 1; |
| 458 | |
| 459 | if (isPRINT(k)( ( (sizeof(k) == sizeof(U8)) ? ( (((U64) (((((U8) (k)))) - ( ((' ')) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( sizeof(k) == sizeof(U32)) ? ( (((U64) (((((U32) (k)))) - (((' ' )) | 0))) <= (((U64) ((((0x7e) - (' '))) | 0))))) : ( ( (( (U64) (((((U64) (k)))) - (((' ')) | 0))) <= (((U64) ((((0x7e ) - (' '))) | 0))))))))) { |
| 460 | /* These need a backslash escape */ |
| 461 | if (k == '"' || k == '\\' || k == '$' || k == '@') { |
| 462 | *r++ = '\\'; |
| 463 | } |
| 464 | |
| 465 | *r++ = (char)k; |
| 466 | } |
| 467 | else if (! useqq) { /* non-qq, non-printable, low-ordinal is |
| 468 | * output raw */ |
| 469 | *r++ = (char)k; |
| 470 | } |
| 471 | else { /* Is qq means use escape sequences */ |
| 472 | bool_Bool next_is_digit; |
| 473 | |
| 474 | *r++ = '\\'; |
| 475 | switch (k) { |
| 476 | case '\a': *r++ = 'a'; break; |
| 477 | case '\b': *r++ = 'b'; break; |
| 478 | case '\t': *r++ = 't'; break; |
| 479 | case '\n': *r++ = 'n'; break; |
| 480 | case '\f': *r++ = 'f'; break; |
| 481 | case '\r': *r++ = 'r'; break; |
| 482 | case ESC_NATIVE0x1B: *r++ = 'e'; break; |
| 483 | default: |
| 484 | |
| 485 | /* only ASCII digits matter here, which are invariant, |
| 486 | * since we only encode characters \377 and under, or |
| 487 | * \x177 and under for a unicode string |
| 488 | */ |
| 489 | next_is_digit = (s + 1 >= send ) |
| 490 | ? FALSE(0) |
| 491 | : (*(U8*)(s+1) >= '0' && *(U8*)(s+1) <= '9'); |
| 492 | |
| 493 | /* faster than |
| 494 | * r = r + my_sprintf(r, "%o", k); |
| 495 | */ |
| 496 | if (k <= 7 && !next_is_digit) { |
| 497 | *r++ = (char)k + '0'; |
| 498 | } else if (k <= 63 && !next_is_digit) { |
| 499 | *r++ = (char)(k>>3) + '0'; |
| 500 | *r++ = (char)(k&7) + '0'; |
| 501 | } else { |
| 502 | *r++ = (char)(k>>6) + '0'; |
| 503 | *r++ = (char)((k&63)>>3) + '0'; |
| 504 | *r++ = (char)(k&7) + '0'; |
| 505 | } |
| 506 | } |
| 507 | } |
| 508 | } |
| 509 | *r++ = '"'; |
| 510 | } else { |
| 511 | /* Single quotes. */ |
| 512 | sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotesPerl_sv_grow( sv,cur + 3 + 2*backslashes + 2*single_quotes + qq_escapables + normal) |
| 513 | + qq_escapables + normal)Perl_sv_grow( sv,cur + 3 + 2*backslashes + 2*single_quotes + qq_escapables + normal); |
| 514 | rstart = r = SvPVX(sv)((sv)->sv_u.svu_pv) + cur; |
| 515 | *r++ = '\''; |
| 516 | for (s = src; s < send; s ++) { |
| 517 | const char k = *s; |
| 518 | if (k == '\'' || k == '\\') |
| 519 | *r++ = '\\'; |
| 520 | *r++ = k; |
| 521 | } |
| 522 | *r++ = '\''; |
| 523 | } |
| 524 | *r = '\0'; |
| 525 | j = r - rstart; |
| 526 | SvCUR_set(sv, cur + j)do { ((void)0); ((void)0); ((void)0); (((XPV*) (sv)->sv_any )->xpv_cur = (cur + j)); } while (0); |
| 527 | |
| 528 | return j; |
| 529 | } |
| 530 | |
| 531 | /* append a repeated string to an SV */ |
| 532 | static SV * |
| 533 | sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) |
| 534 | { |
| 535 | if (!sv) |
| 536 | sv = newSVpvs("")Perl_newSVpvn( ("" "" ""), (sizeof("")-1)); |
| 537 | #ifdef DEBUGGING |
| 538 | else |
| 539 | assert(SvTYPE(sv) >= SVt_PV)((void)0); |
| 540 | #endif |
| 541 | |
| 542 | if (n > 0) { |
| 543 | SvGROW(sv, len*n + SvCUR(sv) + 1)(((sv)->sv_flags & 0x10000000) || ((XPV*) (sv)->sv_any )->xpv_len_u.xpvlenu_len < (len*n + ((XPV*) (sv)->sv_any )->xpv_cur + 1) ? Perl_sv_grow( sv,len*n + ((XPV*) (sv)-> sv_any)->xpv_cur + 1) : ((sv)->sv_u.svu_pv)); |
| 544 | if (len == 1) { |
| 545 | char * const start = SvPVX(sv)((sv)->sv_u.svu_pv) + SvCUR(sv)((XPV*) (sv)->sv_any)->xpv_cur; |
| 546 | SvCUR_set(sv, SvCUR(sv) + n)do { ((void)0); ((void)0); ((void)0); (((XPV*) (sv)->sv_any )->xpv_cur = (((XPV*) (sv)->sv_any)->xpv_cur + n)); } while (0); |
| 547 | start[n] = '\0'; |
| 548 | while (n > 0) |
| 549 | start[--n] = str[0]; |
| 550 | } |
| 551 | else |
| 552 | while (n > 0) { |
| 553 | sv_catpvn(sv, str, len)Perl_sv_catpvn_flags( sv,str,len,2); |
| 554 | --n; |
| 555 | } |
| 556 | } |
| 557 | return sv; |
| 558 | } |
| 559 | |
| 560 | static SV * |
| 561 | deparsed_output(pTHX_ SV *val) |
| 562 | { |
| 563 | SV *text; |
| 564 | int n; |
| 565 | dSPSV **sp = PL_stack_sp; |
| 566 | |
| 567 | /* This is passed to load_module(), which decrements its ref count and |
| 568 | * modifies it (so we also can't reuse it below) */ |
| 569 | SV *pkg = newSVpvs("B::Deparse")Perl_newSVpvn( ("" "B::Deparse" ""), (sizeof("B::Deparse")-1) ); |
| 570 | |
| 571 | /* Commit ebdc88085efa6fca8a1b0afaa388f0491bdccd5a (first released as part |
| 572 | * of 5.19.7) changed core S_process_special_blocks() to use a new stack |
| 573 | * for anything using a BEGIN block, on the grounds that doing so "avoids |
| 574 | * the stack moving underneath anything that directly or indirectly calls |
| 575 | * Perl_load_module()". If we're in an older Perl, we can't rely on that |
| 576 | * stack, and must create a fresh sacrificial stack of our own. */ |
| 577 | #if PERL_VERSION32 < 20 |
| 578 | PUSHSTACKi(PERLSI_REQUIRE)do { PERL_SI *next = PL_curstackinfo->si_next; if (!next) { next = Perl_new_stackinfo( 32,2048/sizeof(PERL_CONTEXT) - 1) ; next->si_prev = PL_curstackinfo; PL_curstackinfo->si_next = next; } next->si_type = 9; next->si_cxix = -1; next-> si_cxsubix = -1; (void)0; ((XPVAV*) (next->si_stack)->sv_any )->xav_fill = 0; do { ((XPVAV*) (PL_curstack)->sv_any)-> xav_fill = sp - PL_stack_base; PL_stack_base = ((next->si_stack )->sv_u.svu_array); PL_stack_max = PL_stack_base + ((XPVAV *) (next->si_stack)->sv_any)->xav_max; sp = PL_stack_sp = PL_stack_base + ((XPVAV*) (next->si_stack)->sv_any)-> xav_fill; PL_curstack = next->si_stack; } while (0); PL_curstackinfo = next; (void)0; } while (0); |
| 579 | #endif |
| 580 | |
| 581 | load_modulePerl_load_module(PERL_LOADMOD_NOIMPORT0x2, pkg, 0); |
| 582 | |
| 583 | #if PERL_VERSION32 < 20 |
| 584 | POPSTACKdo { SV **sp = PL_stack_sp; PERL_SI * const prev = PL_curstackinfo ->si_prev; if (!prev) { Perl_croak_popstack(); } do { ((XPVAV *) (PL_curstack)->sv_any)->xav_fill = sp - PL_stack_base ; PL_stack_base = ((prev->si_stack)->sv_u.svu_array); PL_stack_max = PL_stack_base + ((XPVAV*) (prev->si_stack)->sv_any)-> xav_max; sp = PL_stack_sp = PL_stack_base + ((XPVAV*) (prev-> si_stack)->sv_any)->xav_fill; PL_curstack = prev->si_stack ; } while (0); PL_curstackinfo = prev; } while (0); |
| 585 | SPAGAINsp = PL_stack_sp; |
| 586 | #endif |
| 587 | |
| 588 | SAVETMPSPerl_savetmps(); |
| 589 | |
| 590 | PUSHMARK(SP)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); |
| 591 | mXPUSHs(newSVpvs("B::Deparse"))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newSVpvn( ("" "B::Deparse" ""), (sizeof("B::Deparse")-1)))); } while (0); |
| 592 | PUTBACKPL_stack_sp = sp; |
| 593 | |
| 594 | n = call_method("new", G_SCALAR)Perl_call_method( "new",2); |
| 595 | SPAGAINsp = PL_stack_sp; |
| 596 | |
| 597 | if (n != 1) { |
| 598 | croakPerl_croak("B::Deparse->new returned %d items, but expected exactly 1", n); |
| 599 | } |
| 600 | |
| 601 | PUSHMARK(SP - n)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp - n) - PL_stack_base); ; } while (0); |
| 602 | XPUSHs(val)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (val); } while (0); |
| 603 | PUTBACKPL_stack_sp = sp; |
| 604 | |
| 605 | n = call_method("coderef2text", G_SCALAR)Perl_call_method( "coderef2text",2); |
| 606 | SPAGAINsp = PL_stack_sp; |
| 607 | |
| 608 | if (n != 1) { |
| 609 | croakPerl_croak("$b_deparse->coderef2text returned %d items, but expected exactly 1", n); |
| 610 | } |
| 611 | |
| 612 | text = POPs(*sp--); |
| 613 | SvREFCNT_inc(text)Perl_SvREFCNT_inc(((SV *)({ void *_p = (text); _p; }))); /* the caller will mortalise this */ |
| 614 | |
| 615 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 616 | |
| 617 | PUTBACKPL_stack_sp = sp; |
| 618 | |
| 619 | return text; |
| 620 | } |
| 621 | |
| 622 | /* |
| 623 | * This ought to be split into smaller functions. (it is one long function since |
| 624 | * it exactly parallels the perl version, which was one long thing for |
| 625 | * efficiency raisins.) Ugggh! |
| 626 | */ |
| 627 | static I32 |
| 628 | DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, |
| 629 | AV *postav, const I32 level, SV *apad, Style *style) |
| 630 | { |
| 631 | char tmpbuf[128]; |
| 632 | Size_tsize_t i; |
| 633 | char *c, *r, *realpack; |
| 634 | #ifdef DD_USE_OLD_ID_FORMAT |
| 635 | char id[128]; |
| 636 | #else |
| 637 | UV id_buffer; |
| 638 | char *const id = (char *)&id_buffer; |
| 639 | #endif |
| 640 | SV **svp; |
| 641 | SV *sv, *ipad, *ival; |
| 642 | SV *blesspad = Nullsv((SV*)((void*)0)); |
| 643 | AV *seenentry = NULL((void*)0); |
| 644 | char *iname; |
| 645 | STRLEN inamelen, idlen = 0; |
| 646 | U32 realtype; |
| 647 | bool_Bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it. |
| 648 | in later perls we should actually check the classname of the |
| 649 | engine. this gets tricky as it involves lexical issues that arent so |
| 650 | easy to resolve */ |
| 651 | bool_Bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */ |
| 652 | |
| 653 | if (!val) |
| 654 | return 0; |
| 655 | |
| 656 | if (style->maxrecursed) |
| 657 | return 0; |
| 658 | |
| 659 | /* If the output buffer has less than some arbitrary amount of space |
| 660 | remaining, then enlarge it. For the test case (25M of output), |
| 661 | *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is |
| 662 | deemed to be good enough. */ |
| 663 | if (SvTYPE(retval)((svtype)((retval)->sv_flags & 0xff)) >= SVt_PV && (SvLEN(retval)((XPV*) (retval)->sv_any)->xpv_len_u.xpvlenu_len - SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur) < 42) { |
| 664 | sv_grow(retval, SvCUR(retval) * 3 / 2)Perl_sv_grow( retval,((XPV*) (retval)->sv_any)->xpv_cur * 3 / 2); |
| 665 | } |
| 666 | |
| 667 | realtype = SvTYPE(val)((svtype)((val)->sv_flags & 0xff)); |
| 668 | |
| 669 | if (SvGMAGICAL(val)((val)->sv_flags & 0x00200000)) |
| 670 | mg_get(val)Perl_mg_get( val); |
| 671 | if (SvROK(val)((val)->sv_flags & 0x00000800)) { |
| 672 | |
| 673 | /* If a freeze method is provided and the object has it, call |
| 674 | it. Warn on errors. */ |
| 675 | if (SvOBJECT(SvRV(val))((((val)->sv_u.svu_rv))->sv_flags & 0x00100000) && style->freezer && |
| 676 | SvPOK(style->freezer)((style->freezer)->sv_flags & 0x00000400) && SvCUR(style->freezer)((XPV*) (style->freezer)->sv_any)->xpv_cur && |
| 677 | gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(style->freezer),Perl_gv_fetchmeth_pvn( ((XPVMG*) (((val)->sv_u.svu_rv))-> sv_any)->xmg_stash,((const char*)(0 + (style->freezer)-> sv_u.svu_pv)),((XPV*) (style->freezer)->sv_any)->xpv_cur ,-1,0) |
| 678 | SvCUR(style->freezer), -1)Perl_gv_fetchmeth_pvn( ((XPVMG*) (((val)->sv_u.svu_rv))-> sv_any)->xmg_stash,((const char*)(0 + (style->freezer)-> sv_u.svu_pv)),((XPV*) (style->freezer)->sv_any)->xpv_cur ,-1,0) != NULL((void*)0)) |
| 679 | { |
| 680 | dSPSV **sp = PL_stack_sp; ENTERPerl_push_scope(); SAVETMPSPerl_savetmps(); PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); |
| 681 | XPUSHs(val)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (val); } while (0); PUTBACKPL_stack_sp = sp; |
| 682 | i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD)Perl_call_method( ((const char*)(0 + (style->freezer)-> sv_u.svu_pv)),0x8|1|0x4); |
Value stored to 'i' is never read | |
| 683 | SPAGAINsp = PL_stack_sp; |
| 684 | if (SvTRUE(ERRSV)Perl_SvTRUE( (*((0+(PL_errgv)->sv_u.svu_gp)->gp_sv ? & ((0+(PL_errgv)->sv_u.svu_gp)->gp_sv) : &((0+(Perl_gv_add_by_type ( (PL_errgv),SVt_NULL))->sv_u.svu_gp)->gp_sv))))) |
| 685 | warnPerl_warn("WARNING(Freezer method call failed): %" SVf"-p", ERRSV(*((0+(PL_errgv)->sv_u.svu_gp)->gp_sv ? &((0+(PL_errgv )->sv_u.svu_gp)->gp_sv) : &((0+(Perl_gv_add_by_type ( (PL_errgv),SVt_NULL))->sv_u.svu_gp)->gp_sv)))); |
| 686 | PUTBACKPL_stack_sp = sp; FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); LEAVEPerl_pop_scope(); |
| 687 | } |
| 688 | |
| 689 | ival = SvRV(val)((val)->sv_u.svu_rv); |
| 690 | realtype = SvTYPE(ival)((svtype)((ival)->sv_flags & 0xff)); |
| 691 | #ifdef DD_USE_OLD_ID_FORMAT |
| 692 | idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(ival))({ int len = snprintf(id, sizeof(id), "0x%" "lx", (UV)(ival)) ; do { if ((sizeof(id)) > 0 && (size_t)len > (sizeof (id))) Perl_croak("panic: %s buffer overflow", "snprintf"); } while (0); len; }); |
| 693 | #else |
| 694 | id_buffer = PTR2UV(ival)(UV)(ival); |
| 695 | idlen = sizeof(id_buffer); |
| 696 | #endif |
| 697 | if (SvOBJECT(ival)((ival)->sv_flags & 0x00100000)) |
| 698 | realpack = HvNAME_get(SvSTASH(ival))((((((XPVMG*) (ival)->sv_any)->xmg_stash)->sv_flags & 0x02000000) && ((struct xpvhv_aux*)&(((((XPVMG*) (ival)->sv_any)->xmg_stash)->sv_u.svu_hash)[((XPVHV *) (((XPVMG*) (ival)->sv_any)->xmg_stash)->sv_any)-> xhv_max+1]))->xhv_name_u.xhvnameu_name && ( ((struct xpvhv_aux*)&(((((XPVMG*) (ival)->sv_any)->xmg_stash )->sv_u.svu_hash)[((XPVHV*) (((XPVMG*) (ival)->sv_any)-> xmg_stash)->sv_any)->xhv_max+1]))->xhv_name_count ? * ((struct xpvhv_aux*)&(((((XPVMG*) (ival)->sv_any)-> xmg_stash)->sv_u.svu_hash)[((XPVHV*) (((XPVMG*) (ival)-> sv_any)->xmg_stash)->sv_any)->xhv_max+1]))->xhv_name_u .xhvnameu_names : ((struct xpvhv_aux*)&(((((XPVMG*) (ival )->sv_any)->xmg_stash)->sv_u.svu_hash)[((XPVHV*) ((( XPVMG*) (ival)->sv_any)->xmg_stash)->sv_any)->xhv_max +1]))->xhv_name_u.xhvnameu_name )) ? (( ((struct xpvhv_aux *)&(((((XPVMG*) (ival)->sv_any)->xmg_stash)->sv_u .svu_hash)[((XPVHV*) (((XPVMG*) (ival)->sv_any)->xmg_stash )->sv_any)->xhv_max+1]))->xhv_name_count ? *((struct xpvhv_aux*)&(((((XPVMG*) (ival)->sv_any)->xmg_stash )->sv_u.svu_hash)[((XPVHV*) (((XPVMG*) (ival)->sv_any)-> xmg_stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_names : ((struct xpvhv_aux*)&(((((XPVMG*) (ival)->sv_any)-> xmg_stash)->sv_u.svu_hash)[((XPVHV*) (((XPVMG*) (ival)-> sv_any)->xmg_stash)->sv_any)->xhv_max+1]))->xhv_name_u .xhvnameu_name ))->hek_key : ((void*)0)); |
| 699 | else |
| 700 | realpack = NULL((void*)0); |
| 701 | |
| 702 | /* if it has a name, we need to either look it up, or keep a tab |
| 703 | * on it so we know when we hit it later |
| 704 | */ |
| 705 | if (namelen) { |
| 706 | if ((svp = hv_fetch(seenhv, id, idlen, FALSE)((SV**) Perl_hv_common_key_len( (seenhv),(id),(idlen),((0)) ? (0x20 | 0x10) : 0x20,((void*)0),0))) |
| 707 | && (sv = *svp) && SvROK(sv)((sv)->sv_flags & 0x00000800) && (seenentry = (AV*)SvRV(sv)((sv)->sv_u.svu_rv))) |
| 708 | { |
| 709 | SV *othername; |
| 710 | if ((svp = av_fetch(seenentry, 0, FALSE)Perl_av_fetch( seenentry,0,(0))) |
| 711 | && (othername = *svp)) |
| 712 | { |
| 713 | if (style->purity && level > 0) { |
| 714 | SV *postentry; |
| 715 | |
| 716 | if (realtype == SVt_PVHV) |
| 717 | sv_catpvs(retval, "{}")Perl_sv_catpvn_flags( retval, ("" "{}" ""), (sizeof("{}")-1), 2); |
| 718 | else if (realtype == SVt_PVAV) |
| 719 | sv_catpvs(retval, "[]")Perl_sv_catpvn_flags( retval, ("" "[]" ""), (sizeof("[]")-1), 2); |
| 720 | else |
| 721 | sv_catpvs(retval, "do{my $o}")Perl_sv_catpvn_flags( retval, ("" "do{my $o}" ""), (sizeof("do{my $o}" )-1), 2); |
| 722 | postentry = newSVpvn(name, namelen)Perl_newSVpvn( name,namelen); |
| 723 | sv_catpvs(postentry, " = ")Perl_sv_catpvn_flags( postentry, ("" " = " ""), (sizeof(" = " )-1), 2); |
| 724 | sv_catsv(postentry, othername)Perl_sv_catsv_flags( postentry,othername,2); |
| 725 | av_push(postav, postentry)Perl_av_push( postav,postentry); |
| 726 | } |
| 727 | else { |
| 728 | if (name[0] == '@' || name[0] == '%') { |
| 729 | if ((SvPVX_const(othername)((const char*)(0 + (othername)->sv_u.svu_pv)))[0] == '\\' && |
| 730 | (SvPVX_const(othername)((const char*)(0 + (othername)->sv_u.svu_pv)))[1] == name[0]) { |
| 731 | sv_catpvn(retval, SvPVX_const(othername)+1,Perl_sv_catpvn_flags( retval,((const char*)(0 + (othername)-> sv_u.svu_pv))+1,((XPV*) (othername)->sv_any)->xpv_cur-1 ,2) |
| 732 | SvCUR(othername)-1)Perl_sv_catpvn_flags( retval,((const char*)(0 + (othername)-> sv_u.svu_pv))+1,((XPV*) (othername)->sv_any)->xpv_cur-1 ,2); |
| 733 | } |
| 734 | else { |
| 735 | sv_catpvn(retval, name, 1)Perl_sv_catpvn_flags( retval,name,1,2); |
| 736 | sv_catpvs(retval, "{")Perl_sv_catpvn_flags( retval, ("" "{" ""), (sizeof("{")-1), 2 ); |
| 737 | sv_catsv(retval, othername)Perl_sv_catsv_flags( retval,othername,2); |
| 738 | sv_catpvs(retval, "}")Perl_sv_catpvn_flags( retval, ("" "}" ""), (sizeof("}")-1), 2 ); |
| 739 | } |
| 740 | } |
| 741 | else |
| 742 | sv_catsv(retval, othername)Perl_sv_catsv_flags( retval,othername,2); |
| 743 | } |
| 744 | return 1; |
| 745 | } |
| 746 | else { |
| 747 | #ifdef DD_USE_OLD_ID_FORMAT |
| 748 | warnPerl_warn("ref name not found for %s", id); |
| 749 | #else |
| 750 | warnPerl_warn("ref name not found for 0x%" UVxf"lx", PTR2UV(ival)(UV)(ival)); |
| 751 | #endif |
| 752 | return 0; |
| 753 | } |
| 754 | } |
| 755 | else { /* store our name and continue */ |
| 756 | SV *namesv; |
| 757 | if (name[0] == '@' || name[0] == '%') { |
| 758 | namesv = newSVpvs("\\")Perl_newSVpvn( ("" "\\" ""), (sizeof("\\")-1)); |
| 759 | sv_catpvn(namesv, name, namelen)Perl_sv_catpvn_flags( namesv,name,namelen,2); |
| 760 | } |
| 761 | else if (realtype == SVt_PVCV && name[0] == '*') { |
| 762 | namesv = newSVpvs("\\")Perl_newSVpvn( ("" "\\" ""), (sizeof("\\")-1)); |
| 763 | sv_catpvn(namesv, name, namelen)Perl_sv_catpvn_flags( namesv,name,namelen,2); |
| 764 | (SvPVX(namesv)((namesv)->sv_u.svu_pv))[1] = '&'; |
| 765 | } |
| 766 | else |
| 767 | namesv = newSVpvn(name, namelen)Perl_newSVpvn( name,namelen); |
| 768 | seenentry = newAV()((AV *)({ void *_p = (Perl_newSV_type( SVt_PVAV)); _p; })); |
| 769 | av_push(seenentry, namesv)Perl_av_push( seenentry,namesv); |
| 770 | (void)SvREFCNT_inc(val)Perl_SvREFCNT_inc(((SV *)({ void *_p = (val); _p; }))); |
| 771 | av_push(seenentry, val)Perl_av_push( seenentry,val); |
| 772 | (void)hv_store(seenhv, id, idlen,((SV**) Perl_hv_common_key_len( (seenhv),(id),(idlen),(0x04|0x20 ),(Perl_newRV( (SV*)seenentry)),(0))) |
| 773 | newRV_inc((SV*)seenentry), 0)((SV**) Perl_hv_common_key_len( (seenhv),(id),(idlen),(0x04|0x20 ),(Perl_newRV( (SV*)seenentry)),(0))); |
| 774 | SvREFCNT_dec(seenentry)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (seenentry); _p; }))); |
| 775 | } |
| 776 | } |
| 777 | /* regexps dont have to be blessed into package "Regexp" |
| 778 | * they can be blessed into any package. |
| 779 | */ |
| 780 | #if PERL_VERSION32 < 8 |
| 781 | if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")(strcmp(realpack,"Regexp") == 0)) |
| 782 | #elif PERL_VERSION32 < 11 |
| 783 | if (realpack && realtype == SVt_PVMG && mg_findPerl_mg_find(ival, PERL_MAGIC_qr'r')) |
| 784 | #else |
| 785 | if (realpack && realtype == SVt_REGEXP) |
| 786 | #endif |
| 787 | { |
| 788 | is_regex = 1; |
| 789 | if (strEQ(realpack, "Regexp")(strcmp(realpack,"Regexp") == 0)) |
| 790 | no_bless = 1; |
| 791 | else |
| 792 | no_bless = 0; |
| 793 | } |
| 794 | |
| 795 | /* If purity is not set and maxdepth is set, then check depth: |
| 796 | * if we have reached maximum depth, return the string |
| 797 | * representation of the thing we are currently examining |
| 798 | * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). |
| 799 | */ |
| 800 | if (!style->purity && style->maxdepth > 0 && level >= style->maxdepth) { |
| 801 | STRLEN vallen; |
| 802 | const char * const valstr = SvPV(val,vallen)((((val)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((vallen = ((XPV*) (val)->sv_any)->xpv_cur), ((val) ->sv_u.svu_pv)) : Perl_sv_2pv_flags( val,&vallen,2)); |
| 803 | sv_catpvs(retval, "'")Perl_sv_catpvn_flags( retval, ("" "'" ""), (sizeof("'")-1), 2 ); |
| 804 | sv_catpvn(retval, valstr, vallen)Perl_sv_catpvn_flags( retval,valstr,vallen,2); |
| 805 | sv_catpvs(retval, "'")Perl_sv_catpvn_flags( retval, ("" "'" ""), (sizeof("'")-1), 2 ); |
| 806 | return 1; |
| 807 | } |
| 808 | |
| 809 | if (style->maxrecurse > 0 && level >= style->maxrecurse) { |
| 810 | style->maxrecursed = TRUE(1); |
| 811 | } |
| 812 | |
| 813 | if (realpack && !no_bless) { /* we have a blessed ref */ |
| 814 | STRLEN blesslen; |
| 815 | const char * const blessstr = SvPV(style->bless, blesslen)((((style->bless)->sv_flags & (0x00000400|0x00200000 )) == 0x00000400) ? ((blesslen = ((XPV*) (style->bless)-> sv_any)->xpv_cur), ((style->bless)->sv_u.svu_pv)) : Perl_sv_2pv_flags ( style->bless,&blesslen,2)); |
| 816 | sv_catpvn(retval, blessstr, blesslen)Perl_sv_catpvn_flags( retval,blessstr,blesslen,2); |
| 817 | sv_catpvs(retval, "( ")Perl_sv_catpvn_flags( retval, ("" "( " ""), (sizeof("( ")-1), 2); |
| 818 | if (style->indent >= 2) { |
| 819 | blesspad = apad; |
| 820 | apad = sv_2mortal(newSVsv(apad))Perl_sv_2mortal( Perl_newSVsv_flags( (apad),2|16)); |
| 821 | sv_x(aTHX_ apad, " ", 1, blesslen+2); |
| 822 | } |
| 823 | } |
| 824 | |
| 825 | ipad = sv_x(aTHX_ Nullsv((SV*)((void*)0)), SvPVX_const(style->xpad)((const char*)(0 + (style->xpad)->sv_u.svu_pv)), SvCUR(style->xpad)((XPV*) (style->xpad)->sv_any)->xpv_cur, level+1); |
| 826 | sv_2mortal(ipad)Perl_sv_2mortal( ipad); |
| 827 | |
| 828 | if (is_regex) |
| 829 | { |
| 830 | STRLEN rlen; |
| 831 | SV *sv_pattern = NULL((void*)0); |
| 832 | SV *sv_flags = NULL((void*)0); |
| 833 | CV *re_pattern_cv; |
| 834 | const char *rval; |
| 835 | const char *rend; |
| 836 | const char *slash; |
| 837 | |
| 838 | if ((re_pattern_cv = get_cv("re::regexp_pattern", 0)Perl_get_cv( "re::regexp_pattern",0))) { |
| 839 | dSPSV **sp = PL_stack_sp; |
| 840 | I32 count; |
| 841 | ENTERPerl_push_scope(); |
| 842 | SAVETMPSPerl_savetmps(); |
| 843 | PUSHMARK(SP)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); |
| 844 | XPUSHs(val)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (val); } while (0); |
| 845 | PUTBACKPL_stack_sp = sp; |
| 846 | count = call_sv((SV*)re_pattern_cv, G_ARRAY)Perl_call_sv( (SV*)re_pattern_cv,3); |
| 847 | SPAGAINsp = PL_stack_sp; |
| 848 | if (count >= 2) { |
| 849 | sv_flags = POPs(*sp--); |
| 850 | sv_pattern = POPs(*sp--); |
| 851 | SvREFCNT_inc(sv_flags)Perl_SvREFCNT_inc(((SV *)({ void *_p = (sv_flags); _p; }))); |
| 852 | SvREFCNT_inc(sv_pattern)Perl_SvREFCNT_inc(((SV *)({ void *_p = (sv_pattern); _p; }))); |
| 853 | } |
| 854 | PUTBACKPL_stack_sp = sp; |
| 855 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 856 | LEAVEPerl_pop_scope(); |
| 857 | if (sv_pattern) { |
| 858 | sv_2mortal(sv_pattern)Perl_sv_2mortal( sv_pattern); |
| 859 | sv_2mortal(sv_flags)Perl_sv_2mortal( sv_flags); |
| 860 | } |
| 861 | } |
| 862 | else { |
| 863 | sv_pattern = val; |
| 864 | } |
| 865 | assert(sv_pattern)((void)0); |
| 866 | rval = SvPV(sv_pattern, rlen)((((sv_pattern)->sv_flags & (0x00000400|0x00200000)) == 0x00000400) ? ((rlen = ((XPV*) (sv_pattern)->sv_any)-> xpv_cur), ((sv_pattern)->sv_u.svu_pv)) : Perl_sv_2pv_flags ( sv_pattern,&rlen,2)); |
| 867 | rend = rval+rlen; |
| 868 | slash = rval; |
| 869 | sv_catpvs(retval, "qr/")Perl_sv_catpvn_flags( retval, ("" "qr/" ""), (sizeof("qr/")-1 ), 2); |
| 870 | for (;slash < rend; slash++) { |
| 871 | if (*slash == '\\') { ++slash; continue; } |
| 872 | if (*slash == '/') { |
| 873 | sv_catpvn(retval, rval, slash-rval)Perl_sv_catpvn_flags( retval,rval,slash-rval,2); |
| 874 | sv_catpvs(retval, "\\/")Perl_sv_catpvn_flags( retval, ("" "\\/" ""), (sizeof("\\/")-1 ), 2); |
| 875 | rlen -= slash-rval+1; |
| 876 | rval = slash+1; |
| 877 | } |
| 878 | } |
| 879 | sv_catpvn(retval, rval, rlen)Perl_sv_catpvn_flags( retval,rval,rlen,2); |
| 880 | sv_catpvs(retval, "/")Perl_sv_catpvn_flags( retval, ("" "/" ""), (sizeof("/")-1), 2 ); |
| 881 | if (sv_flags) |
| 882 | sv_catsv(retval, sv_flags)Perl_sv_catsv_flags( retval,sv_flags,2); |
| 883 | } |
| 884 | else if ( |
| 885 | #if PERL_VERSION32 < 9 |
| 886 | realtype <= SVt_PVBMSVt_PVMG |
| 887 | #else |
| 888 | realtype <= SVt_PVMG |
| 889 | #endif |
| 890 | ) { /* scalar ref */ |
| 891 | SV * const namesv = sv_2mortal(newSVpvs("${"))Perl_sv_2mortal( Perl_newSVpvn( ("" "${" ""), (sizeof("${")-1 ))); |
| 892 | sv_catpvn(namesv, name, namelen)Perl_sv_catpvn_flags( namesv,name,namelen,2); |
| 893 | sv_catpvs(namesv, "}")Perl_sv_catpvn_flags( namesv, ("" "}" ""), (sizeof("}")-1), 2 ); |
| 894 | if (realpack) { /* blessed */ |
| 895 | sv_catpvs(retval, "do{\\(my $o = ")Perl_sv_catpvn_flags( retval, ("" "do{\\(my $o = " ""), (sizeof ("do{\\(my $o = ")-1), 2); |
| 896 | DD_dump(aTHX_ ival, SvPVX_const(namesv)((const char*)(0 + (namesv)->sv_u.svu_pv)), SvCUR(namesv)((XPV*) (namesv)->sv_any)->xpv_cur, retval, seenhv, |
| 897 | postav, level+1, apad, style); |
| 898 | sv_catpvs(retval, ")}")Perl_sv_catpvn_flags( retval, ("" ")}" ""), (sizeof(")}")-1), 2); |
| 899 | } /* plain */ |
| 900 | else { |
| 901 | sv_catpvs(retval, "\\")Perl_sv_catpvn_flags( retval, ("" "\\" ""), (sizeof("\\")-1), 2); |
| 902 | DD_dump(aTHX_ ival, SvPVX_const(namesv)((const char*)(0 + (namesv)->sv_u.svu_pv)), SvCUR(namesv)((XPV*) (namesv)->sv_any)->xpv_cur, retval, seenhv, |
| 903 | postav, level+1, apad, style); |
| 904 | } |
| 905 | } |
| 906 | else if (realtype == SVt_PVGV) { /* glob ref */ |
| 907 | SV * const namesv = newSVpvs("*{")Perl_newSVpvn( ("" "*{" ""), (sizeof("*{")-1)); |
| 908 | sv_catpvn(namesv, name, namelen)Perl_sv_catpvn_flags( namesv,name,namelen,2); |
| 909 | sv_catpvs(namesv, "}")Perl_sv_catpvn_flags( namesv, ("" "}" ""), (sizeof("}")-1), 2 ); |
| 910 | sv_catpvs(retval, "\\")Perl_sv_catpvn_flags( retval, ("" "\\" ""), (sizeof("\\")-1), 2); |
| 911 | DD_dump(aTHX_ ival, SvPVX_const(namesv)((const char*)(0 + (namesv)->sv_u.svu_pv)), SvCUR(namesv)((XPV*) (namesv)->sv_any)->xpv_cur, retval, seenhv, |
| 912 | postav, level+1, apad, style); |
| 913 | SvREFCNT_dec(namesv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (namesv); _p; }))); |
| 914 | } |
| 915 | else if (realtype == SVt_PVAV) { |
| 916 | SV *totpad; |
| 917 | SSize_tssize_t ix = 0; |
| 918 | const SSize_tssize_t ixmax = av_len((AV *)ival)Perl_av_len( (AV *)ival); |
| 919 | |
| 920 | SV * const ixsv = sv_2mortal(newSViv(0))Perl_sv_2mortal( Perl_newSViv( 0)); |
| 921 | /* allowing for a 24 char wide array index */ |
| 922 | New(0, iname, namelen+28, char)(iname = ((void)(__builtin_expect(((((( sizeof(size_t) < sizeof (namelen+28) || sizeof(char) > ((size_t)1 << 8*(sizeof (size_t) - sizeof(namelen+28)))) ? (size_t)(namelen+28) : ((size_t )-1)/sizeof(char)) > ((size_t)-1)/sizeof(char))) ? (_Bool) 1 : (_Bool)0),(0)) && (Perl_croak_memory_wrap(),0)), ( char*)(Perl_safesysmalloc((size_t)((namelen+28)*sizeof(char)) )))); |
| 923 | SAVEFREEPV(iname)Perl_save_pushptr( (void *)((char*)(iname)),10); |
| 924 | (void) strlcpy(iname, name, namelen+28)strlcpy(iname,name,namelen+28); |
| 925 | inamelen = namelen; |
| 926 | if (name[0] == '@') { |
| 927 | sv_catpvs(retval, "(")Perl_sv_catpvn_flags( retval, ("" "(" ""), (sizeof("(")-1), 2 ); |
| 928 | iname[0] = '$'; |
| 929 | } |
| 930 | else { |
| 931 | sv_catpvs(retval, "[")Perl_sv_catpvn_flags( retval, ("" "[" ""), (sizeof("[")-1), 2 ); |
| 932 | /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ |
| 933 | /*if (namelen > 0 |
| 934 | && name[namelen-1] != ']' && name[namelen-1] != '}' |
| 935 | && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ |
| 936 | if ((namelen > 0 |
| 937 | && name[namelen-1] != ']' && name[namelen-1] != '}') |
| 938 | || (namelen > 4 |
| 939 | && (name[1] == '{' |
| 940 | || (name[0] == '\\' && name[2] == '{')))) |
| 941 | { |
| 942 | iname[inamelen++] = '-'; iname[inamelen++] = '>'; |
| 943 | iname[inamelen] = '\0'; |
| 944 | } |
| 945 | } |
| 946 | if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && |
| 947 | (instr(iname+inamelen-8, "{SCALAR}")strstr(iname+inamelen-8, "{SCALAR}") || |
| 948 | instr(iname+inamelen-7, "{ARRAY}")strstr(iname+inamelen-7, "{ARRAY}") || |
| 949 | instr(iname+inamelen-6, "{HASH}")strstr(iname+inamelen-6, "{HASH}"))) { |
| 950 | iname[inamelen++] = '-'; iname[inamelen++] = '>'; |
| 951 | } |
| 952 | iname[inamelen++] = '['; iname[inamelen] = '\0'; |
| 953 | totpad = sv_2mortal(newSVsv(style->sep))Perl_sv_2mortal( Perl_newSVsv_flags( (style->sep),2|16)); |
| 954 | sv_catsv(totpad, style->pad)Perl_sv_catsv_flags( totpad,style->pad,2); |
| 955 | sv_catsv(totpad, apad)Perl_sv_catsv_flags( totpad,apad,2); |
| 956 | |
| 957 | for (ix = 0; ix <= ixmax; ++ix) { |
| 958 | STRLEN ilen; |
| 959 | SV *elem; |
| 960 | svp = av_fetch((AV*)ival, ix, FALSE)Perl_av_fetch( (AV*)ival,ix,(0)); |
| 961 | if (svp) |
| 962 | elem = *svp; |
| 963 | else |
| 964 | elem = &PL_sv_undef(PL_sv_immortals[1]); |
| 965 | |
| 966 | ilen = inamelen; |
| 967 | sv_setiv(ixsv, ix)Perl_sv_setiv( ixsv,ix); |
| 968 | #if PERL_VERSION32 < 10 |
| 969 | (void) sprintf(iname+ilen, "%" IVdf"ld", (IV)ix); |
| 970 | ilen = strlen(iname); |
| 971 | #else |
| 972 | ilen = ilen + my_sprintfsprintf(iname+ilen, "%" IVdf"ld", (IV)ix); |
| 973 | #endif |
| 974 | iname[ilen++] = ']'; iname[ilen] = '\0'; |
| 975 | if (style->indent >= 3) { |
| 976 | sv_catsv(retval, totpad)Perl_sv_catsv_flags( retval,totpad,2); |
| 977 | sv_catsv(retval, ipad)Perl_sv_catsv_flags( retval,ipad,2); |
| 978 | sv_catpvs(retval, "#")Perl_sv_catpvn_flags( retval, ("" "#" ""), (sizeof("#")-1), 2 ); |
| 979 | sv_catsv(retval, ixsv)Perl_sv_catsv_flags( retval,ixsv,2); |
| 980 | } |
| 981 | sv_catsv(retval, totpad)Perl_sv_catsv_flags( retval,totpad,2); |
| 982 | sv_catsv(retval, ipad)Perl_sv_catsv_flags( retval,ipad,2); |
| 983 | ENTERPerl_push_scope(); |
| 984 | SAVETMPSPerl_savetmps(); |
| 985 | DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, |
| 986 | level+1, apad, style); |
| 987 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 988 | LEAVEPerl_pop_scope(); |
| 989 | if (ix < ixmax || (style->trailingcomma && style->indent >= 1)) |
| 990 | sv_catpvs(retval, ",")Perl_sv_catpvn_flags( retval, ("" "," ""), (sizeof(",")-1), 2 ); |
| 991 | } |
| 992 | if (ixmax >= 0) { |
| 993 | SV * const opad = sv_x(aTHX_ Nullsv((SV*)((void*)0)), SvPVX_const(style->xpad)((const char*)(0 + (style->xpad)->sv_u.svu_pv)), SvCUR(style->xpad)((XPV*) (style->xpad)->sv_any)->xpv_cur, level); |
| 994 | sv_catsv(retval, totpad)Perl_sv_catsv_flags( retval,totpad,2); |
| 995 | sv_catsv(retval, opad)Perl_sv_catsv_flags( retval,opad,2); |
| 996 | SvREFCNT_dec(opad)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (opad); _p; }))); |
| 997 | } |
| 998 | if (name[0] == '@') |
| 999 | sv_catpvs(retval, ")")Perl_sv_catpvn_flags( retval, ("" ")" ""), (sizeof(")")-1), 2 ); |
| 1000 | else |
| 1001 | sv_catpvs(retval, "]")Perl_sv_catpvn_flags( retval, ("" "]" ""), (sizeof("]")-1), 2 ); |
| 1002 | } |
| 1003 | else if (realtype == SVt_PVHV) { |
| 1004 | SV *totpad, *newapad; |
| 1005 | SV *sname; |
| 1006 | HE *entry = NULL((void*)0); |
| 1007 | char *key; |
| 1008 | SV *hval; |
| 1009 | AV *keys = NULL((void*)0); |
| 1010 | |
| 1011 | SV * const iname = newSVpvn_flags(name, namelen, SVs_TEMP)Perl_newSVpvn_flags( name,namelen,0x00080000); |
| 1012 | if (name[0] == '%') { |
| 1013 | sv_catpvs(retval, "(")Perl_sv_catpvn_flags( retval, ("" "(" ""), (sizeof("(")-1), 2 ); |
| 1014 | (SvPVX(iname)((iname)->sv_u.svu_pv))[0] = '$'; |
| 1015 | } |
| 1016 | else { |
| 1017 | sv_catpvs(retval, "{")Perl_sv_catpvn_flags( retval, ("" "{" ""), (sizeof("{")-1), 2 ); |
| 1018 | /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ |
| 1019 | if ((namelen > 0 |
| 1020 | && name[namelen-1] != ']' && name[namelen-1] != '}') |
| 1021 | || (namelen > 4 |
| 1022 | && (name[1] == '{' |
| 1023 | || (name[0] == '\\' && name[2] == '{')))) |
| 1024 | { |
| 1025 | sv_catpvs(iname, "->")Perl_sv_catpvn_flags( iname, ("" "->" ""), (sizeof("->" )-1), 2); |
| 1026 | } |
| 1027 | } |
| 1028 | if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && |
| 1029 | (instr(name+namelen-8, "{SCALAR}")strstr(name+namelen-8, "{SCALAR}") || |
| 1030 | instr(name+namelen-7, "{ARRAY}")strstr(name+namelen-7, "{ARRAY}") || |
| 1031 | instr(name+namelen-6, "{HASH}")strstr(name+namelen-6, "{HASH}"))) { |
| 1032 | sv_catpvs(iname, "->")Perl_sv_catpvn_flags( iname, ("" "->" ""), (sizeof("->" )-1), 2); |
| 1033 | } |
| 1034 | sv_catpvs(iname, "{")Perl_sv_catpvn_flags( iname, ("" "{" ""), (sizeof("{")-1), 2); |
| 1035 | totpad = sv_2mortal(newSVsv(style->sep))Perl_sv_2mortal( Perl_newSVsv_flags( (style->sep),2|16)); |
| 1036 | sv_catsv(totpad, style->pad)Perl_sv_catsv_flags( totpad,style->pad,2); |
| 1037 | sv_catsv(totpad, apad)Perl_sv_catsv_flags( totpad,apad,2); |
| 1038 | |
| 1039 | /* If requested, get a sorted/filtered array of hash keys */ |
| 1040 | if (style->sortkeys) { |
| 1041 | #if PERL_VERSION32 >= 8 |
| 1042 | if (style->sortkeys == &PL_sv_yes(PL_sv_immortals[0])) { |
| 1043 | keys = newAV()((AV *)({ void *_p = (Perl_newSV_type( SVt_PVAV)); _p; })); |
| 1044 | (void)hv_iterinit((HV*)ival)Perl_hv_iterinit( (HV*)ival); |
| 1045 | while ((entry = hv_iternext((HV*)ival)Perl_hv_iternext_flags( (HV*)ival,0))) { |
| 1046 | sv = hv_iterkeysv(entry)Perl_hv_iterkeysv( entry); |
| 1047 | (void)SvREFCNT_inc(sv)Perl_SvREFCNT_inc(((SV *)({ void *_p = (sv); _p; }))); |
| 1048 | av_push(keys, sv)Perl_av_push( keys,sv); |
| 1049 | } |
| 1050 | # ifdef USE_LOCALE_COLLATE |
| 1051 | # ifdef IN_LC /* Use this if available */ |
| 1052 | if (IN_LC(LC_COLLATE)(( ((PL_compiling.cop_hints & 0x00000004) ? (_Bool)1 : (_Bool )0) || ( ((PL_compiling.cop_hints & 0x00000010) ? (_Bool) 1 : (_Bool)0) && Perl__is_in_locale_category( (1), (1 )))) || ((PL_curcop && ((PL_curcop)->cop_hints + 0 ) & 0x00000004) || ((PL_curcop && ((PL_curcop)-> cop_hints + 0) & 0x00000010) && Perl__is_in_locale_category ( (0), (1)))))) |
| 1053 | # else |
| 1054 | if (IN_LOCALE(((PL_curcop == &PL_compiling) ? (_Bool)1 : (_Bool)0) ? ( (PL_compiling.cop_hints & 0x00000004) ? (_Bool)1 : (_Bool )0) : (PL_curcop && ((PL_curcop)->cop_hints + 0) & 0x00000004))) |
| 1055 | # endif |
| 1056 | { |
| 1057 | sortsv(AvARRAY(keys),Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp_locale) |
| 1058 | av_len(keys)+1,Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp_locale) |
| 1059 | Perl_sv_cmp_locale)Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp_locale); |
| 1060 | } |
| 1061 | else |
| 1062 | # endif |
| 1063 | { |
| 1064 | sortsv(AvARRAY(keys),Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp) |
| 1065 | av_len(keys)+1,Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp) |
| 1066 | Perl_sv_cmp)Perl_sortsv( ((keys)->sv_u.svu_array),Perl_av_len( keys)+1 ,Perl_sv_cmp); |
| 1067 | } |
| 1068 | } |
| 1069 | else |
| 1070 | #endif |
| 1071 | { |
| 1072 | dSPSV **sp = PL_stack_sp; ENTERPerl_push_scope(); SAVETMPSPerl_savetmps(); PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); |
| 1073 | XPUSHs(sv_2mortal(newRV_inc(ival)))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newRV( ival))); } while (0); PUTBACKPL_stack_sp = sp; |
| 1074 | i = perl_call_sv(style->sortkeys, G_SCALAR | G_EVAL)Perl_call_sv( style->sortkeys,2 | 0x8); |
| 1075 | SPAGAINsp = PL_stack_sp; |
| 1076 | if (i) { |
| 1077 | sv = POPs(*sp--); |
| 1078 | if (SvROK(sv)((sv)->sv_flags & 0x00000800) && (SvTYPE(SvRV(sv))((svtype)((((sv)->sv_u.svu_rv))->sv_flags & 0xff)) == SVt_PVAV)) |
| 1079 | keys = (AV*)SvREFCNT_inc(SvRV(sv))Perl_SvREFCNT_inc(((SV *)({ void *_p = (((sv)->sv_u.svu_rv )); _p; }))); |
| 1080 | } |
| 1081 | if (! keys) |
| 1082 | warnPerl_warn("Sortkeys subroutine did not return ARRAYREF\n"); |
| 1083 | PUTBACKPL_stack_sp = sp; FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); LEAVEPerl_pop_scope(); |
| 1084 | } |
| 1085 | if (keys) |
| 1086 | sv_2mortal((SV*)keys)Perl_sv_2mortal( (SV*)keys); |
| 1087 | } |
| 1088 | else |
| 1089 | (void)hv_iterinit((HV*)ival)Perl_hv_iterinit( (HV*)ival); |
| 1090 | |
| 1091 | /* foreach (keys %hash) */ |
| 1092 | for (i = 0; 1; i++) { |
| 1093 | char *nkey; |
| 1094 | char *nkey_buffer = NULL((void*)0); |
| 1095 | STRLEN nticks = 0; |
| 1096 | SV* keysv; |
| 1097 | STRLEN klen; |
| 1098 | STRLEN keylen; |
| 1099 | STRLEN nlen; |
| 1100 | bool_Bool do_utf8 = FALSE(0); |
| 1101 | |
| 1102 | if (style->sortkeys) { |
| 1103 | if (!(keys && (SSize_tssize_t)i <= av_len(keys)Perl_av_len( keys))) break; |
| 1104 | } else { |
| 1105 | if (!(entry = hv_iternext((HV *)ival)Perl_hv_iternext_flags( (HV *)ival,0))) break; |
| 1106 | } |
| 1107 | |
| 1108 | if (i) |
| 1109 | sv_catpvs(retval, ",")Perl_sv_catpvn_flags( retval, ("" "," ""), (sizeof(",")-1), 2 ); |
| 1110 | |
| 1111 | if (style->sortkeys) { |
| 1112 | char *key; |
| 1113 | svp = av_fetch(keys, i, FALSE)Perl_av_fetch( keys,i,(0)); |
| 1114 | keysv = svp ? *svp : sv_newmortal()Perl_sv_newmortal(); |
| 1115 | key = SvPV(keysv, keylen)((((keysv)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((keylen = ((XPV*) (keysv)->sv_any)->xpv_cur), ((keysv )->sv_u.svu_pv)) : Perl_sv_2pv_flags( keysv,&keylen,2) ); |
| 1116 | svp = hv_fetch((HV*)ival, key,((SV**) Perl_hv_common_key_len( ((HV*)ival),(key),(((keysv)-> sv_flags & 0x20000000) ? -(I32)keylen : (I32)keylen),(0) ? (0x20 | 0x10) : 0x20,((void*)0),0)) |
| 1117 | SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0)((SV**) Perl_hv_common_key_len( ((HV*)ival),(key),(((keysv)-> sv_flags & 0x20000000) ? -(I32)keylen : (I32)keylen),(0) ? (0x20 | 0x10) : 0x20,((void*)0),0)); |
| 1118 | hval = svp ? *svp : sv_newmortal()Perl_sv_newmortal(); |
| 1119 | } |
| 1120 | else { |
| 1121 | keysv = hv_iterkeysv(entry)Perl_hv_iterkeysv( entry); |
| 1122 | hval = hv_iterval((HV*)ival, entry)Perl_hv_iterval( (HV*)ival,entry); |
| 1123 | } |
| 1124 | |
| 1125 | key = SvPV(keysv, keylen)((((keysv)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((keylen = ((XPV*) (keysv)->sv_any)->xpv_cur), ((keysv )->sv_u.svu_pv)) : Perl_sv_2pv_flags( keysv,&keylen,2) ); |
| 1126 | do_utf8 = DO_UTF8(keysv)(((keysv)->sv_flags & 0x20000000) && !__builtin_expect (((((PL_curcop)->cop_hints + 0) & 0x00000008) ? (_Bool )1 : (_Bool)0),(0))); |
| 1127 | klen = keylen; |
| 1128 | |
| 1129 | sv_catsv(retval, totpad)Perl_sv_catsv_flags( retval,totpad,2); |
| 1130 | sv_catsv(retval, ipad)Perl_sv_catsv_flags( retval,ipad,2); |
| 1131 | |
| 1132 | ENTERPerl_push_scope(); |
| 1133 | SAVETMPSPerl_savetmps(); |
| 1134 | |
| 1135 | /* The (very) |
| 1136 | old logic was first to check utf8 flag, and if utf8 always |
| 1137 | call esc_q_utf8. This caused test to break under -Mutf8, |
| 1138 | because there even strings like 'c' have utf8 flag on. |
| 1139 | Hence with quotekeys == 0 the XS code would still '' quote |
| 1140 | them based on flags, whereas the perl code would not, |
| 1141 | based on regexps. |
| 1142 | |
| 1143 | The old logic checked that the string was a valid |
| 1144 | perl glob name (foo::bar), which isn't safe under |
| 1145 | strict, and differs from the perl code which only |
| 1146 | accepts simple identifiers. |
| 1147 | |
| 1148 | With the fix for [perl #120384] I chose to make |
| 1149 | their handling of key quoting compatible between XS |
| 1150 | and perl. |
| 1151 | */ |
| 1152 | if (style->quotekeys || key_needs_quote(key,keylen)) { |
| 1153 | if (do_utf8 || style->useqq) { |
| 1154 | STRLEN ocur = SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur; |
| 1155 | klen = nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq); |
| 1156 | nkey = SvPVX(retval)((retval)->sv_u.svu_pv) + ocur; |
| 1157 | } |
| 1158 | else { |
| 1159 | nticks = num_q(key, klen); |
| 1160 | New(0, nkey_buffer, klen+nticks+3, char)(nkey_buffer = ((void)(__builtin_expect(((((( sizeof(size_t) < sizeof(klen+nticks+3) || sizeof(char) > ((size_t)1 << 8*(sizeof(size_t) - sizeof(klen+nticks+3)))) ? (size_t)(klen +nticks+3) : ((size_t)-1)/sizeof(char)) > ((size_t)-1)/sizeof (char))) ? (_Bool)1 : (_Bool)0),(0)) && (Perl_croak_memory_wrap (),0)), (char*)(Perl_safesysmalloc((size_t)((klen+nticks+3)*sizeof (char)))))); |
| 1161 | SAVEFREEPV(nkey_buffer)Perl_save_pushptr( (void *)((char*)(nkey_buffer)),10); |
| 1162 | nkey = nkey_buffer; |
| 1163 | nkey[0] = '\''; |
| 1164 | if (nticks) |
| 1165 | klen += esc_q(nkey+1, key, klen); |
| 1166 | else |
| 1167 | (void)Copy(key, nkey+1, klen, char)((void)(__builtin_expect(((((( sizeof(size_t) < sizeof(klen ) || sizeof(char) > ((size_t)1 << 8*(sizeof(size_t) - sizeof(klen)))) ? (size_t)(klen) : ((size_t)-1)/sizeof(char) ) > ((size_t)-1)/sizeof(char))) ? (_Bool)1 : (_Bool)0),(0) ) && (Perl_croak_memory_wrap(),0)), ((void)0), ((void )0), (void)memcpy((char*)(nkey+1),(const char*)(key), (klen) * sizeof(char))); |
| 1168 | nkey[++klen] = '\''; |
| 1169 | nkey[++klen] = '\0'; |
| 1170 | nlen = klen; |
| 1171 | sv_catpvn(retval, nkey, klen)Perl_sv_catpvn_flags( retval,nkey,klen,2); |
| 1172 | } |
| 1173 | } |
| 1174 | else { |
| 1175 | nkey = key; |
| 1176 | nlen = klen; |
| 1177 | sv_catpvn(retval, nkey, klen)Perl_sv_catpvn_flags( retval,nkey,klen,2); |
| 1178 | } |
| 1179 | |
| 1180 | sname = sv_2mortal(newSVsv(iname))Perl_sv_2mortal( Perl_newSVsv_flags( (iname),2|16)); |
| 1181 | sv_catpvn(sname, nkey, nlen)Perl_sv_catpvn_flags( sname,nkey,nlen,2); |
| 1182 | sv_catpvs(sname, "}")Perl_sv_catpvn_flags( sname, ("" "}" ""), (sizeof("}")-1), 2); |
| 1183 | |
| 1184 | sv_catsv(retval, style->pair)Perl_sv_catsv_flags( retval,style->pair,2); |
| 1185 | if (style->indent >= 2) { |
| 1186 | char *extra; |
| 1187 | STRLEN elen = 0; |
| 1188 | newapad = sv_2mortal(newSVsv(apad))Perl_sv_2mortal( Perl_newSVsv_flags( (apad),2|16)); |
| 1189 | New(0, extra, klen+4+1, char)(extra = ((void)(__builtin_expect(((((( sizeof(size_t) < sizeof (klen+4+1) || sizeof(char) > ((size_t)1 << 8*(sizeof (size_t) - sizeof(klen+4+1)))) ? (size_t)(klen+4+1) : ((size_t )-1)/sizeof(char)) > ((size_t)-1)/sizeof(char))) ? (_Bool) 1 : (_Bool)0),(0)) && (Perl_croak_memory_wrap(),0)), ( char*)(Perl_safesysmalloc((size_t)((klen+4+1)*sizeof(char)))) )); |
| 1190 | while (elen < (klen+4)) |
| 1191 | extra[elen++] = ' '; |
| 1192 | extra[elen] = '\0'; |
| 1193 | sv_catpvn(newapad, extra, elen)Perl_sv_catpvn_flags( newapad,extra,elen,2); |
| 1194 | Safefree(extra)Perl_safesysfree(((void *)(extra))); |
| 1195 | } |
| 1196 | else |
| 1197 | newapad = apad; |
| 1198 | |
| 1199 | DD_dump(aTHX_ hval, SvPVX_const(sname)((const char*)(0 + (sname)->sv_u.svu_pv)), SvCUR(sname)((XPV*) (sname)->sv_any)->xpv_cur, retval, seenhv, |
| 1200 | postav, level+1, newapad, style); |
| 1201 | |
| 1202 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 1203 | LEAVEPerl_pop_scope(); |
| 1204 | } |
| 1205 | if (i) { |
| 1206 | SV *opad = sv_x(aTHX_ Nullsv((SV*)((void*)0)), SvPVX_const(style->xpad)((const char*)(0 + (style->xpad)->sv_u.svu_pv)), |
| 1207 | SvCUR(style->xpad)((XPV*) (style->xpad)->sv_any)->xpv_cur, level); |
| 1208 | if (style->trailingcomma && style->indent >= 1) |
| 1209 | sv_catpvs(retval, ",")Perl_sv_catpvn_flags( retval, ("" "," ""), (sizeof(",")-1), 2 ); |
| 1210 | sv_catsv(retval, totpad)Perl_sv_catsv_flags( retval,totpad,2); |
| 1211 | sv_catsv(retval, opad)Perl_sv_catsv_flags( retval,opad,2); |
| 1212 | SvREFCNT_dec(opad)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (opad); _p; }))); |
| 1213 | } |
| 1214 | if (name[0] == '%') |
| 1215 | sv_catpvs(retval, ")")Perl_sv_catpvn_flags( retval, ("" ")" ""), (sizeof(")")-1), 2 ); |
| 1216 | else |
| 1217 | sv_catpvs(retval, "}")Perl_sv_catpvn_flags( retval, ("" "}" ""), (sizeof("}")-1), 2 ); |
| 1218 | } |
| 1219 | else if (realtype == SVt_PVCV) { |
| 1220 | if (style->deparse) { |
| 1221 | SV *deparsed = sv_2mortal(deparsed_output(aTHX_ val))Perl_sv_2mortal( deparsed_output( val)); |
| 1222 | SV *fullpad = sv_2mortal(newSVsv(style->sep))Perl_sv_2mortal( Perl_newSVsv_flags( (style->sep),2|16)); |
| 1223 | const char *p; |
| 1224 | STRLEN plen; |
| 1225 | I32 i; |
| 1226 | |
| 1227 | sv_catsv(fullpad, style->pad)Perl_sv_catsv_flags( fullpad,style->pad,2); |
| 1228 | sv_catsv(fullpad, apad)Perl_sv_catsv_flags( fullpad,apad,2); |
| 1229 | for (i = 0; i < level; i++) { |
| 1230 | sv_catsv(fullpad, style->xpad)Perl_sv_catsv_flags( fullpad,style->xpad,2); |
| 1231 | } |
| 1232 | |
| 1233 | sv_catpvs(retval, "sub ")Perl_sv_catpvn_flags( retval, ("" "sub " ""), (sizeof("sub ") -1), 2); |
| 1234 | p = SvPV(deparsed, plen)((((deparsed)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((plen = ((XPV*) (deparsed)->sv_any)->xpv_cur), ((deparsed )->sv_u.svu_pv)) : Perl_sv_2pv_flags( deparsed,&plen,2 )); |
| 1235 | while (plen > 0) { |
| 1236 | const char *nl = (const char *) memchr(p, '\n', plen); |
| 1237 | if (!nl) { |
| 1238 | sv_catpvn(retval, p, plen)Perl_sv_catpvn_flags( retval,p,plen,2); |
| 1239 | break; |
| 1240 | } |
| 1241 | else { |
| 1242 | size_t n = nl - p; |
| 1243 | sv_catpvn(retval, p, n)Perl_sv_catpvn_flags( retval,p,n,2); |
| 1244 | sv_catsv(retval, fullpad)Perl_sv_catsv_flags( retval,fullpad,2); |
| 1245 | p += n + 1; |
| 1246 | plen -= n + 1; |
| 1247 | } |
| 1248 | } |
| 1249 | } |
| 1250 | else { |
| 1251 | sv_catpvs(retval, "sub { \"DUMMY\" }")Perl_sv_catpvn_flags( retval, ("" "sub { \"DUMMY\" }" ""), (sizeof ("sub { \"DUMMY\" }")-1), 2); |
| 1252 | if (style->purity) |
| 1253 | warnPerl_warn("Encountered CODE ref, using dummy placeholder"); |
| 1254 | } |
| 1255 | } |
| 1256 | else { |
| 1257 | warnPerl_warn("cannot handle ref type %d", (int)realtype); |
| 1258 | } |
| 1259 | |
| 1260 | if (realpack && !no_bless) { /* free blessed allocs */ |
| 1261 | STRLEN plen, pticks; |
| 1262 | |
| 1263 | if (style->indent >= 2) { |
| 1264 | apad = blesspad; |
| 1265 | } |
| 1266 | sv_catpvs(retval, ", '")Perl_sv_catpvn_flags( retval, ("" ", '" ""), (sizeof(", '")-1 ), 2); |
| 1267 | |
| 1268 | plen = strlen(realpack); |
| 1269 | pticks = num_q(realpack, plen); |
| 1270 | if (pticks) { /* needs escaping */ |
| 1271 | char *npack; |
| 1272 | char *npack_buffer = NULL((void*)0); |
| 1273 | |
| 1274 | New(0, npack_buffer, plen+pticks+1, char)(npack_buffer = ((void)(__builtin_expect(((((( sizeof(size_t) < sizeof(plen+pticks+1) || sizeof(char) > ((size_t)1 << 8*(sizeof(size_t) - sizeof(plen+pticks+1)))) ? (size_t)(plen +pticks+1) : ((size_t)-1)/sizeof(char)) > ((size_t)-1)/sizeof (char))) ? (_Bool)1 : (_Bool)0),(0)) && (Perl_croak_memory_wrap (),0)), (char*)(Perl_safesysmalloc((size_t)((plen+pticks+1)*sizeof (char)))))); |
| 1275 | npack = npack_buffer; |
| 1276 | plen += esc_q(npack, realpack, plen); |
| 1277 | npack[plen] = '\0'; |
| 1278 | |
| 1279 | sv_catpvn(retval, npack, plen)Perl_sv_catpvn_flags( retval,npack,plen,2); |
| 1280 | Safefree(npack_buffer)Perl_safesysfree(((void *)(npack_buffer))); |
| 1281 | } |
| 1282 | else { |
| 1283 | sv_catpvn(retval, realpack, strlen(realpack))Perl_sv_catpvn_flags( retval,realpack,strlen(realpack),2); |
| 1284 | } |
| 1285 | sv_catpvs(retval, "' )")Perl_sv_catpvn_flags( retval, ("" "' )" ""), (sizeof("' )")-1 ), 2); |
| 1286 | if (style->toaster && SvPOK(style->toaster)((style->toaster)->sv_flags & 0x00000400) && SvCUR(style->toaster)((XPV*) (style->toaster)->sv_any)->xpv_cur) { |
| 1287 | sv_catpvs(retval, "->")Perl_sv_catpvn_flags( retval, ("" "->" ""), (sizeof("->" )-1), 2); |
| 1288 | sv_catsv(retval, style->toaster)Perl_sv_catsv_flags( retval,style->toaster,2); |
| 1289 | sv_catpvs(retval, "()")Perl_sv_catpvn_flags( retval, ("" "()" ""), (sizeof("()")-1), 2); |
| 1290 | } |
| 1291 | } |
| 1292 | } |
| 1293 | else { |
| 1294 | STRLEN i; |
| 1295 | const MAGIC *mg; |
| 1296 | |
| 1297 | if (namelen) { |
| 1298 | #ifdef DD_USE_OLD_ID_FORMAT |
| 1299 | idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(val))({ int len = snprintf(id, sizeof(id), "0x%" "lx", (UV)(val)); do { if ((sizeof(id)) > 0 && (size_t)len > (sizeof (id))) Perl_croak("panic: %s buffer overflow", "snprintf"); } while (0); len; }); |
| 1300 | #else |
| 1301 | id_buffer = PTR2UV(val)(UV)(val); |
| 1302 | idlen = sizeof(id_buffer); |
| 1303 | #endif |
| 1304 | if ((svp = hv_fetch(seenhv, id, idlen, FALSE)((SV**) Perl_hv_common_key_len( (seenhv),(id),(idlen),((0)) ? (0x20 | 0x10) : 0x20,((void*)0),0))) && |
| 1305 | (sv = *svp) && SvROK(sv)((sv)->sv_flags & 0x00000800) && |
| 1306 | (seenentry = (AV*)SvRV(sv)((sv)->sv_u.svu_rv))) |
| 1307 | { |
| 1308 | SV *othername; |
| 1309 | if ((svp = av_fetch(seenentry, 0, FALSE)Perl_av_fetch( seenentry,0,(0))) && (othername = *svp) |
| 1310 | && (svp = av_fetch(seenentry, 2, FALSE)Perl_av_fetch( seenentry,2,(0))) && *svp && SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)) > 0) |
| 1311 | { |
| 1312 | sv_catpvs(retval, "${")Perl_sv_catpvn_flags( retval, ("" "${" ""), (sizeof("${")-1), 2); |
| 1313 | sv_catsv(retval, othername)Perl_sv_catsv_flags( retval,othername,2); |
| 1314 | sv_catpvs(retval, "}")Perl_sv_catpvn_flags( retval, ("" "}" ""), (sizeof("}")-1), 2 ); |
| 1315 | return 1; |
| 1316 | } |
| 1317 | } |
| 1318 | /* If we're allowed to keep only a sparse "seen" hash |
| 1319 | * (IOW, the user does not expect it to contain everything |
| 1320 | * after the dump, then only store in seen hash if the SV |
| 1321 | * ref count is larger than 1. If it's 1, then we know that |
| 1322 | * there is no other reference, duh. This is an optimization. |
| 1323 | * Note that we'd have to check for weak-refs, too, but this is |
| 1324 | * already the branch for non-refs only. */ |
| 1325 | else if (val != &PL_sv_undef(PL_sv_immortals[1]) && (!style->use_sparse_seen_hash || SvREFCNT(val)(val)->sv_refcnt > 1)) { |
| 1326 | SV * const namesv = newSVpvs("\\")Perl_newSVpvn( ("" "\\" ""), (sizeof("\\")-1)); |
| 1327 | sv_catpvn(namesv, name, namelen)Perl_sv_catpvn_flags( namesv,name,namelen,2); |
| 1328 | seenentry = newAV()((AV *)({ void *_p = (Perl_newSV_type( SVt_PVAV)); _p; })); |
| 1329 | av_push(seenentry, namesv)Perl_av_push( seenentry,namesv); |
| 1330 | av_push(seenentry, newRV_inc(val))Perl_av_push( seenentry,Perl_newRV( val)); |
| 1331 | (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0)((SV**) Perl_hv_common_key_len( (seenhv),(id),(idlen),(0x04|0x20 ),(Perl_newRV( (SV*)seenentry)),(0))); |
| 1332 | SvREFCNT_dec(seenentry)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (seenentry); _p; }))); |
| 1333 | } |
| 1334 | } |
| 1335 | |
| 1336 | if (DD_is_integer(val)((val)->sv_flags & 0x00000100)) { |
| 1337 | STRLEN len; |
| 1338 | if (SvIsUV(val)((val)->sv_flags & 0x80000000)) |
| 1339 | len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" UVuf, SvUV(val))({ int len = snprintf(tmpbuf, sizeof(tmpbuf), "%" "lu", ((((val )->sv_flags & (0x00000100|0x80000000|0x00200000)) == ( 0x00000100|0x80000000)) ? ((XPVUV*) (val)->sv_any)->xuv_u .xivu_uv : Perl_sv_2uv_flags( val,2))); do { if ((sizeof(tmpbuf )) > 0 && (size_t)len > (sizeof(tmpbuf))) Perl_croak ("panic: %s buffer overflow", "snprintf"); } while (0); len; } ); |
| 1340 | else |
| 1341 | len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, SvIV(val))({ int len = snprintf(tmpbuf, sizeof(tmpbuf), "%" "ld", ((((val )->sv_flags & (0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (val)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( val,2))); do { if ((sizeof(tmpbuf)) > 0 && (size_t )len > (sizeof(tmpbuf))) Perl_croak("panic: %s buffer overflow" , "snprintf"); } while (0); len; }); |
| 1342 | if (SvPOK(val)((val)->sv_flags & 0x00000400)) { |
| 1343 | /* Need to check to see if this is a string such as " 0". |
| 1344 | I'm assuming from sprintf isn't going to clash with utf8. */ |
| 1345 | STRLEN pvlen; |
| 1346 | const char * const pv = SvPV(val, pvlen)((((val)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((pvlen = ((XPV*) (val)->sv_any)->xpv_cur), ((val)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( val,&pvlen,2)); |
| 1347 | if (pvlen != len || memNE(pv, tmpbuf, len)(! (memcmp(((const void *) (pv)), ((const void *) (tmpbuf)), len ) == 0))) |
| 1348 | goto integer_came_from_string; |
| 1349 | } |
| 1350 | if (len > 10) { |
| 1351 | /* Looks like we're on a 64 bit system. Make it a string so that |
| 1352 | if a 32 bit system reads the number it will cope better. */ |
| 1353 | sv_catpvfPerl_sv_catpvf(retval, "'%s'", tmpbuf); |
| 1354 | } else |
| 1355 | sv_catpvn(retval, tmpbuf, len)Perl_sv_catpvn_flags( retval,tmpbuf,len,2); |
| 1356 | } |
| 1357 | else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ |
| 1358 | c = SvPV(val, i)((((val)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((i = ((XPV*) (val)->sv_any)->xpv_cur), ((val)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( val,&i,2)); |
| 1359 | if(i) ++c, --i; /* just get the name */ |
| 1360 | if (memBEGINs(c, i, "main::")( (i) >= sizeof("main::") - 1 && (memcmp(((const void *) (c)), ((const void *) ("" "main::" "")), sizeof("main::") -1) == 0))) { |
| 1361 | c += 4; |
| 1362 | #if PERL_VERSION32 < 7 |
| 1363 | if (i == 6 || (i == 7 && c[6] == '\0')) |
| 1364 | #else |
| 1365 | if (i == 6) |
| 1366 | #endif |
| 1367 | i = 0; else i -= 4; |
| 1368 | } |
| 1369 | if (globname_needs_quote(c,i)) { |
| 1370 | sv_grow(retval, SvCUR(retval)+3)Perl_sv_grow( retval,((XPV*) (retval)->sv_any)->xpv_cur +3); |
| 1371 | r = SvPVX(retval)((retval)->sv_u.svu_pv)+SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur; |
| 1372 | r[0] = '*'; r[1] = '{'; r[2] = 0; |
| 1373 | SvCUR_set(retval, SvCUR(retval)+2)do { ((void)0); ((void)0); ((void)0); (((XPV*) (retval)->sv_any )->xpv_cur = (((XPV*) (retval)->sv_any)->xpv_cur+2)) ; } while (0); |
| 1374 | i = 3 + esc_q_utf8(aTHX_ retval, c, i, |
| 1375 | #ifdef GvNAMEUTF8 |
| 1376 | !!GvNAMEUTF8(val)((*((unsigned char *)(((((XPVGV*)(val)->sv_any)->xiv_u. xivu_namehek))->hek_key)+((((XPVGV*)(val)->sv_any)-> xiv_u.xivu_namehek))->hek_len+1)) & 0x01), style->useqq |
| 1377 | #else |
| 1378 | 0, style->useqq || globname_supra_ascii(c, i) |
| 1379 | #endif |
| 1380 | ); |
| 1381 | sv_grow(retval, SvCUR(retval)+2)Perl_sv_grow( retval,((XPV*) (retval)->sv_any)->xpv_cur +2); |
| 1382 | r = SvPVX(retval)((retval)->sv_u.svu_pv)+SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur; |
| 1383 | r[0] = '}'; r[1] = '\0'; |
| 1384 | SvCUR_set(retval, SvCUR(retval)+1)do { ((void)0); ((void)0); ((void)0); (((XPV*) (retval)->sv_any )->xpv_cur = (((XPV*) (retval)->sv_any)->xpv_cur+1)) ; } while (0); |
| 1385 | r = r+1 - i; |
| 1386 | } |
| 1387 | else { |
| 1388 | sv_grow(retval, SvCUR(retval)+i+2)Perl_sv_grow( retval,((XPV*) (retval)->sv_any)->xpv_cur +i+2); |
| 1389 | r = SvPVX(retval)((retval)->sv_u.svu_pv)+SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur; |
| 1390 | r[0] = '*'; strlcpy(r+1, c, SvLEN(retval))strlcpy(r+1,c,((XPV*) (retval)->sv_any)->xpv_len_u.xpvlenu_len ); |
| 1391 | i++; |
| 1392 | SvCUR_set(retval, SvCUR(retval)+i)do { ((void)0); ((void)0); ((void)0); (((XPV*) (retval)->sv_any )->xpv_cur = (((XPV*) (retval)->sv_any)->xpv_cur+i)) ; } while (0); |
| 1393 | } |
| 1394 | |
| 1395 | if (style->purity) { |
| 1396 | static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; |
| 1397 | static const STRLEN sizes[] = { 8, 7, 6 }; |
| 1398 | SV *e; |
| 1399 | SV * const nname = newSVpvs("")Perl_newSVpvn( ("" "" ""), (sizeof("")-1)); |
| 1400 | SV * const newapad = newSVpvs("")Perl_newSVpvn( ("" "" ""), (sizeof("")-1)); |
| 1401 | GV * const gv = (GV*)val; |
| 1402 | I32 j; |
| 1403 | |
| 1404 | for (j=0; j<3; j++) { |
| 1405 | e = ((j == 0) ? GvSV(gv)((0+(gv)->sv_u.svu_gp)->gp_sv) : (j == 1) ? (SV*)GvAV(gv)((0+(gv)->sv_u.svu_gp)->gp_av) : (SV*)GvHV(gv)(((0+(gv)->sv_u.svu_gp))->gp_hv)); |
| 1406 | if (!e) |
| 1407 | continue; |
| 1408 | if (j == 0 && !SvOK(e)((e)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) |
| 1409 | continue; |
| 1410 | |
| 1411 | { |
| 1412 | SV *postentry = newSVpvn(r,i)Perl_newSVpvn( r,i); |
| 1413 | |
| 1414 | sv_setsv(nname, postentry)Perl_sv_setsv_flags( nname,postentry,2|0); |
| 1415 | sv_catpvn(nname, entries[j], sizes[j])Perl_sv_catpvn_flags( nname,entries[j],sizes[j],2); |
| 1416 | sv_catpvs(postentry, " = ")Perl_sv_catpvn_flags( postentry, ("" " = " ""), (sizeof(" = " )-1), 2); |
| 1417 | av_push(postav, postentry)Perl_av_push( postav,postentry); |
| 1418 | e = newRV_inc(e)Perl_newRV( e); |
| 1419 | |
| 1420 | SvCUR_set(newapad, 0)do { ((void)0); ((void)0); ((void)0); (((XPV*) (newapad)-> sv_any)->xpv_cur = (0)); } while (0); |
| 1421 | if (style->indent >= 2) |
| 1422 | (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)((XPV*) (postentry)->sv_any)->xpv_cur); |
| 1423 | |
| 1424 | DD_dump(aTHX_ e, SvPVX_const(nname)((const char*)(0 + (nname)->sv_u.svu_pv)), SvCUR(nname)((XPV*) (nname)->sv_any)->xpv_cur, postentry, |
| 1425 | seenhv, postav, 0, newapad, style); |
| 1426 | SvREFCNT_dec(e)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (e); _p; }))); |
| 1427 | } |
| 1428 | } |
| 1429 | |
| 1430 | SvREFCNT_dec(newapad)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (newapad); _p; }))); |
| 1431 | SvREFCNT_dec(nname)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (nname); _p; }))); |
| 1432 | } |
| 1433 | } |
| 1434 | else if (val == &PL_sv_undef(PL_sv_immortals[1]) || !SvOK(val)((val)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) { |
| 1435 | sv_catpvs(retval, "undef")Perl_sv_catpvn_flags( retval, ("" "undef" ""), (sizeof("undef" )-1), 2); |
| 1436 | } |
| 1437 | #ifdef SvVOK |
| 1438 | else if (SvMAGICAL(val)((val)->sv_flags & (0x00200000|0x00400000|0x00800000)) && (mg = mg_findPerl_mg_find(val, 'V'))) { |
| 1439 | # if !defined(PL_vtbl_vstring) && PERL_VERSION32 < 17 |
| 1440 | SV * const vecsv = sv_newmortal()Perl_sv_newmortal(); |
| 1441 | # if PERL_VERSION32 < 10 |
| 1442 | scan_vstring(mg->mg_ptr, vecsv); |
| 1443 | # else |
| 1444 | scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv)Perl_scan_vstring( mg->mg_ptr,mg->mg_ptr + mg->mg_len ,vecsv); |
| 1445 | # endif |
| 1446 | if (!sv_eq(vecsv, val)Perl_sv_eq_flags( vecsv,val,2)) goto integer_came_from_string; |
| 1447 | # endif |
| 1448 | sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len)Perl_sv_catpvn_flags( retval,(const char *)mg->mg_ptr,mg-> mg_len,2); |
| 1449 | } |
| 1450 | #endif |
| 1451 | |
| 1452 | else { |
| 1453 | integer_came_from_string: |
| 1454 | c = SvPV(val, i)((((val)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((i = ((XPV*) (val)->sv_any)->xpv_cur), ((val)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( val,&i,2)); |
| 1455 | /* the pure perl and XS non-qq outputs have historically been |
| 1456 | * different in this case, but for useqq, let's try to match |
| 1457 | * the pure perl code. |
| 1458 | * see [perl #74798] |
| 1459 | */ |
| 1460 | if (style->useqq && safe_decimal_number(c, i)) { |
| 1461 | sv_catsv(retval, val)Perl_sv_catsv_flags( retval,val,2); |
| 1462 | } |
| 1463 | else if (DO_UTF8(val)(((val)->sv_flags & 0x20000000) && !__builtin_expect (((((PL_curcop)->cop_hints + 0) & 0x00000008) ? (_Bool )1 : (_Bool)0),(0))) || style->useqq) |
| 1464 | i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val)(((val)->sv_flags & 0x20000000) && !__builtin_expect (((((PL_curcop)->cop_hints + 0) & 0x00000008) ? (_Bool )1 : (_Bool)0),(0))), style->useqq); |
| 1465 | else { |
| 1466 | sv_grow(retval, SvCUR(retval)+3+2*i)Perl_sv_grow( retval,((XPV*) (retval)->sv_any)->xpv_cur +3+2*i); /* 3: ""\0 */ |
| 1467 | r = SvPVX(retval)((retval)->sv_u.svu_pv) + SvCUR(retval)((XPV*) (retval)->sv_any)->xpv_cur; |
| 1468 | r[0] = '\''; |
| 1469 | i += esc_q(r+1, c, i); |
| 1470 | ++i; |
| 1471 | r[i++] = '\''; |
| 1472 | r[i] = '\0'; |
| 1473 | SvCUR_set(retval, SvCUR(retval)+i)do { ((void)0); ((void)0); ((void)0); (((XPV*) (retval)->sv_any )->xpv_cur = (((XPV*) (retval)->sv_any)->xpv_cur+i)) ; } while (0); |
| 1474 | } |
| 1475 | } |
| 1476 | } |
| 1477 | |
| 1478 | if (idlen) { |
| 1479 | if (style->deepcopy) |
| 1480 | (void)hv_delete(seenhv, id, idlen, G_DISCARD)(((SV *)({ void *_p = (Perl_hv_common_key_len( (seenhv),(id), (idlen),(0x4) | 0x40,((void*)0),0)); _p; }))); |
| 1481 | else if (namelen && seenentry) { |
| 1482 | SV *mark = *av_fetch(seenentry, 2, TRUE)Perl_av_fetch( seenentry,2,(1)); |
| 1483 | sv_setiv(mark,1)Perl_sv_setiv( mark,1); |
| 1484 | } |
| 1485 | } |
| 1486 | return 1; |
| 1487 | } |
| 1488 | |
| 1489 | |
| 1490 | #line 1491 "Dumper.c" |
| 1491 | #ifndef PERL_UNUSED_VAR |
| 1492 | # define PERL_UNUSED_VAR(var)((void)sizeof(var)) if (0) var = var |
| 1493 | #endif |
| 1494 | |
| 1495 | #ifndef dVARstruct Perl___notused_struct |
| 1496 | # define dVARstruct Perl___notused_struct dNOOPstruct Perl___notused_struct |
| 1497 | #endif |
| 1498 | |
| 1499 | |
| 1500 | /* This stuff is not part of the API! You have been warned. */ |
| 1501 | #ifndef PERL_VERSION_DECIMAL |
| 1502 | # define PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s) (r*1000000 + v*1000 + s) |
| 1503 | #endif |
| 1504 | #ifndef PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) |
| 1505 | # define PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) \ |
| 1506 | PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)(5*1000000 + 32*1000 + 1) |
| 1507 | #endif |
| 1508 | #ifndef PERL_VERSION_GE |
| 1509 | # define PERL_VERSION_GE(r,v,s)((5*1000000 + 32*1000 + 1) >= (r*1000000 + v*1000 + s)) \ |
| 1510 | (PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) >= PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s)) |
| 1511 | #endif |
| 1512 | #ifndef PERL_VERSION_LE |
| 1513 | # define PERL_VERSION_LE(r,v,s)((5*1000000 + 32*1000 + 1) <= (r*1000000 + v*1000 + s)) \ |
| 1514 | (PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) <= PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s)) |
| 1515 | #endif |
| 1516 | |
| 1517 | /* XS_INTERNAL is the explicit static-linkage variant of the default |
| 1518 | * XS macro. |
| 1519 | * |
| 1520 | * XS_EXTERNAL is the same as XS_INTERNAL except it does not include |
| 1521 | * "STATIC", ie. it exports XSUB symbols. You probably don't want that |
| 1522 | * for anything but the BOOT XSUB. |
| 1523 | * |
| 1524 | * See XSUB.h in core! |
| 1525 | */ |
| 1526 | |
| 1527 | |
| 1528 | /* TODO: This might be compatible further back than 5.10.0. */ |
| 1529 | #if PERL_VERSION_GE(5, 10, 0)((5*1000000 + 32*1000 + 1) >= (5*1000000 + 10*1000 + 0)) && PERL_VERSION_LE(5, 15, 1)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 15*1000 + 1)) |
| 1530 | # undef XS_EXTERNAL |
| 1531 | # undef XS_INTERNAL |
| 1532 | # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) |
| 1533 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) __declspec(dllexport) XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1534 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1535 | # endif |
| 1536 | # if defined(__SYMBIAN32__) |
| 1537 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) EXPORT_C XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1538 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) EXPORT_C STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1539 | # endif |
| 1540 | # ifndef XS_EXTERNAL |
| 1541 | # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) |
| 1542 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) void name(pTHX_ CV* cv __attribute__unused____attribute__((unused))) |
| 1543 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic void name(pTHX_ CV* cv __attribute__unused____attribute__((unused))) |
| 1544 | # else |
| 1545 | # ifdef __cplusplus |
| 1546 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) extern "C" XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1547 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) static XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1548 | # else |
| 1549 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1550 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) |
| 1551 | # endif |
| 1552 | # endif |
| 1553 | # endif |
| 1554 | #endif |
| 1555 | |
| 1556 | /* perl >= 5.10.0 && perl <= 5.15.1 */ |
| 1557 | |
| 1558 | |
| 1559 | /* The XS_EXTERNAL macro is used for functions that must not be static |
| 1560 | * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL |
| 1561 | * macro defined, the best we can do is assume XS is the same. |
| 1562 | * Dito for XS_INTERNAL. |
| 1563 | */ |
| 1564 | #ifndef XS_EXTERNAL |
| 1565 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) XS(name)void name( CV* cv __attribute__((unused))) |
| 1566 | #endif |
| 1567 | #ifndef XS_INTERNAL |
| 1568 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) XS(name)void name( CV* cv __attribute__((unused))) |
| 1569 | #endif |
| 1570 | |
| 1571 | /* Now, finally, after all this mess, we want an ExtUtils::ParseXS |
| 1572 | * internal macro that we're free to redefine for varying linkage due |
| 1573 | * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use |
| 1574 | * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! |
| 1575 | */ |
| 1576 | |
| 1577 | #undef XS_EUPXS |
| 1578 | #if defined(PERL_EUPXS_ALWAYS_EXPORT) |
| 1579 | # define XS_EUPXS(name)static void name( CV* cv __attribute__((unused))) XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) |
| 1580 | #else |
| 1581 | /* default to internal */ |
| 1582 | # define XS_EUPXS(name)static void name( CV* cv __attribute__((unused))) XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) |
| 1583 | #endif |
| 1584 | |
| 1585 | #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) |
| 1586 | #define PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) assert(cv)((void)0); assert(params)((void)0) |
| 1587 | |
| 1588 | /* prototype to pass -Wmissing-prototypes */ |
| 1589 | STATICstatic void |
| 1590 | S_croak_xs_usage(const CV *const cv, const char *const params); |
| 1591 | |
| 1592 | STATICstatic void |
| 1593 | S_croak_xs_usage(const CV *const cv, const char *const params) |
| 1594 | { |
| 1595 | const GV *const gv = CvGV(cv)Perl_CvGV( (CV *)(cv)); |
| 1596 | |
| 1597 | PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0); |
| 1598 | |
| 1599 | if (gv) { |
| 1600 | const char *const gvname = GvNAME(gv)((((XPVGV*)(gv)->sv_any)->xiv_u.xivu_namehek))->hek_key; |
| 1601 | const HV *const stash = GvSTASH(gv)(((XPVGV*)(gv)->sv_any)->xnv_u.xgv_stash); |
| 1602 | const char *const hvname = stash ? HvNAME(stash)((((stash)->sv_flags & 0x02000000) && ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV*) (stash )->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name && ( ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_count ? * ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_names : ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name )) ? (( ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash )[((XPVHV*) (stash)->sv_any)->xhv_max+1]))->xhv_name_count ? *((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_names : ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name ))->hek_key : ((void*)0)) : NULL((void*)0); |
| 1603 | |
| 1604 | if (hvname) |
| 1605 | Perl_croak_nocontextPerl_croak("Usage: %s::%s(%s)", hvname, gvname, params); |
| 1606 | else |
| 1607 | Perl_croak_nocontextPerl_croak("Usage: %s(%s)", gvname, params); |
| 1608 | } else { |
| 1609 | /* Pants. I don't think that it should be possible to get here. */ |
| 1610 | Perl_croak_nocontextPerl_croak("Usage: CODE(0x%" UVxf"lx" ")(%s)", PTR2UV(cv)(UV)(cv), params); |
| 1611 | } |
| 1612 | } |
| 1613 | #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) |
| 1614 | |
| 1615 | #define croak_xs_usagePerl_croak_xs_usage S_croak_xs_usage |
| 1616 | |
| 1617 | #endif |
| 1618 | |
| 1619 | /* NOTE: the prototype of newXSproto() is different in versions of perls, |
| 1620 | * so we define a portable version of newXSproto() |
| 1621 | */ |
| 1622 | #ifdef newXS_flags |
| 1623 | #define newXSproto_portable(name, c_impl, file, proto)Perl_newXS_flags( name,c_impl,file,proto,0) newXS_flags(name, c_impl, file, proto, 0)Perl_newXS_flags( name,c_impl,file,proto,0) |
| 1624 | #else |
| 1625 | #define newXSproto_portable(name, c_impl, file, proto)Perl_newXS_flags( name,c_impl,file,proto,0) (PL_Sv=(SV*)newXS(name, c_impl, file)Perl_newXS( name,c_impl,file), sv_setpv(PL_Sv, proto)Perl_sv_setpv( PL_Sv,proto), (CV*)PL_Sv) |
| 1626 | #endif /* !defined(newXS_flags) */ |
| 1627 | |
| 1628 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) |
| 1629 | # define newXS_deffile(a,b)Perl_newXS_deffile( a,b) Perl_newXS(aTHX_ a,b,file) |
| 1630 | #else |
| 1631 | # define newXS_deffile(a,b)Perl_newXS_deffile( a,b) Perl_newXS_deffile(aTHX_ a,b) |
| 1632 | #endif |
| 1633 | |
| 1634 | #line 1635 "Dumper.c" |
| 1635 | |
| 1636 | XS_EUPXS(XS_Data__Dumper_Dumpxs)static void XS_Data__Dumper_Dumpxs( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ |
| 1637 | XS_EUPXS(XS_Data__Dumper_Dumpxs)static void XS_Data__Dumper_Dumpxs( CV* cv __attribute__((unused ))) |
| 1638 | { |
| 1639 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); |
| 1640 | if (items < 1) |
| 1641 | croak_xs_usagePerl_croak_xs_usage(cv, "href, ..."); |
| 1642 | PERL_UNUSED_VAR(ax)((void)sizeof(ax)); /* -Wall */ |
| 1643 | SPsp -= items; |
| 1644 | { |
| 1645 | SV * href = ST(0)PL_stack_base[ax + (0)] |
| 1646 | ; |
| 1647 | #line 1494 "Dumper.xs" |
| 1648 | { |
| 1649 | HV *hv; |
| 1650 | SV *retval, *valstr; |
| 1651 | HV *seenhv = NULL((void*)0); |
| 1652 | AV *postav, *todumpav, *namesav; |
| 1653 | I32 terse = 0; |
| 1654 | SSize_tssize_t i, imax, postlen; |
| 1655 | SV **svp; |
| 1656 | SV *apad = &PL_sv_undef(PL_sv_immortals[1]); |
| 1657 | Style style; |
| 1658 | |
| 1659 | SV *name, *val = &PL_sv_undef(PL_sv_immortals[1]), *varname = &PL_sv_undef(PL_sv_immortals[1]); |
| 1660 | char tmpbuf[1024]; |
| 1661 | I32 gimme = GIMME_VPerl_gimme_V(); |
| 1662 | |
| 1663 | if (!SvROK(href)((href)->sv_flags & 0x00000800)) { /* call new to get an object first */ |
| 1664 | if (items < 2) |
| 1665 | croakPerl_croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); |
| 1666 | |
| 1667 | ENTERPerl_push_scope(); |
| 1668 | SAVETMPSPerl_savetmps(); |
| 1669 | |
| 1670 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); |
| 1671 | EXTEND(SP, 3)do { (void)0; if (__builtin_expect(((((3) < 0 || PL_stack_max - (sp) < (3))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(3) > sizeof(ssize_t) && ((ssize_t) (3) != (3)) ? -1 : (3))); ((void)sizeof(sp)); } } while (0); /* 3 == max of all branches below */ |
| 1672 | PUSHs(href)(*++sp = (href)); |
| 1673 | PUSHs(sv_2mortal(newSVsv(ST(1))))(*++sp = (Perl_sv_2mortal( Perl_newSVsv_flags( (PL_stack_base [ax + (1)]),2|16)))); |
| 1674 | if (items >= 3) |
| 1675 | PUSHs(sv_2mortal(newSVsv(ST(2))))(*++sp = (Perl_sv_2mortal( Perl_newSVsv_flags( (PL_stack_base [ax + (2)]),2|16)))); |
| 1676 | PUTBACKPL_stack_sp = sp; |
| 1677 | i = perl_call_method("new", G_SCALAR)Perl_call_method( "new",2); |
| 1678 | SPAGAINsp = PL_stack_sp; |
| 1679 | if (i) |
| 1680 | href = newSVsv(POPs)Perl_newSVsv_flags( ((*sp--)),2|16); |
| 1681 | |
| 1682 | PUTBACKPL_stack_sp = sp; |
| 1683 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 1684 | LEAVEPerl_pop_scope(); |
| 1685 | if (i) |
| 1686 | (void)sv_2mortal(href)Perl_sv_2mortal( href); |
| 1687 | } |
| 1688 | |
| 1689 | todumpav = namesav = NULL((void*)0); |
| 1690 | style.indent = 2; |
| 1691 | style.quotekeys = 1; |
| 1692 | style.maxrecurse = 1000; |
| 1693 | style.maxrecursed = FALSE(0); |
| 1694 | style.purity = style.deepcopy = style.useqq = style.maxdepth |
| 1695 | = style.use_sparse_seen_hash = style.trailingcomma = 0; |
| 1696 | style.pad = style.xpad = style.sep = style.pair = style.sortkeys |
| 1697 | = style.freezer = style.toaster = style.bless = &PL_sv_undef(PL_sv_immortals[1]); |
| 1698 | seenhv = NULL((void*)0); |
| 1699 | name = sv_newmortal()Perl_sv_newmortal(); |
| 1700 | |
| 1701 | retval = newSVpvs_flags("", SVs_TEMP)Perl_newSVpvn_flags( ("" "" ""), (sizeof("")-1), 0x00080000); |
| 1702 | if (SvROK(href)((href)->sv_flags & 0x00000800) |
| 1703 | && (hv = (HV*)SvRV((SV*)href)(((SV*)href)->sv_u.svu_rv)) |
| 1704 | && SvTYPE(hv)((svtype)((hv)->sv_flags & 0xff)) == SVt_PVHV) { |
| 1705 | |
| 1706 | if ((svp = hv_fetchs(hv, "seen", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "seen" "")),((sizeof ("seen")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0))) && SvROK(*svp)((*svp)->sv_flags & 0x00000800)) |
| 1707 | seenhv = (HV*)SvRV(*svp)((*svp)->sv_u.svu_rv); |
| 1708 | else |
| 1709 | style.use_sparse_seen_hash = 1; |
| 1710 | if ((svp = hv_fetchs(hv, "noseen", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "noseen" "")),((sizeof ("noseen")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1711 | style.use_sparse_seen_hash = (SvOK(*svp)((*svp)->sv_flags & (0x00000100|0x00000200|0x00000400| 0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) && SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)) != 0); |
| 1712 | if ((svp = hv_fetchs(hv, "todump", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "todump" "")),((sizeof ("todump")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0))) && SvROK(*svp)((*svp)->sv_flags & 0x00000800)) |
| 1713 | todumpav = (AV*)SvRV(*svp)((*svp)->sv_u.svu_rv); |
| 1714 | if ((svp = hv_fetchs(hv, "names", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "names" "")),((sizeof ("names")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0))) && SvROK(*svp)((*svp)->sv_flags & 0x00000800)) |
| 1715 | namesav = (AV*)SvRV(*svp)((*svp)->sv_u.svu_rv); |
| 1716 | if ((svp = hv_fetchs(hv, "indent", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "indent" "")),((sizeof ("indent")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1717 | style.indent = SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)); |
| 1718 | if ((svp = hv_fetchs(hv, "purity", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "purity" "")),((sizeof ("purity")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1719 | style.purity = SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)); |
| 1720 | if ((svp = hv_fetchs(hv, "terse", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "terse" "")),((sizeof ("terse")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1721 | terse = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1722 | if ((svp = hv_fetchs(hv, "useqq", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "useqq" "")),((sizeof ("useqq")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1723 | style.useqq = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1724 | if ((svp = hv_fetchs(hv, "pad", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "pad" "")),((sizeof ("pad")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1725 | style.pad = *svp; |
| 1726 | if ((svp = hv_fetchs(hv, "xpad", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "xpad" "")),((sizeof ("xpad")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1727 | style.xpad = *svp; |
| 1728 | if ((svp = hv_fetchs(hv, "apad", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "apad" "")),((sizeof ("apad")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1729 | apad = *svp; |
| 1730 | if ((svp = hv_fetchs(hv, "sep", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "sep" "")),((sizeof ("sep")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1731 | style.sep = *svp; |
| 1732 | if ((svp = hv_fetchs(hv, "pair", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "pair" "")),((sizeof ("pair")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1733 | style.pair = *svp; |
| 1734 | if ((svp = hv_fetchs(hv, "varname", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "varname" "")),(( sizeof("varname")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*) 0),0)))) |
| 1735 | varname = *svp; |
| 1736 | if ((svp = hv_fetchs(hv, "freezer", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "freezer" "")),(( sizeof("freezer")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*) 0),0)))) |
| 1737 | style.freezer = *svp; |
| 1738 | if ((svp = hv_fetchs(hv, "toaster", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "toaster" "")),(( sizeof("toaster")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*) 0),0)))) |
| 1739 | style.toaster = *svp; |
| 1740 | if ((svp = hv_fetchs(hv, "deepcopy", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "deepcopy" "")),( (sizeof("deepcopy")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void *)0),0)))) |
| 1741 | style.deepcopy = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1742 | if ((svp = hv_fetchs(hv, "quotekeys", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "quotekeys" "")), ((sizeof("quotekeys")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void *)0),0)))) |
| 1743 | style.quotekeys = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1744 | if ((svp = hv_fetchs(hv, "trailingcomma", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "trailingcomma" "" )),((sizeof("trailingcomma")-1)),(((0))) ? (0x20 | 0x10) : 0x20 ,((void*)0),0)))) |
| 1745 | style.trailingcomma = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1746 | if ((svp = hv_fetchs(hv, "deparse", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "deparse" "")),(( sizeof("deparse")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*) 0),0)))) |
| 1747 | style.deparse = SvTRUE(*svp)Perl_SvTRUE( *svp); |
| 1748 | if ((svp = hv_fetchs(hv, "bless", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "bless" "")),((sizeof ("bless")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void*)0),0)))) |
| 1749 | style.bless = *svp; |
| 1750 | if ((svp = hv_fetchs(hv, "maxdepth", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "maxdepth" "")),( (sizeof("maxdepth")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void *)0),0)))) |
| 1751 | style.maxdepth = SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)); |
| 1752 | if ((svp = hv_fetchs(hv, "maxrecurse", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "maxrecurse" "")) ,((sizeof("maxrecurse")-1)),(((0))) ? (0x20 | 0x10) : 0x20,(( void*)0),0)))) |
| 1753 | style.maxrecurse = SvIV(*svp)((((*svp)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (*svp)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( *svp,2)); |
| 1754 | if ((svp = hv_fetchs(hv, "sortkeys", FALSE)((SV**) Perl_hv_common_key_len( ((hv)),(("" "sortkeys" "")),( (sizeof("sortkeys")-1)),(((0))) ? (0x20 | 0x10) : 0x20,((void *)0),0)))) { |
| 1755 | SV *sv = *svp; |
| 1756 | if (! SvTRUE(sv)Perl_SvTRUE( sv)) |
| 1757 | style.sortkeys = NULL((void*)0); |
| 1758 | else if (SvROK(sv)((sv)->sv_flags & 0x00000800) && SvTYPE(SvRV(sv))((svtype)((((sv)->sv_u.svu_rv))->sv_flags & 0xff)) == SVt_PVCV) |
| 1759 | style.sortkeys = sv; |
| 1760 | else if (PERL_VERSION32 < 8) |
| 1761 | /* 5.6 doesn't make sortsv() available to XS code, |
| 1762 | * so we must use this helper instead. Note that we |
| 1763 | * always allocate this mortal SV, but it will be |
| 1764 | * used only if at least one hash is encountered |
| 1765 | * while dumping recursively; an older version |
| 1766 | * allocated it lazily as needed. */ |
| 1767 | style.sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys"))Perl_sv_2mortal( Perl_newSVpvn( ("" "Data::Dumper::_sortkeys" ""), (sizeof("Data::Dumper::_sortkeys")-1))); |
| 1768 | else |
| 1769 | /* flag to use sortsv() for sorting hash keys */ |
| 1770 | style.sortkeys = &PL_sv_yes(PL_sv_immortals[0]); |
| 1771 | } |
| 1772 | postav = newAV()((AV *)({ void *_p = (Perl_newSV_type( SVt_PVAV)); _p; })); |
| 1773 | sv_2mortal((SV*)postav)Perl_sv_2mortal( (SV*)postav); |
| 1774 | |
| 1775 | if (todumpav) |
| 1776 | imax = av_len(todumpav)Perl_av_len( todumpav); |
| 1777 | else |
| 1778 | imax = -1; |
| 1779 | valstr = newSVpvs_flags("", SVs_TEMP)Perl_newSVpvn_flags( ("" "" ""), (sizeof("")-1), 0x00080000); |
| 1780 | for (i = 0; i <= imax; ++i) { |
| 1781 | SV *newapad; |
| 1782 | |
| 1783 | av_clear(postav)Perl_av_clear( postav); |
| 1784 | if ((svp = av_fetch(todumpav, i, FALSE)Perl_av_fetch( todumpav,i,(0)))) |
| 1785 | val = *svp; |
| 1786 | else |
| 1787 | val = &PL_sv_undef(PL_sv_immortals[1]); |
| 1788 | if ((svp = av_fetch(namesav, i, TRUE)Perl_av_fetch( namesav,i,(1)))) { |
| 1789 | sv_setsv(name, *svp)Perl_sv_setsv_flags( name,*svp,2|0); |
| 1790 | if (SvOK(*svp)((*svp)->sv_flags & (0x00000100|0x00000200|0x00000400| 0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) && !SvPOK(*svp)((*svp)->sv_flags & 0x00000400)) |
| 1791 | (void)SvPV_nolen_const(name)((((name)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((const char*)(0 + (name)->sv_u.svu_pv)) : Perl_sv_2pv_flags ( name,0,2|32)); |
| 1792 | } |
| 1793 | else |
| 1794 | (void)SvOK_off(name)( (name)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), ((void)(((name)->sv_flags & 0x02000000) && (Perl_sv_backoff(name),0)))); |
| 1795 | |
| 1796 | if (SvPOK(name)((name)->sv_flags & 0x00000400)) { |
| 1797 | if ((SvPVX_const(name)((const char*)(0 + (name)->sv_u.svu_pv)))[0] == '*') { |
| 1798 | if (SvROK(val)((val)->sv_flags & 0x00000800)) { |
| 1799 | switch (SvTYPE(SvRV(val))((svtype)((((val)->sv_u.svu_rv))->sv_flags & 0xff))) { |
| 1800 | case SVt_PVAV: |
| 1801 | (SvPVX(name)((name)->sv_u.svu_pv))[0] = '@'; |
| 1802 | break; |
| 1803 | case SVt_PVHV: |
| 1804 | (SvPVX(name)((name)->sv_u.svu_pv))[0] = '%'; |
| 1805 | break; |
| 1806 | case SVt_PVCV: |
| 1807 | (SvPVX(name)((name)->sv_u.svu_pv))[0] = '*'; |
| 1808 | break; |
| 1809 | default: |
| 1810 | (SvPVX(name)((name)->sv_u.svu_pv))[0] = '$'; |
| 1811 | break; |
| 1812 | } |
| 1813 | } |
| 1814 | else |
| 1815 | (SvPVX(name)((name)->sv_u.svu_pv))[0] = '$'; |
| 1816 | } |
| 1817 | else if ((SvPVX_const(name)((const char*)(0 + (name)->sv_u.svu_pv)))[0] != '$') |
| 1818 | sv_insert(name, 0, 0, "$", 1)Perl_sv_insert_flags( (name),(0), (0), ("$"), (1), 2); |
| 1819 | } |
| 1820 | else { |
| 1821 | STRLEN nchars; |
| 1822 | sv_setpvs(name, "$")Perl_sv_setpvn( name, ("" "$" ""), (sizeof("$")-1)); |
| 1823 | sv_catsv(name, varname)Perl_sv_catsv_flags( name,varname,2); |
| 1824 | nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf,({ int len = snprintf(tmpbuf, sizeof(tmpbuf), "%" "ld", (IV)( i+1)); do { if ((sizeof(tmpbuf)) > 0 && (size_t)len > (sizeof(tmpbuf))) Perl_croak("panic: %s buffer overflow" , "snprintf"); } while (0); len; }) |
| 1825 | (IV)(i+1))({ int len = snprintf(tmpbuf, sizeof(tmpbuf), "%" "ld", (IV)( i+1)); do { if ((sizeof(tmpbuf)) > 0 && (size_t)len > (sizeof(tmpbuf))) Perl_croak("panic: %s buffer overflow" , "snprintf"); } while (0); len; }); |
| 1826 | sv_catpvn(name, tmpbuf, nchars)Perl_sv_catpvn_flags( name,tmpbuf,nchars,2); |
| 1827 | } |
| 1828 | |
| 1829 | if (style.indent >= 2 && !terse) { |
| 1830 | SV * const tmpsv = sv_x(aTHX_ NULL((void*)0), " ", 1, SvCUR(name)((XPV*) (name)->sv_any)->xpv_cur+3); |
| 1831 | newapad = sv_2mortal(newSVsv(apad))Perl_sv_2mortal( Perl_newSVsv_flags( (apad),2|16)); |
| 1832 | sv_catsv(newapad, tmpsv)Perl_sv_catsv_flags( newapad,tmpsv,2); |
| 1833 | SvREFCNT_dec(tmpsv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (tmpsv); _p; }))); |
| 1834 | } |
| 1835 | else |
| 1836 | newapad = apad; |
| 1837 | |
| 1838 | ENTERPerl_push_scope(); |
| 1839 | SAVETMPSPerl_savetmps(); |
| 1840 | PUTBACKPL_stack_sp = sp; |
| 1841 | DD_dump(aTHX_ val, SvPVX_const(name)((const char*)(0 + (name)->sv_u.svu_pv)), SvCUR(name)((XPV*) (name)->sv_any)->xpv_cur, valstr, seenhv, |
| 1842 | postav, 0, newapad, &style); |
| 1843 | SPAGAINsp = PL_stack_sp; |
| 1844 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); |
| 1845 | LEAVEPerl_pop_scope(); |
| 1846 | |
| 1847 | postlen = av_len(postav)Perl_av_len( postav); |
| 1848 | if (postlen >= 0 || !terse) { |
| 1849 | sv_insert(valstr, 0, 0, " = ", 3)Perl_sv_insert_flags( (valstr),(0), (0), (" = "), (3), 2); |
| 1850 | sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name))Perl_sv_insert_flags( (valstr),(0), (0), (((const char*)(0 + ( name)->sv_u.svu_pv))), (((XPV*) (name)->sv_any)->xpv_cur ), 2); |
| 1851 | sv_catpvs(valstr, ";")Perl_sv_catpvn_flags( valstr, ("" ";" ""), (sizeof(";")-1), 2 ); |
| 1852 | } |
| 1853 | sv_catsv(retval, style.pad)Perl_sv_catsv_flags( retval,style.pad,2); |
| 1854 | sv_catsv(retval, valstr)Perl_sv_catsv_flags( retval,valstr,2); |
| 1855 | sv_catsv(retval, style.sep)Perl_sv_catsv_flags( retval,style.sep,2); |
| 1856 | if (postlen >= 0) { |
| 1857 | SSize_tssize_t i; |
| 1858 | sv_catsv(retval, style.pad)Perl_sv_catsv_flags( retval,style.pad,2); |
| 1859 | for (i = 0; i <= postlen; ++i) { |
| 1860 | SV *elem; |
| 1861 | svp = av_fetch(postav, i, FALSE)Perl_av_fetch( postav,i,(0)); |
| 1862 | if (svp && (elem = *svp)) { |
| 1863 | sv_catsv(retval, elem)Perl_sv_catsv_flags( retval,elem,2); |
| 1864 | if (i < postlen) { |
| 1865 | sv_catpvs(retval, ";")Perl_sv_catpvn_flags( retval, ("" ";" ""), (sizeof(";")-1), 2 ); |
| 1866 | sv_catsv(retval, style.sep)Perl_sv_catsv_flags( retval,style.sep,2); |
| 1867 | sv_catsv(retval, style.pad)Perl_sv_catsv_flags( retval,style.pad,2); |
| 1868 | } |
| 1869 | } |
| 1870 | } |
| 1871 | sv_catpvs(retval, ";")Perl_sv_catpvn_flags( retval, ("" ";" ""), (sizeof(";")-1), 2 ); |
| 1872 | sv_catsv(retval, style.sep)Perl_sv_catsv_flags( retval,style.sep,2); |
| 1873 | } |
| 1874 | SvPVCLEAR(valstr)Perl_sv_setpv_bufsize( valstr,0,0); |
| 1875 | if (gimme == G_ARRAY3) { |
| 1876 | XPUSHs(retval)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (retval); } while (0); |
| 1877 | if (i < imax) /* not the last time thro ? */ |
| 1878 | retval = newSVpvs_flags("", SVs_TEMP)Perl_newSVpvn_flags( ("" "" ""), (sizeof("")-1), 0x00080000); |
| 1879 | } |
| 1880 | } |
| 1881 | |
| 1882 | /* we defer croaking until here so that temporary SVs and |
| 1883 | * buffers won't be leaked */ |
| 1884 | if (style.maxrecursed) |
| 1885 | croakPerl_croak("Recursion limit of %" IVdf"ld" " exceeded", |
| 1886 | style.maxrecurse); |
| 1887 | |
| 1888 | } |
| 1889 | else |
| 1890 | croakPerl_croak("Call to new() method failed to return HASH ref"); |
| 1891 | if (gimme != G_ARRAY3) |
| 1892 | XPUSHs(retval)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (retval); } while (0); |
| 1893 | } |
| 1894 | #line 1895 "Dumper.c" |
| 1895 | PUTBACKPL_stack_sp = sp; |
| 1896 | return; |
| 1897 | } |
| 1898 | } |
| 1899 | |
| 1900 | |
| 1901 | XS_EUPXS(XS_Data__Dumper__vstring)static void XS_Data__Dumper__vstring( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ |
| 1902 | XS_EUPXS(XS_Data__Dumper__vstring)static void XS_Data__Dumper__vstring( CV* cv __attribute__((unused ))) |
| 1903 | { |
| 1904 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); |
| 1905 | if (items != 1) |
| 1906 | croak_xs_usagePerl_croak_xs_usage(cv, "sv"); |
| 1907 | { |
| 1908 | SV * sv = ST(0)PL_stack_base[ax + (0)] |
| 1909 | ; |
| 1910 | SV * RETVAL; |
| 1911 | #line 1746 "Dumper.xs" |
| 1912 | { |
| 1913 | #ifdef SvVOK |
| 1914 | const MAGIC *mg; |
| 1915 | RETVAL = |
| 1916 | SvMAGICAL(sv)((sv)->sv_flags & (0x00200000|0x00400000|0x00800000)) && (mg = mg_findPerl_mg_find(sv, 'V')) |
| 1917 | ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)Perl_newSVpvn( (const char *)mg->mg_ptr,mg->mg_len) |
| 1918 | : &PL_sv_undef(PL_sv_immortals[1]); |
| 1919 | #else |
| 1920 | RETVAL = &PL_sv_undef(PL_sv_immortals[1]); |
| 1921 | #endif |
| 1922 | } |
| 1923 | #line 1924 "Dumper.c" |
| 1924 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); |
| 1925 | ST(0)PL_stack_base[ax + (0)] = RETVAL; |
| 1926 | } |
| 1927 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); |
| 1928 | } |
| 1929 | |
| 1930 | #ifdef __cplusplus |
| 1931 | extern "C" |
| 1932 | #endif |
| 1933 | XS_EXTERNAL(boot_Data__Dumper)void boot_Data__Dumper( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */ |
| 1934 | XS_EXTERNAL(boot_Data__Dumper)void boot_Data__Dumper( CV* cv __attribute__((unused))) |
| 1935 | { |
| 1936 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) |
| 1937 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); |
| 1938 | #else |
| 1939 | dVARstruct Perl___notused_struct; dXSBOOTARGSXSAPIVERCHKI32 ax = Perl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter )) << 16) | ((sizeof("" "2.174_01" "")-1) > 0xFF ? ( Perl_croak("panic: handshake overflow"), 0xFF) : (sizeof("" "2.174_01" "")-1) << 8) | ((((1)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | (( ((1)) ? (_Bool)1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Dumper.c", "v" "5" "." "32" "." "0", "2.174_01"); SV * *mark = PL_stack_base + ax; SV **sp = PL_stack_sp; I32 items = (I32)(sp - mark); |
| 1940 | #endif |
| 1941 | #if (PERL_REVISION5 == 5 && PERL_VERSION32 < 9) |
| 1942 | char* file = __FILE__"Dumper.c"; |
| 1943 | #else |
| 1944 | const char* file = __FILE__"Dumper.c"; |
| 1945 | #endif |
| 1946 | |
| 1947 | PERL_UNUSED_VAR(file)((void)sizeof(file)); |
| 1948 | |
| 1949 | PERL_UNUSED_VAR(cv)((void)sizeof(cv)); /* -W */ |
| 1950 | PERL_UNUSED_VAR(items)((void)sizeof(items)); /* -W */ |
| 1951 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) |
| 1952 | XS_VERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "2.174_01" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "2.174_01" "" )-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | (( ((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "" "")-1))), cv, "Dumper.c", items , ax, "2.174_01"); |
| 1953 | # ifdef XS_APIVERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "" "")-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | (((( 0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | ((((0)) ? (_Bool )1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Dumper.c", items, ax, "v" "5" "." "32" "." "0") |
| 1954 | XS_APIVERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "" "")-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | (((( 0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | ((((0)) ? (_Bool )1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Dumper.c", items, ax, "v" "5" "." "32" "." "0"); |
| 1955 | # endif |
| 1956 | #endif |
| 1957 | |
| 1958 | (void)newXSproto_portable("Data::Dumper::Dumpxs", XS_Data__Dumper_Dumpxs, file, "$;$$")Perl_newXS_flags( "Data::Dumper::Dumpxs",XS_Data__Dumper_Dumpxs ,file,"$;$$",0); |
| 1959 | (void)newXSproto_portable("Data::Dumper::_vstring", XS_Data__Dumper__vstring, file, "$")Perl_newXS_flags( "Data::Dumper::_vstring",XS_Data__Dumper__vstring ,file,"$",0); |
| 1960 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) |
| 1961 | # if PERL_VERSION_GE(5, 9, 0)((5*1000000 + 32*1000 + 1) >= (5*1000000 + 9*1000 + 0)) |
| 1962 | if (PL_unitcheckav) |
| 1963 | call_list(PL_scopestack_ix, PL_unitcheckav)Perl_call_list( PL_scopestack_ix,PL_unitcheckav); |
| 1964 | # endif |
| 1965 | XSRETURN_YESdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[0]) ); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); |
| 1966 | #else |
| 1967 | Perl_xs_boot_epilog(aTHX_ ax); |
| 1968 | #endif |
| 1969 | } |
| 1970 |