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 |