line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
2
|
|
|
|
|
|
#include "EXTERN.h" |
3
|
|
|
|
|
|
#include "perl.h" |
4
|
|
|
|
|
|
#include "XSUB.h" |
5
|
|
|
|
|
|
#ifdef USE_PPPORT_H |
6
|
|
|
|
|
|
# define NEED_my_snprintf |
7
|
|
|
|
|
|
# define NEED_sv_2pv_flags |
8
|
|
|
|
|
|
# include "ppport.h" |
9
|
|
|
|
|
|
#endif |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
#if PERL_VERSION < 8 |
12
|
|
|
|
|
|
# define DD_USE_OLD_ID_FORMAT |
13
|
|
|
|
|
|
#endif |
14
|
|
|
|
|
|
|
15
|
|
|
|
|
|
#ifndef isWORDCHAR |
16
|
|
|
|
|
|
# define isWORDCHAR(c) isALNUM(c) |
17
|
|
|
|
|
|
#endif |
18
|
|
|
|
|
|
|
19
|
|
|
|
|
|
static I32 num_q (const char *s, STRLEN slen); |
20
|
|
|
|
|
|
static I32 esc_q (char *dest, const char *src, STRLEN slen); |
21
|
|
|
|
|
|
static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq); |
22
|
|
|
|
|
|
static I32 needs_quote(const char *s, STRLEN len); |
23
|
|
|
|
|
|
static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n); |
24
|
|
|
|
|
|
static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, |
25
|
|
|
|
|
|
HV *seenhv, AV *postav, I32 *levelp, I32 indent, |
26
|
|
|
|
|
|
SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, |
27
|
|
|
|
|
|
SV *freezer, SV *toaster, |
28
|
|
|
|
|
|
I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, |
29
|
|
|
|
|
|
I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq); |
30
|
|
|
|
|
|
|
31
|
|
|
|
|
|
#ifndef HvNAME_get |
32
|
|
|
|
|
|
#define HvNAME_get HvNAME |
33
|
|
|
|
|
|
#endif |
34
|
|
|
|
|
|
|
35
|
|
|
|
|
|
/* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a |
36
|
|
|
|
|
|
* length parameter. This wrongly allowed reading beyond the end of buffer |
37
|
|
|
|
|
|
* given malformed input */ |
38
|
|
|
|
|
|
|
39
|
|
|
|
|
|
#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */ |
40
|
|
|
|
|
|
|
41
|
|
|
|
|
|
# ifdef EBCDIC |
42
|
|
|
|
|
|
# define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch)) |
43
|
|
|
|
|
|
# else |
44
|
|
|
|
|
|
# define UNI_TO_NATIVE(ch) (ch) |
45
|
|
|
|
|
|
# endif |
46
|
|
|
|
|
|
|
47
|
|
|
|
|
|
UV |
48
|
|
|
|
|
|
Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) |
49
|
|
|
|
|
|
{ |
50
|
|
|
|
|
|
const UV uv = utf8_to_uv(s, send - s, retlen, |
51
|
|
|
|
|
|
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); |
52
|
|
|
|
|
|
return UNI_TO_NATIVE(uv); |
53
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
55
|
|
|
|
|
|
# if !defined(PERL_IMPLICIT_CONTEXT) |
56
|
|
|
|
|
|
# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf |
57
|
|
|
|
|
|
# else |
58
|
|
|
|
|
|
# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) |
59
|
|
|
|
|
|
# endif |
60
|
|
|
|
|
|
|
61
|
|
|
|
|
|
#endif /* PERL_VERSION <= 6 */ |
62
|
|
|
|
|
|
|
63
|
|
|
|
|
|
/* Perl 5.7 through part of 5.15 */ |
64
|
|
|
|
|
|
#if PERL_VERSION > 6 && PERL_VERSION <= 15 && ! defined(utf8_to_uvchr_buf) |
65
|
|
|
|
|
|
|
66
|
|
|
|
|
|
UV |
67
|
|
|
|
|
|
Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) |
68
|
|
|
|
|
|
{ |
69
|
|
|
|
|
|
/* We have to discard for these versions; hence can read off the |
70
|
|
|
|
|
|
* end of the buffer if there is a malformation that indicates the |
71
|
|
|
|
|
|
* character is longer than the space available */ |
72
|
|
|
|
|
|
|
73
|
|
|
|
|
|
const UV uv = utf8_to_uvchr(s, retlen); |
74
|
|
|
|
|
|
return UNI_TO_NATIVE(uv); |
75
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
77
|
|
|
|
|
|
# if !defined(PERL_IMPLICIT_CONTEXT) |
78
|
|
|
|
|
|
# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf |
79
|
|
|
|
|
|
# else |
80
|
|
|
|
|
|
# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) |
81
|
|
|
|
|
|
# endif |
82
|
|
|
|
|
|
|
83
|
|
|
|
|
|
#endif /* PERL_VERSION > 6 && <= 15 */ |
84
|
|
|
|
|
|
|
85
|
|
|
|
|
|
/* Changes in 5.7 series mean that now IOK is only set if scalar is |
86
|
|
|
|
|
|
precisely integer but in 5.6 and earlier we need to do a more |
87
|
|
|
|
|
|
complex test */ |
88
|
|
|
|
|
|
#if PERL_VERSION <= 6 |
89
|
|
|
|
|
|
#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv))) |
90
|
|
|
|
|
|
#else |
91
|
|
|
|
|
|
#define DD_is_integer(sv) SvIOK(sv) |
92
|
|
|
|
|
|
#endif |
93
|
|
|
|
|
|
|
94
|
|
|
|
|
|
/* does a string need to be protected? */ |
95
|
|
|
|
|
|
static I32 |
96
|
362
|
|
|
|
|
needs_quote(const char *s, STRLEN len) |
97
|
|
|
|
|
|
{ |
98
|
362
|
|
|
|
|
const char *send = s+len; |
99
|
|
|
|
|
|
TOP: |
100
|
366
|
|
|
|
|
if (s[0] == ':') { |
101
|
46
|
|
|
|
|
if (++s
|
102
|
44
|
|
|
|
|
if (*s++ != ':') |
103
|
|
|
|
|
|
return 1; |
104
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
else |
106
|
|
|
|
|
|
return 1; |
107
|
|
|
|
|
|
} |
108
|
364
|
|
|
|
|
if (isIDFIRST(*s)) { |
109
|
870
|
|
|
|
|
while (++s
|
110
|
596
|
|
|
|
|
if (!isWORDCHAR(*s)) { |
111
|
6
|
|
|
|
|
if (*s == ':') |
112
|
|
|
|
|
|
goto TOP; |
113
|
|
|
|
|
|
else |
114
|
|
|
|
|
|
return 1; |
115
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
else |
118
|
|
|
|
|
|
return 1; |
119
|
|
|
|
|
|
return 0; |
120
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
122
|
|
|
|
|
|
/* Check that the SV can be represented as a simple decimal integer. |
123
|
|
|
|
|
|
* |
124
|
|
|
|
|
|
* The perl code does this by matching against /^(?:0|-?[1-9]\d{0,8})\z/ |
125
|
|
|
|
|
|
*/ |
126
|
|
|
|
|
|
static bool |
127
|
75946
|
|
|
|
|
safe_decimal_number(pTHX_ SV *val) { |
128
|
|
|
|
|
|
STRLEN len; |
129
|
75946
|
|
|
|
|
const char *p = SvPV(val, len); |
130
|
|
|
|
|
|
|
131
|
75946
|
|
|
|
|
if (len == 1 && *p == '0') |
132
|
|
|
|
|
|
return TRUE; |
133
|
|
|
|
|
|
|
134
|
75946
|
|
|
|
|
if (len && *p == '-') { |
135
|
0
|
|
|
|
|
++p; |
136
|
0
|
|
|
|
|
--len; |
137
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
139
|
75946
|
|
|
|
|
if (len == 0 || *p < '1' || *p > '9') |
140
|
|
|
|
|
|
return FALSE; |
141
|
|
|
|
|
|
|
142
|
72642
|
|
|
|
|
++p; |
143
|
72642
|
|
|
|
|
--len; |
144
|
|
|
|
|
|
|
145
|
72642
|
|
|
|
|
if (len > 8) |
146
|
|
|
|
|
|
return FALSE; |
147
|
|
|
|
|
|
|
148
|
217858
|
|
|
|
|
while (len > 0) { |
149
|
|
|
|
|
|
/* the perl code checks /\d/ but we don't want unicode digits here */ |
150
|
145220
|
|
|
|
|
if (*p < '0' || *p > '9') |
151
|
|
|
|
|
|
return FALSE; |
152
|
145220
|
|
|
|
|
++p; |
153
|
145220
|
|
|
|
|
--len; |
154
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
return TRUE; |
156
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
158
|
|
|
|
|
|
/* count the number of "'"s and "\"s in string */ |
159
|
|
|
|
|
|
static I32 |
160
|
|
|
|
|
|
num_q(const char *s, STRLEN slen) |
161
|
|
|
|
|
|
{ |
162
|
|
|
|
|
|
I32 ret = 0; |
163
|
|
|
|
|
|
|
164
|
317832
|
|
|
|
|
while (slen > 0) { |
165
|
291374
|
|
|
|
|
if (*s == '\'' || *s == '\\') |
166
|
4
|
|
|
|
|
++ret; |
167
|
291374
|
|
|
|
|
++s; |
168
|
291374
|
|
|
|
|
--slen; |
169
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
return ret; |
171
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
174
|
|
|
|
|
|
/* returns number of chars added to escape "'"s and "\"s in s */ |
175
|
|
|
|
|
|
/* slen number of characters in s will be escaped */ |
176
|
|
|
|
|
|
/* destination must be long enough for additional chars */ |
177
|
|
|
|
|
|
static I32 |
178
|
46210
|
|
|
|
|
esc_q(char *d, const char *s, STRLEN slen) |
179
|
|
|
|
|
|
{ |
180
|
|
|
|
|
|
I32 ret = 0; |
181
|
|
|
|
|
|
|
182
|
1807360
|
|
|
|
|
while (slen > 0) { |
183
|
1714940
|
|
|
|
|
switch (*s) { |
184
|
|
|
|
|
|
case '\'': |
185
|
|
|
|
|
|
case '\\': |
186
|
12
|
|
|
|
|
*d = '\\'; |
187
|
12
|
|
|
|
|
++d; ++ret; |
188
|
|
|
|
|
|
default: |
189
|
1714940
|
|
|
|
|
*d = *s; |
190
|
1714940
|
|
|
|
|
++d; ++s; --slen; |
191
|
1714940
|
|
|
|
|
break; |
192
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
} |
194
|
46210
|
|
|
|
|
return ret; |
195
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
197
|
|
|
|
|
|
/* this function is also misused for implementing $Useqq */ |
198
|
|
|
|
|
|
static I32 |
199
|
19490
|
|
|
|
|
esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) |
200
|
|
|
|
|
|
{ |
201
|
|
|
|
|
|
char *r, *rstart; |
202
|
|
|
|
|
|
const char *s = src; |
203
|
19490
|
|
|
|
|
const char * const send = src + slen; |
204
|
19490
|
|
|
|
|
STRLEN j, cur = SvCUR(sv); |
205
|
|
|
|
|
|
/* Could count 128-255 and 256+ in two variables, if we want to |
206
|
|
|
|
|
|
be like &qquote and make a distinction. */ |
207
|
|
|
|
|
|
STRLEN grow = 0; /* bytes needed to represent chars 128+ */ |
208
|
|
|
|
|
|
/* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */ |
209
|
|
|
|
|
|
STRLEN backslashes = 0; |
210
|
|
|
|
|
|
STRLEN single_quotes = 0; |
211
|
|
|
|
|
|
STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ |
212
|
|
|
|
|
|
STRLEN normal = 0; |
213
|
|
|
|
|
|
int increment; |
214
|
|
|
|
|
|
UV next; |
215
|
|
|
|
|
|
|
216
|
|
|
|
|
|
/* this will need EBCDICification */ |
217
|
173884
|
|
|
|
|
for (s = src; s < send; do_utf8 ? s += increment : s++) { |
218
|
154394
|
|
|
|
|
const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; |
219
|
|
|
|
|
|
|
220
|
|
|
|
|
|
/* check for invalid utf8 */ |
221
|
154394
|
|
|
|
|
increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); |
222
|
|
|
|
|
|
|
223
|
|
|
|
|
|
/* this is only used to check if the next character is an |
224
|
|
|
|
|
|
* ASCII digit, which are invariant, so if the following collects |
225
|
|
|
|
|
|
* a UTF-8 start byte it does no harm |
226
|
|
|
|
|
|
*/ |
227
|
154394
|
|
|
|
|
next = (s + increment >= send ) ? 0 : *(U8*)(s+increment); |
228
|
|
|
|
|
|
|
229
|
|
|
|
|
|
#ifdef EBCDIC |
230
|
|
|
|
|
|
if (!isprint(k) || k > 256) { |
231
|
|
|
|
|
|
#else |
232
|
154394
|
|
|
|
|
if (k > 127) { |
233
|
|
|
|
|
|
#endif |
234
|
|
|
|
|
|
/* 4: \x{} then count the number of hex digits. */ |
235
|
1080
|
|
|
|
|
grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : |
236
|
|
|
|
|
|
#if UVSIZE == 4 |
237
|
|
|
|
|
|
8 /* We may allocate a bit more than the minimum here. */ |
238
|
|
|
|
|
|
#else |
239
|
|
|
|
|
|
k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 |
240
|
|
|
|
|
|
#endif |
241
|
|
|
|
|
|
); |
242
|
|
|
|
|
|
#ifndef EBCDIC |
243
|
306366
|
|
|
|
|
} else if (useqq && |
244
|
|
|
|
|
|
/* we can't use the short form like '\0' if followed by a digit */ |
245
|
306062
|
|
|
|
|
(((k >= 7 && k <= 10) || k == 12 || k == 13 || k == 27) |
246
|
152990
|
|
|
|
|
|| (k < 8 && (next < '0' || next > '9')))) { |
247
|
130
|
|
|
|
|
grow += 2; |
248
|
153184
|
|
|
|
|
} else if (useqq && k <= 31 && (next < '0' || next > '9')) { |
249
|
144
|
|
|
|
|
grow += 3; |
250
|
153040
|
|
|
|
|
} else if (useqq && (k <= 31 || k >= 127)) { |
251
|
16
|
|
|
|
|
grow += 4; |
252
|
|
|
|
|
|
#endif |
253
|
153024
|
|
|
|
|
} else if (k == '\\') { |
254
|
12
|
|
|
|
|
backslashes++; |
255
|
153012
|
|
|
|
|
} else if (k == '\'') { |
256
|
116
|
|
|
|
|
single_quotes++; |
257
|
152896
|
|
|
|
|
} else if (k == '"' || k == '$' || k == '@') { |
258
|
44
|
|
|
|
|
qq_escapables++; |
259
|
|
|
|
|
|
} else { |
260
|
152852
|
|
|
|
|
normal++; |
261
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
} |
263
|
19490
|
|
|
|
|
if (grow || useqq) { |
264
|
|
|
|
|
|
/* We have something needing hex. 3 is ""\0 */ |
265
|
19480
|
|
|
|
|
sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes |
266
|
|
|
|
|
|
+ 2*qq_escapables + normal); |
267
|
19480
|
|
|
|
|
rstart = r = SvPVX(sv) + cur; |
268
|
|
|
|
|
|
|
269
|
19480
|
|
|
|
|
*r++ = '"'; |
270
|
|
|
|
|
|
|
271
|
173642
|
|
|
|
|
for (s = src; s < send; do_utf8 ? s += UTF8SKIP(s) : s++) { |
272
|
154162
|
|
|
|
|
const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; |
273
|
|
|
|
|
|
|
274
|
154162
|
|
|
|
|
if (k == '"' || k == '\\' || k == '$' || k == '@') { |
275
|
48
|
|
|
|
|
*r++ = '\\'; |
276
|
48
|
|
|
|
|
*r++ = (char)k; |
277
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
else |
279
|
|
|
|
|
|
#ifdef EBCDIC |
280
|
|
|
|
|
|
if (isprint(k) && k < 256) |
281
|
|
|
|
|
|
#else |
282
|
154114
|
|
|
|
|
if (useqq && (k <= 31 || k == 127 || (!do_utf8 && k > 127))) { |
283
|
|
|
|
|
|
bool next_is_digit; |
284
|
|
|
|
|
|
|
285
|
802
|
|
|
|
|
*r++ = '\\'; |
286
|
802
|
|
|
|
|
switch (k) { |
287
|
8
|
|
|
|
|
case 7: *r++ = 'a'; break; |
288
|
8
|
|
|
|
|
case 8: *r++ = 'b'; break; |
289
|
8
|
|
|
|
|
case 9: *r++ = 't'; break; |
290
|
10
|
|
|
|
|
case 10: *r++ = 'n'; break; |
291
|
8
|
|
|
|
|
case 12: *r++ = 'f'; break; |
292
|
8
|
|
|
|
|
case 13: *r++ = 'r'; break; |
293
|
12
|
|
|
|
|
case 27: *r++ = 'e'; break; |
294
|
|
|
|
|
|
default: |
295
|
740
|
|
|
|
|
increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); |
296
|
|
|
|
|
|
|
297
|
|
|
|
|
|
/* only ASCII digits matter here, which are invariant, |
298
|
|
|
|
|
|
* since we only encode characters \377 and under, or |
299
|
|
|
|
|
|
* \x177 and under for a unicode string |
300
|
|
|
|
|
|
*/ |
301
|
740
|
|
|
|
|
next = (s+increment < send) ? *(U8*)(s+increment) : 0; |
302
|
740
|
|
|
|
|
next_is_digit = next >= '0' && next <= '9'; |
303
|
|
|
|
|
|
|
304
|
|
|
|
|
|
/* faster than |
305
|
|
|
|
|
|
* r = r + my_sprintf(r, "%o", k); |
306
|
|
|
|
|
|
*/ |
307
|
740
|
|
|
|
|
if (k <= 7 && !next_is_digit) { |
308
|
68
|
|
|
|
|
*r++ = (char)k + '0'; |
309
|
672
|
|
|
|
|
} else if (k <= 63 && !next_is_digit) { |
310
|
144
|
|
|
|
|
*r++ = (char)(k>>3) + '0'; |
311
|
144
|
|
|
|
|
*r++ = (char)(k&7) + '0'; |
312
|
|
|
|
|
|
} else { |
313
|
528
|
|
|
|
|
*r++ = (char)(k>>6) + '0'; |
314
|
528
|
|
|
|
|
*r++ = (char)((k&63)>>3) + '0'; |
315
|
528
|
|
|
|
|
*r++ = (char)(k&7) + '0'; |
316
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
} |
319
|
153312
|
|
|
|
|
else if (k < 0x80) |
320
|
|
|
|
|
|
#endif |
321
|
152744
|
|
|
|
|
*r++ = (char)k; |
322
|
|
|
|
|
|
else { |
323
|
|
|
|
|
|
#if PERL_VERSION < 10 |
324
|
|
|
|
|
|
sprintf(r, "\\x{%"UVxf"}", k); |
325
|
|
|
|
|
|
r += strlen(r); |
326
|
|
|
|
|
|
/* my_sprintf is not supported by ppport.h */ |
327
|
|
|
|
|
|
#else |
328
|
568
|
|
|
|
|
r = r + my_sprintf(r, "\\x{%"UVxf"}", k); |
329
|
|
|
|
|
|
#endif |
330
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
} |
332
|
19480
|
|
|
|
|
*r++ = '"'; |
333
|
|
|
|
|
|
} else { |
334
|
|
|
|
|
|
/* Single quotes. */ |
335
|
10
|
|
|
|
|
sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes |
336
|
|
|
|
|
|
+ qq_escapables + normal); |
337
|
10
|
|
|
|
|
rstart = r = SvPVX(sv) + cur; |
338
|
10
|
|
|
|
|
*r++ = '\''; |
339
|
242
|
|
|
|
|
for (s = src; s < send; s ++) { |
340
|
232
|
|
|
|
|
const char k = *s; |
341
|
232
|
|
|
|
|
if (k == '\'' || k == '\\') |
342
|
104
|
|
|
|
|
*r++ = '\\'; |
343
|
232
|
|
|
|
|
*r++ = k; |
344
|
|
|
|
|
|
} |
345
|
10
|
|
|
|
|
*r++ = '\''; |
346
|
|
|
|
|
|
} |
347
|
19490
|
|
|
|
|
*r = '\0'; |
348
|
19490
|
|
|
|
|
j = r - rstart; |
349
|
19490
|
|
|
|
|
SvCUR_set(sv, cur + j); |
350
|
|
|
|
|
|
|
351
|
19490
|
|
|
|
|
return j; |
352
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
354
|
|
|
|
|
|
/* append a repeated string to an SV */ |
355
|
|
|
|
|
|
static SV * |
356
|
113384
|
|
|
|
|
sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) |
357
|
|
|
|
|
|
{ |
358
|
113384
|
|
|
|
|
if (!sv) |
359
|
113302
|
|
|
|
|
sv = newSVpvn("", 0); |
360
|
|
|
|
|
|
#ifdef DEBUGGING |
361
|
|
|
|
|
|
else |
362
|
|
|
|
|
|
assert(SvTYPE(sv) >= SVt_PV); |
363
|
|
|
|
|
|
#endif |
364
|
|
|
|
|
|
|
365
|
113384
|
|
|
|
|
if (n > 0) { |
366
|
105344
|
|
|
|
|
SvGROW(sv, len*n + SvCUR(sv) + 1); |
367
|
105344
|
|
|
|
|
if (len == 1) { |
368
|
74920
|
|
|
|
|
char * const start = SvPVX(sv) + SvCUR(sv); |
369
|
74920
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) + n); |
370
|
74920
|
|
|
|
|
start[n] = '\0'; |
371
|
743580
|
|
|
|
|
while (n > 0) |
372
|
593740
|
|
|
|
|
start[--n] = str[0]; |
373
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
else |
375
|
90582
|
|
|
|
|
while (n > 0) { |
376
|
60158
|
|
|
|
|
sv_catpvn(sv, str, len); |
377
|
60158
|
|
|
|
|
--n; |
378
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
} |
380
|
113384
|
|
|
|
|
return sv; |
381
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
383
|
|
|
|
|
|
/* |
384
|
|
|
|
|
|
* This ought to be split into smaller functions. (it is one long function since |
385
|
|
|
|
|
|
* it exactly parallels the perl version, which was one long thing for |
386
|
|
|
|
|
|
* efficiency raisins.) Ugggh! |
387
|
|
|
|
|
|
*/ |
388
|
|
|
|
|
|
static I32 |
389
|
231732
|
|
|
|
|
DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, |
390
|
|
|
|
|
|
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, |
391
|
|
|
|
|
|
SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, |
392
|
|
|
|
|
|
I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys, |
393
|
|
|
|
|
|
int use_sparse_seen_hash, I32 useqq) |
394
|
|
|
|
|
|
{ |
395
|
|
|
|
|
|
char tmpbuf[128]; |
396
|
|
|
|
|
|
Size_t i; |
397
|
|
|
|
|
|
char *c, *r, *realpack; |
398
|
|
|
|
|
|
#ifdef DD_USE_OLD_ID_FORMAT |
399
|
|
|
|
|
|
char id[128]; |
400
|
|
|
|
|
|
#else |
401
|
|
|
|
|
|
UV id_buffer; |
402
|
|
|
|
|
|
char *const id = (char *)&id_buffer; |
403
|
|
|
|
|
|
#endif |
404
|
|
|
|
|
|
SV **svp; |
405
|
|
|
|
|
|
SV *sv, *ipad, *ival; |
406
|
|
|
|
|
|
SV *blesspad = Nullsv; |
407
|
|
|
|
|
|
AV *seenentry = NULL; |
408
|
|
|
|
|
|
char *iname; |
409
|
|
|
|
|
|
STRLEN inamelen, idlen = 0; |
410
|
|
|
|
|
|
U32 realtype; |
411
|
|
|
|
|
|
bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it. |
412
|
|
|
|
|
|
in later perls we should actually check the classname of the |
413
|
|
|
|
|
|
engine. this gets tricky as it involves lexical issues that arent so |
414
|
|
|
|
|
|
easy to resolve */ |
415
|
|
|
|
|
|
bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */ |
416
|
|
|
|
|
|
|
417
|
231732
|
|
|
|
|
if (!val) |
418
|
|
|
|
|
|
return 0; |
419
|
|
|
|
|
|
|
420
|
|
|
|
|
|
/* If the ouput buffer has less than some arbitrary amount of space |
421
|
|
|
|
|
|
remaining, then enlarge it. For the test case (25M of output), |
422
|
|
|
|
|
|
*1.1 was slower, *2.0 was the same, so the first guess of 1.5 is |
423
|
|
|
|
|
|
deemed to be good enough. */ |
424
|
231732
|
|
|
|
|
if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) { |
425
|
120222
|
|
|
|
|
sv_grow(retval, SvCUR(retval) * 3 / 2); |
426
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
428
|
231732
|
|
|
|
|
realtype = SvTYPE(val); |
429
|
|
|
|
|
|
|
430
|
231732
|
|
|
|
|
if (SvGMAGICAL(val)) |
431
|
0
|
|
|
|
|
mg_get(val); |
432
|
231732
|
|
|
|
|
if (SvROK(val)) { |
433
|
|
|
|
|
|
|
434
|
|
|
|
|
|
/* If a freeze method is provided and the object has it, call |
435
|
|
|
|
|
|
it. Warn on errors. */ |
436
|
23938
|
|
|
|
|
if (SvOBJECT(SvRV(val)) && freezer && |
437
|
172
|
|
|
|
|
SvPOK(freezer) && SvCUR(freezer) && |
438
|
14
|
|
|
|
|
gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer), |
439
|
|
|
|
|
|
SvCUR(freezer), -1) != NULL) |
440
|
|
|
|
|
|
{ |
441
|
12
|
|
|
|
|
dSP; ENTER; SAVETMPS; PUSHMARK(sp); |
442
|
12
|
|
|
|
|
XPUSHs(val); PUTBACK; |
443
|
12
|
|
|
|
|
i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID|G_DISCARD); |
444
|
12
|
|
|
|
|
SPAGAIN; |
445
|
12
|
|
|
|
|
if (SvTRUE(ERRSV)) |
446
|
2
|
|
|
|
|
warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); |
447
|
12
|
|
|
|
|
PUTBACK; FREETMPS; LEAVE; |
448
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
450
|
23858
|
|
|
|
|
ival = SvRV(val); |
451
|
23858
|
|
|
|
|
realtype = SvTYPE(ival); |
452
|
|
|
|
|
|
#ifdef DD_USE_OLD_ID_FORMAT |
453
|
|
|
|
|
|
idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival)); |
454
|
|
|
|
|
|
#else |
455
|
23858
|
|
|
|
|
id_buffer = PTR2UV(ival); |
456
|
|
|
|
|
|
idlen = sizeof(id_buffer); |
457
|
|
|
|
|
|
#endif |
458
|
23858
|
|
|
|
|
if (SvOBJECT(ival)) |
459
|
80
|
|
|
|
|
realpack = HvNAME_get(SvSTASH(ival)); |
460
|
|
|
|
|
|
else |
461
|
|
|
|
|
|
realpack = NULL; |
462
|
|
|
|
|
|
|
463
|
|
|
|
|
|
/* if it has a name, we need to either look it up, or keep a tab |
464
|
|
|
|
|
|
* on it so we know when we hit it later |
465
|
|
|
|
|
|
*/ |
466
|
23858
|
|
|
|
|
if (namelen) { |
467
|
23858
|
|
|
|
|
if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) |
468
|
652
|
|
|
|
|
&& (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) |
469
|
|
|
|
|
|
{ |
470
|
|
|
|
|
|
SV *othername; |
471
|
652
|
|
|
|
|
if ((svp = av_fetch(seenentry, 0, FALSE)) |
472
|
652
|
|
|
|
|
&& (othername = *svp)) |
473
|
|
|
|
|
|
{ |
474
|
828
|
|
|
|
|
if (purity && *levelp > 0) { |
475
|
|
|
|
|
|
SV *postentry; |
476
|
|
|
|
|
|
|
477
|
176
|
|
|
|
|
if (realtype == SVt_PVHV) |
478
|
56
|
|
|
|
|
sv_catpvn(retval, "{}", 2); |
479
|
120
|
|
|
|
|
else if (realtype == SVt_PVAV) |
480
|
76
|
|
|
|
|
sv_catpvn(retval, "[]", 2); |
481
|
|
|
|
|
|
else |
482
|
44
|
|
|
|
|
sv_catpvn(retval, "do{my $o}", 9); |
483
|
176
|
|
|
|
|
postentry = newSVpvn(name, namelen); |
484
|
176
|
|
|
|
|
sv_catpvn(postentry, " = ", 3); |
485
|
176
|
|
|
|
|
sv_catsv(postentry, othername); |
486
|
176
|
|
|
|
|
av_push(postav, postentry); |
487
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
else { |
489
|
476
|
|
|
|
|
if (name[0] == '@' || name[0] == '%') { |
490
|
80
|
|
|
|
|
if ((SvPVX_const(othername))[0] == '\\' && |
491
|
20
|
|
|
|
|
(SvPVX_const(othername))[1] == name[0]) { |
492
|
20
|
|
|
|
|
sv_catpvn(retval, SvPVX_const(othername)+1, |
493
|
|
|
|
|
|
SvCUR(othername)-1); |
494
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
else { |
496
|
40
|
|
|
|
|
sv_catpvn(retval, name, 1); |
497
|
40
|
|
|
|
|
sv_catpvn(retval, "{", 1); |
498
|
40
|
|
|
|
|
sv_catsv(retval, othername); |
499
|
40
|
|
|
|
|
sv_catpvn(retval, "}", 1); |
500
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
else |
503
|
416
|
|
|
|
|
sv_catsv(retval, othername); |
504
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
return 1; |
506
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
else { |
508
|
|
|
|
|
|
#ifdef DD_USE_OLD_ID_FORMAT |
509
|
|
|
|
|
|
warn("ref name not found for %s", id); |
510
|
|
|
|
|
|
#else |
511
|
0
|
|
|
|
|
warn("ref name not found for 0x%"UVxf, PTR2UV(ival)); |
512
|
|
|
|
|
|
#endif |
513
|
0
|
|
|
|
|
return 0; |
514
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
else { /* store our name and continue */ |
517
|
|
|
|
|
|
SV *namesv; |
518
|
23206
|
|
|
|
|
if (name[0] == '@' || name[0] == '%') { |
519
|
66
|
|
|
|
|
namesv = newSVpvn("\\", 1); |
520
|
66
|
|
|
|
|
sv_catpvn(namesv, name, namelen); |
521
|
|
|
|
|
|
} |
522
|
23140
|
|
|
|
|
else if (realtype == SVt_PVCV && name[0] == '*') { |
523
|
0
|
|
|
|
|
namesv = newSVpvn("\\", 2); |
524
|
0
|
|
|
|
|
sv_catpvn(namesv, name, namelen); |
525
|
0
|
|
|
|
|
(SvPVX(namesv))[1] = '&'; |
526
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
else |
528
|
23140
|
|
|
|
|
namesv = newSVpvn(name, namelen); |
529
|
23206
|
|
|
|
|
seenentry = newAV(); |
530
|
23206
|
|
|
|
|
av_push(seenentry, namesv); |
531
|
|
|
|
|
|
(void)SvREFCNT_inc(val); |
532
|
23206
|
|
|
|
|
av_push(seenentry, val); |
533
|
23206
|
|
|
|
|
(void)hv_store(seenhv, id, idlen, |
534
|
|
|
|
|
|
newRV_inc((SV*)seenentry), 0); |
535
|
23206
|
|
|
|
|
SvREFCNT_dec(seenentry); |
536
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
/* regexps dont have to be blessed into package "Regexp" |
539
|
|
|
|
|
|
* they can be blessed into any package. |
540
|
|
|
|
|
|
*/ |
541
|
|
|
|
|
|
#if PERL_VERSION < 8 |
542
|
|
|
|
|
|
if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) |
543
|
|
|
|
|
|
#elif PERL_VERSION < 11 |
544
|
|
|
|
|
|
if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr)) |
545
|
|
|
|
|
|
#else |
546
|
23206
|
|
|
|
|
if (realpack && realtype == SVt_REGEXP) |
547
|
|
|
|
|
|
#endif |
548
|
|
|
|
|
|
{ |
549
|
|
|
|
|
|
is_regex = 1; |
550
|
4
|
|
|
|
|
if (strEQ(realpack, "Regexp")) |
551
|
|
|
|
|
|
no_bless = 1; |
552
|
|
|
|
|
|
else |
553
|
|
|
|
|
|
no_bless = 0; |
554
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
556
|
|
|
|
|
|
/* If purity is not set and maxdepth is set, then check depth: |
557
|
|
|
|
|
|
* if we have reached maximum depth, return the string |
558
|
|
|
|
|
|
* representation of the thing we are currently examining |
559
|
|
|
|
|
|
* at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). |
560
|
|
|
|
|
|
*/ |
561
|
23206
|
|
|
|
|
if (!purity && maxdepth > 0 && *levelp >= maxdepth) { |
562
|
|
|
|
|
|
STRLEN vallen; |
563
|
12
|
|
|
|
|
const char * const valstr = SvPV(val,vallen); |
564
|
12
|
|
|
|
|
sv_catpvn(retval, "'", 1); |
565
|
12
|
|
|
|
|
sv_catpvn(retval, valstr, vallen); |
566
|
12
|
|
|
|
|
sv_catpvn(retval, "'", 1); |
567
|
12
|
|
|
|
|
return 1; |
568
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
570
|
23194
|
|
|
|
|
if (realpack && !no_bless) { /* we have a blessed ref */ |
571
|
|
|
|
|
|
STRLEN blesslen; |
572
|
78
|
|
|
|
|
const char * const blessstr = SvPV(bless, blesslen); |
573
|
78
|
|
|
|
|
sv_catpvn(retval, blessstr, blesslen); |
574
|
78
|
|
|
|
|
sv_catpvn(retval, "( ", 2); |
575
|
78
|
|
|
|
|
if (indent >= 2) { |
576
|
|
|
|
|
|
blesspad = apad; |
577
|
70
|
|
|
|
|
apad = newSVsv(apad); |
578
|
70
|
|
|
|
|
sv_x(aTHX_ apad, " ", 1, blesslen+2); |
579
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
582
|
23194
|
|
|
|
|
(*levelp)++; |
583
|
23194
|
|
|
|
|
ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp); |
584
|
|
|
|
|
|
|
585
|
23194
|
|
|
|
|
if (is_regex) |
586
|
|
|
|
|
|
{ |
587
|
|
|
|
|
|
STRLEN rlen; |
588
|
4
|
|
|
|
|
const char *rval = SvPV(val, rlen); |
589
|
4
|
|
|
|
|
const char * const rend = rval+rlen; |
590
|
|
|
|
|
|
const char *slash = rval; |
591
|
4
|
|
|
|
|
sv_catpvn(retval, "qr/", 3); |
592
|
30
|
|
|
|
|
for (;slash < rend; slash++) { |
593
|
26
|
|
|
|
|
if (*slash == '\\') { ++slash; continue; } |
594
|
24
|
|
|
|
|
if (*slash == '/') { |
595
|
0
|
|
|
|
|
sv_catpvn(retval, rval, slash-rval); |
596
|
0
|
|
|
|
|
sv_catpvn(retval, "\\/", 2); |
597
|
0
|
|
|
|
|
rlen -= slash-rval+1; |
598
|
0
|
|
|
|
|
rval = slash+1; |
599
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
} |
601
|
4
|
|
|
|
|
sv_catpvn(retval, rval, rlen); |
602
|
4
|
|
|
|
|
sv_catpvn(retval, "/", 1); |
603
|
|
|
|
|
|
} |
604
|
23190
|
|
|
|
|
else if ( |
605
|
|
|
|
|
|
#if PERL_VERSION < 9 |
606
|
|
|
|
|
|
realtype <= SVt_PVBM |
607
|
|
|
|
|
|
#else |
608
|
|
|
|
|
|
realtype <= SVt_PVMG |
609
|
|
|
|
|
|
#endif |
610
|
|
|
|
|
|
) { /* scalar ref */ |
611
|
144
|
|
|
|
|
SV * const namesv = newSVpvn("${", 2); |
612
|
144
|
|
|
|
|
sv_catpvn(namesv, name, namelen); |
613
|
144
|
|
|
|
|
sv_catpvn(namesv, "}", 1); |
614
|
144
|
|
|
|
|
if (realpack) { /* blessed */ |
615
|
0
|
|
|
|
|
sv_catpvn(retval, "do{\\(my $o = ", 13); |
616
|
0
|
|
|
|
|
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, |
617
|
|
|
|
|
|
postav, levelp, indent, pad, xpad, apad, sep, pair, |
618
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, bless, |
619
|
|
|
|
|
|
maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
620
|
0
|
|
|
|
|
sv_catpvn(retval, ")}", 2); |
621
|
|
|
|
|
|
} /* plain */ |
622
|
|
|
|
|
|
else { |
623
|
144
|
|
|
|
|
sv_catpvn(retval, "\\", 1); |
624
|
144
|
|
|
|
|
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, |
625
|
|
|
|
|
|
postav, levelp, indent, pad, xpad, apad, sep, pair, |
626
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, bless, |
627
|
|
|
|
|
|
maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
628
|
|
|
|
|
|
} |
629
|
144
|
|
|
|
|
SvREFCNT_dec(namesv); |
630
|
|
|
|
|
|
} |
631
|
23046
|
|
|
|
|
else if (realtype == SVt_PVGV) { /* glob ref */ |
632
|
44
|
|
|
|
|
SV * const namesv = newSVpvn("*{", 2); |
633
|
44
|
|
|
|
|
sv_catpvn(namesv, name, namelen); |
634
|
44
|
|
|
|
|
sv_catpvn(namesv, "}", 1); |
635
|
44
|
|
|
|
|
sv_catpvn(retval, "\\", 1); |
636
|
44
|
|
|
|
|
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, |
637
|
|
|
|
|
|
postav, levelp, indent, pad, xpad, apad, sep, pair, |
638
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, bless, |
639
|
|
|
|
|
|
maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
640
|
44
|
|
|
|
|
SvREFCNT_dec(namesv); |
641
|
|
|
|
|
|
} |
642
|
23002
|
|
|
|
|
else if (realtype == SVt_PVAV) { |
643
|
|
|
|
|
|
SV *totpad; |
644
|
|
|
|
|
|
SSize_t ix = 0; |
645
|
11938
|
|
|
|
|
const SSize_t ixmax = av_len((AV *)ival); |
646
|
|
|
|
|
|
|
647
|
11938
|
|
|
|
|
SV * const ixsv = newSViv(0); |
648
|
|
|
|
|
|
/* allowing for a 24 char wide array index */ |
649
|
11938
|
|
|
|
|
New(0, iname, namelen+28, char); |
650
|
|
|
|
|
|
(void)strcpy(iname, name); |
651
|
|
|
|
|
|
inamelen = namelen; |
652
|
11938
|
|
|
|
|
if (name[0] == '@') { |
653
|
46
|
|
|
|
|
sv_catpvn(retval, "(", 1); |
654
|
46
|
|
|
|
|
iname[0] = '$'; |
655
|
|
|
|
|
|
} |
656
|
|
|
|
|
|
else { |
657
|
11892
|
|
|
|
|
sv_catpvn(retval, "[", 1); |
658
|
|
|
|
|
|
/* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ |
659
|
|
|
|
|
|
/*if (namelen > 0 |
660
|
|
|
|
|
|
&& name[namelen-1] != ']' && name[namelen-1] != '}' |
661
|
|
|
|
|
|
&& (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ |
662
|
11892
|
|
|
|
|
if ((namelen > 0 |
663
|
11892
|
|
|
|
|
&& name[namelen-1] != ']' && name[namelen-1] != '}') |
664
|
6924
|
|
|
|
|
|| (namelen > 4 |
665
|
6924
|
|
|
|
|
&& (name[1] == '{' |
666
|
6920
|
|
|
|
|
|| (name[0] == '\\' && name[2] == '{')))) |
667
|
|
|
|
|
|
{ |
668
|
4972
|
|
|
|
|
iname[inamelen++] = '-'; iname[inamelen++] = '>'; |
669
|
4972
|
|
|
|
|
iname[inamelen] = '\0'; |
670
|
|
|
|
|
|
} |
671
|
|
|
|
|
|
} |
672
|
11946
|
|
|
|
|
if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && |
673
|
16
|
|
|
|
|
(instr(iname+inamelen-8, "{SCALAR}") || |
674
|
8
|
|
|
|
|
instr(iname+inamelen-7, "{ARRAY}") || |
675
|
0
|
|
|
|
|
instr(iname+inamelen-6, "{HASH}"))) { |
676
|
8
|
|
|
|
|
iname[inamelen++] = '-'; iname[inamelen++] = '>'; |
677
|
|
|
|
|
|
} |
678
|
11938
|
|
|
|
|
iname[inamelen++] = '['; iname[inamelen] = '\0'; |
679
|
11938
|
|
|
|
|
totpad = newSVsv(sep); |
680
|
11938
|
|
|
|
|
sv_catsv(totpad, pad); |
681
|
11938
|
|
|
|
|
sv_catsv(totpad, apad); |
682
|
|
|
|
|
|
|
683
|
124038
|
|
|
|
|
for (ix = 0; ix <= ixmax; ++ix) { |
684
|
|
|
|
|
|
STRLEN ilen; |
685
|
|
|
|
|
|
SV *elem; |
686
|
112100
|
|
|
|
|
svp = av_fetch((AV*)ival, ix, FALSE); |
687
|
112100
|
|
|
|
|
if (svp) |
688
|
112100
|
|
|
|
|
elem = *svp; |
689
|
|
|
|
|
|
else |
690
|
|
|
|
|
|
elem = &PL_sv_undef; |
691
|
|
|
|
|
|
|
692
|
|
|
|
|
|
ilen = inamelen; |
693
|
112100
|
|
|
|
|
sv_setiv(ixsv, ix); |
694
|
|
|
|
|
|
#if PERL_VERSION < 10 |
695
|
|
|
|
|
|
(void) sprintf(iname+ilen, "%"IVdf, (IV)ix); |
696
|
|
|
|
|
|
ilen = strlen(iname); |
697
|
|
|
|
|
|
#else |
698
|
224200
|
|
|
|
|
ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix); |
699
|
|
|
|
|
|
#endif |
700
|
112100
|
|
|
|
|
iname[ilen++] = ']'; iname[ilen] = '\0'; |
701
|
112100
|
|
|
|
|
if (indent >= 3) { |
702
|
32
|
|
|
|
|
sv_catsv(retval, totpad); |
703
|
32
|
|
|
|
|
sv_catsv(retval, ipad); |
704
|
32
|
|
|
|
|
sv_catpvn(retval, "#", 1); |
705
|
32
|
|
|
|
|
sv_catsv(retval, ixsv); |
706
|
|
|
|
|
|
} |
707
|
112100
|
|
|
|
|
sv_catsv(retval, totpad); |
708
|
112100
|
|
|
|
|
sv_catsv(retval, ipad); |
709
|
112100
|
|
|
|
|
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, |
710
|
|
|
|
|
|
levelp, indent, pad, xpad, apad, sep, pair, |
711
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, bless, |
712
|
|
|
|
|
|
maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
713
|
112100
|
|
|
|
|
if (ix < ixmax) |
714
|
102106
|
|
|
|
|
sv_catpvn(retval, ",", 1); |
715
|
|
|
|
|
|
} |
716
|
11938
|
|
|
|
|
if (ixmax >= 0) { |
717
|
9994
|
|
|
|
|
SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1); |
718
|
9994
|
|
|
|
|
sv_catsv(retval, totpad); |
719
|
9994
|
|
|
|
|
sv_catsv(retval, opad); |
720
|
9994
|
|
|
|
|
SvREFCNT_dec(opad); |
721
|
|
|
|
|
|
} |
722
|
11938
|
|
|
|
|
if (name[0] == '@') |
723
|
46
|
|
|
|
|
sv_catpvn(retval, ")", 1); |
724
|
|
|
|
|
|
else |
725
|
11892
|
|
|
|
|
sv_catpvn(retval, "]", 1); |
726
|
11938
|
|
|
|
|
SvREFCNT_dec(ixsv); |
727
|
11938
|
|
|
|
|
SvREFCNT_dec(totpad); |
728
|
11938
|
|
|
|
|
Safefree(iname); |
729
|
|
|
|
|
|
} |
730
|
11064
|
|
|
|
|
else if (realtype == SVt_PVHV) { |
731
|
|
|
|
|
|
SV *totpad, *newapad; |
732
|
|
|
|
|
|
SV *sname; |
733
|
|
|
|
|
|
HE *entry; |
734
|
|
|
|
|
|
char *key; |
735
|
|
|
|
|
|
I32 klen; |
736
|
|
|
|
|
|
SV *hval; |
737
|
|
|
|
|
|
AV *keys = NULL; |
738
|
|
|
|
|
|
|
739
|
11054
|
|
|
|
|
SV * const iname = newSVpvn(name, namelen); |
740
|
11054
|
|
|
|
|
if (name[0] == '%') { |
741
|
20
|
|
|
|
|
sv_catpvn(retval, "(", 1); |
742
|
20
|
|
|
|
|
(SvPVX(iname))[0] = '$'; |
743
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
else { |
745
|
11034
|
|
|
|
|
sv_catpvn(retval, "{", 1); |
746
|
|
|
|
|
|
/* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ |
747
|
11034
|
|
|
|
|
if ((namelen > 0 |
748
|
11034
|
|
|
|
|
&& name[namelen-1] != ']' && name[namelen-1] != '}') |
749
|
7132
|
|
|
|
|
|| (namelen > 4 |
750
|
7132
|
|
|
|
|
&& (name[1] == '{' |
751
|
7124
|
|
|
|
|
|| (name[0] == '\\' && name[2] == '{')))) |
752
|
|
|
|
|
|
{ |
753
|
3910
|
|
|
|
|
sv_catpvn(iname, "->", 2); |
754
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
} |
756
|
11070
|
|
|
|
|
if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && |
757
|
32
|
|
|
|
|
(instr(name+namelen-8, "{SCALAR}") || |
758
|
32
|
|
|
|
|
instr(name+namelen-7, "{ARRAY}") || |
759
|
16
|
|
|
|
|
instr(name+namelen-6, "{HASH}"))) { |
760
|
16
|
|
|
|
|
sv_catpvn(iname, "->", 2); |
761
|
|
|
|
|
|
} |
762
|
11054
|
|
|
|
|
sv_catpvn(iname, "{", 1); |
763
|
11054
|
|
|
|
|
totpad = newSVsv(sep); |
764
|
11054
|
|
|
|
|
sv_catsv(totpad, pad); |
765
|
11054
|
|
|
|
|
sv_catsv(totpad, apad); |
766
|
|
|
|
|
|
|
767
|
|
|
|
|
|
/* If requested, get a sorted/filtered array of hash keys */ |
768
|
11054
|
|
|
|
|
if (sortkeys) { |
769
|
3450
|
|
|
|
|
if (sortkeys == &PL_sv_yes) { |
770
|
|
|
|
|
|
#if PERL_VERSION < 8 |
771
|
|
|
|
|
|
sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23)); |
772
|
|
|
|
|
|
#else |
773
|
3420
|
|
|
|
|
keys = newAV(); |
774
|
3420
|
|
|
|
|
(void)hv_iterinit((HV*)ival); |
775
|
23652
|
|
|
|
|
while ((entry = hv_iternext((HV*)ival))) { |
776
|
16812
|
|
|
|
|
sv = hv_iterkeysv(entry); |
777
|
|
|
|
|
|
(void)SvREFCNT_inc(sv); |
778
|
16812
|
|
|
|
|
av_push(keys, sv); |
779
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
# ifdef USE_LOCALE_NUMERIC |
781
|
3420
|
|
|
|
|
sortsv(AvARRAY(keys), |
782
|
|
|
|
|
|
av_len(keys)+1, |
783
|
|
|
|
|
|
IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp); |
784
|
|
|
|
|
|
# else |
785
|
|
|
|
|
|
sortsv(AvARRAY(keys), |
786
|
|
|
|
|
|
av_len(keys)+1, |
787
|
|
|
|
|
|
Perl_sv_cmp); |
788
|
|
|
|
|
|
# endif |
789
|
|
|
|
|
|
#endif |
790
|
|
|
|
|
|
} |
791
|
3450
|
|
|
|
|
if (sortkeys != &PL_sv_yes) { |
792
|
30
|
|
|
|
|
dSP; ENTER; SAVETMPS; PUSHMARK(sp); |
793
|
30
|
|
|
|
|
XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK; |
794
|
30
|
|
|
|
|
i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL); |
795
|
30
|
|
|
|
|
SPAGAIN; |
796
|
30
|
|
|
|
|
if (i) { |
797
|
30
|
|
|
|
|
sv = POPs; |
798
|
30
|
|
|
|
|
if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV)) |
799
|
28
|
|
|
|
|
keys = (AV*)SvREFCNT_inc(SvRV(sv)); |
800
|
|
|
|
|
|
} |
801
|
30
|
|
|
|
|
if (! keys) |
802
|
2
|
|
|
|
|
warn("Sortkeys subroutine did not return ARRAYREF\n"); |
803
|
30
|
|
|
|
|
PUTBACK; FREETMPS; LEAVE; |
804
|
|
|
|
|
|
} |
805
|
3450
|
|
|
|
|
if (keys) |
806
|
3448
|
|
|
|
|
sv_2mortal((SV*)keys); |
807
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
else |
809
|
7604
|
|
|
|
|
(void)hv_iterinit((HV*)ival); |
810
|
|
|
|
|
|
|
811
|
|
|
|
|
|
/* foreach (keys %hash) */ |
812
|
42776
|
|
|
|
|
for (i = 0; 1; i++) { |
813
|
|
|
|
|
|
char *nkey; |
814
|
|
|
|
|
|
char *nkey_buffer = NULL; |
815
|
|
|
|
|
|
I32 nticks = 0; |
816
|
|
|
|
|
|
SV* keysv; |
817
|
|
|
|
|
|
STRLEN keylen; |
818
|
|
|
|
|
|
I32 nlen; |
819
|
|
|
|
|
|
bool do_utf8 = FALSE; |
820
|
|
|
|
|
|
|
821
|
53830
|
|
|
|
|
if (sortkeys) { |
822
|
20620
|
|
|
|
|
if (!(keys && (SSize_t)i <= av_len(keys))) break; |
823
|
|
|
|
|
|
} else { |
824
|
33210
|
|
|
|
|
if (!(entry = hv_iternext((HV *)ival))) break; |
825
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
827
|
42776
|
|
|
|
|
if (i) |
828
|
37500
|
|
|
|
|
sv_catpvn(retval, ",", 1); |
829
|
|
|
|
|
|
|
830
|
42776
|
|
|
|
|
if (sortkeys) { |
831
|
|
|
|
|
|
char *key; |
832
|
17170
|
|
|
|
|
svp = av_fetch(keys, i, FALSE); |
833
|
17170
|
|
|
|
|
keysv = svp ? *svp : sv_newmortal(); |
834
|
17170
|
|
|
|
|
key = SvPV(keysv, keylen); |
835
|
17170
|
|
|
|
|
svp = hv_fetch((HV*)ival, key, |
836
|
|
|
|
|
|
SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0); |
837
|
17170
|
|
|
|
|
hval = svp ? *svp : sv_newmortal(); |
838
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
else { |
840
|
25606
|
|
|
|
|
keysv = hv_iterkeysv(entry); |
841
|
25606
|
|
|
|
|
hval = hv_iterval((HV*)ival, entry); |
842
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
844
|
42776
|
|
|
|
|
key = SvPV(keysv, keylen); |
845
|
42776
|
|
|
|
|
do_utf8 = DO_UTF8(keysv); |
846
|
42776
|
|
|
|
|
klen = keylen; |
847
|
|
|
|
|
|
|
848
|
42776
|
|
|
|
|
sv_catsv(retval, totpad); |
849
|
42776
|
|
|
|
|
sv_catsv(retval, ipad); |
850
|
|
|
|
|
|
/* old logic was first to check utf8 flag, and if utf8 always |
851
|
|
|
|
|
|
call esc_q_utf8. This caused test to break under -Mutf8, |
852
|
|
|
|
|
|
because there even strings like 'c' have utf8 flag on. |
853
|
|
|
|
|
|
Hence with quotekeys == 0 the XS code would still '' quote |
854
|
|
|
|
|
|
them based on flags, whereas the perl code would not, |
855
|
|
|
|
|
|
based on regexps. |
856
|
|
|
|
|
|
The perl code is correct. |
857
|
|
|
|
|
|
needs_quote() decides that anything that isn't a valid |
858
|
|
|
|
|
|
perl identifier needs to be quoted, hence only correctly |
859
|
|
|
|
|
|
formed strings with no characters outside [A-Za-z0-9_:] |
860
|
|
|
|
|
|
won't need quoting. None of those characters are used in |
861
|
|
|
|
|
|
the byte encoding of utf8, so anything with utf8 |
862
|
|
|
|
|
|
encoded characters in will need quoting. Hence strings |
863
|
|
|
|
|
|
with utf8 encoded characters in will end up inside do_utf8 |
864
|
|
|
|
|
|
just like before, but now strings with utf8 flag set but |
865
|
|
|
|
|
|
only ascii characters will end up in the unquoted section. |
866
|
|
|
|
|
|
|
867
|
|
|
|
|
|
There should also be less tests for the (probably currently) |
868
|
|
|
|
|
|
more common doesn't need quoting case. |
869
|
|
|
|
|
|
The code is also smaller (22044 vs 22260) because I've been |
870
|
|
|
|
|
|
able to pull the common logic out to both sides. */ |
871
|
42776
|
|
|
|
|
if (quotekeys || needs_quote(key,keylen)) { |
872
|
58700
|
|
|
|
|
if (do_utf8 || useqq) { |
873
|
16160
|
|
|
|
|
STRLEN ocur = SvCUR(retval); |
874
|
16160
|
|
|
|
|
nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, useqq); |
875
|
16160
|
|
|
|
|
nkey = SvPVX(retval) + ocur; |
876
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
else { |
878
|
26380
|
|
|
|
|
nticks = num_q(key, klen); |
879
|
26380
|
|
|
|
|
New(0, nkey_buffer, klen+nticks+3, char); |
880
|
|
|
|
|
|
nkey = nkey_buffer; |
881
|
26380
|
|
|
|
|
nkey[0] = '\''; |
882
|
26380
|
|
|
|
|
if (nticks) |
883
|
0
|
|
|
|
|
klen += esc_q(nkey+1, key, klen); |
884
|
|
|
|
|
|
else |
885
|
26380
|
|
|
|
|
(void)Copy(key, nkey+1, klen, char); |
886
|
26380
|
|
|
|
|
nkey[++klen] = '\''; |
887
|
26380
|
|
|
|
|
nkey[++klen] = '\0'; |
888
|
|
|
|
|
|
nlen = klen; |
889
|
26380
|
|
|
|
|
sv_catpvn(retval, nkey, klen); |
890
|
|
|
|
|
|
} |
891
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
else { |
893
|
|
|
|
|
|
nkey = key; |
894
|
|
|
|
|
|
nlen = klen; |
895
|
236
|
|
|
|
|
sv_catpvn(retval, nkey, klen); |
896
|
|
|
|
|
|
} |
897
|
42776
|
|
|
|
|
sname = newSVsv(iname); |
898
|
42776
|
|
|
|
|
sv_catpvn(sname, nkey, nlen); |
899
|
42776
|
|
|
|
|
sv_catpvn(sname, "}", 1); |
900
|
|
|
|
|
|
|
901
|
42776
|
|
|
|
|
sv_catsv(retval, pair); |
902
|
42776
|
|
|
|
|
if (indent >= 2) { |
903
|
|
|
|
|
|
char *extra; |
904
|
|
|
|
|
|
I32 elen = 0; |
905
|
42162
|
|
|
|
|
newapad = newSVsv(apad); |
906
|
42162
|
|
|
|
|
New(0, extra, klen+4+1, char); |
907
|
652306
|
|
|
|
|
while (elen < (klen+4)) |
908
|
567982
|
|
|
|
|
extra[elen++] = ' '; |
909
|
42162
|
|
|
|
|
extra[elen] = '\0'; |
910
|
42162
|
|
|
|
|
sv_catpvn(newapad, extra, elen); |
911
|
42162
|
|
|
|
|
Safefree(extra); |
912
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
else |
914
|
|
|
|
|
|
newapad = apad; |
915
|
|
|
|
|
|
|
916
|
42776
|
|
|
|
|
DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv, |
917
|
|
|
|
|
|
postav, levelp, indent, pad, xpad, newapad, sep, pair, |
918
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, bless, |
919
|
|
|
|
|
|
maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
920
|
42776
|
|
|
|
|
SvREFCNT_dec(sname); |
921
|
42776
|
|
|
|
|
Safefree(nkey_buffer); |
922
|
42776
|
|
|
|
|
if (indent >= 2) |
923
|
42162
|
|
|
|
|
SvREFCNT_dec(newapad); |
924
|
42776
|
|
|
|
|
} |
925
|
11054
|
|
|
|
|
if (i) { |
926
|
5276
|
|
|
|
|
SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1); |
927
|
5276
|
|
|
|
|
sv_catsv(retval, totpad); |
928
|
5276
|
|
|
|
|
sv_catsv(retval, opad); |
929
|
5276
|
|
|
|
|
SvREFCNT_dec(opad); |
930
|
|
|
|
|
|
} |
931
|
11054
|
|
|
|
|
if (name[0] == '%') |
932
|
20
|
|
|
|
|
sv_catpvn(retval, ")", 1); |
933
|
|
|
|
|
|
else |
934
|
11034
|
|
|
|
|
sv_catpvn(retval, "}", 1); |
935
|
11054
|
|
|
|
|
SvREFCNT_dec(iname); |
936
|
11054
|
|
|
|
|
SvREFCNT_dec(totpad); |
937
|
|
|
|
|
|
} |
938
|
10
|
|
|
|
|
else if (realtype == SVt_PVCV) { |
939
|
10
|
|
|
|
|
sv_catpvn(retval, "sub { \"DUMMY\" }", 15); |
940
|
10
|
|
|
|
|
if (purity) |
941
|
0
|
|
|
|
|
warn("Encountered CODE ref, using dummy placeholder"); |
942
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
else { |
944
|
0
|
|
|
|
|
warn("cannot handle ref type %d", (int)realtype); |
945
|
|
|
|
|
|
} |
946
|
|
|
|
|
|
|
947
|
23194
|
|
|
|
|
if (realpack && !no_bless) { /* free blessed allocs */ |
948
|
|
|
|
|
|
I32 plen; |
949
|
|
|
|
|
|
I32 pticks; |
950
|
|
|
|
|
|
|
951
|
78
|
|
|
|
|
if (indent >= 2) { |
952
|
70
|
|
|
|
|
SvREFCNT_dec(apad); |
953
|
|
|
|
|
|
apad = blesspad; |
954
|
|
|
|
|
|
} |
955
|
78
|
|
|
|
|
sv_catpvn(retval, ", '", 3); |
956
|
|
|
|
|
|
|
957
|
78
|
|
|
|
|
plen = strlen(realpack); |
958
|
78
|
|
|
|
|
pticks = num_q(realpack, plen); |
959
|
78
|
|
|
|
|
if (pticks) { /* needs escaping */ |
960
|
|
|
|
|
|
char *npack; |
961
|
|
|
|
|
|
char *npack_buffer = NULL; |
962
|
|
|
|
|
|
|
963
|
4
|
|
|
|
|
New(0, npack_buffer, plen+pticks+1, char); |
964
|
|
|
|
|
|
npack = npack_buffer; |
965
|
4
|
|
|
|
|
plen += esc_q(npack, realpack, plen); |
966
|
4
|
|
|
|
|
npack[plen] = '\0'; |
967
|
|
|
|
|
|
|
968
|
4
|
|
|
|
|
sv_catpvn(retval, npack, plen); |
969
|
4
|
|
|
|
|
Safefree(npack_buffer); |
970
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
else { |
972
|
74
|
|
|
|
|
sv_catpvn(retval, realpack, strlen(realpack)); |
973
|
|
|
|
|
|
} |
974
|
78
|
|
|
|
|
sv_catpvn(retval, "' )", 3); |
975
|
78
|
|
|
|
|
if (toaster && SvPOK(toaster) && SvCUR(toaster)) { |
976
|
0
|
|
|
|
|
sv_catpvn(retval, "->", 2); |
977
|
0
|
|
|
|
|
sv_catsv(retval, toaster); |
978
|
0
|
|
|
|
|
sv_catpvn(retval, "()", 2); |
979
|
|
|
|
|
|
} |
980
|
|
|
|
|
|
} |
981
|
23194
|
|
|
|
|
SvREFCNT_dec(ipad); |
982
|
23194
|
|
|
|
|
(*levelp)--; |
983
|
|
|
|
|
|
} |
984
|
|
|
|
|
|
else { |
985
|
|
|
|
|
|
STRLEN i; |
986
|
|
|
|
|
|
const MAGIC *mg; |
987
|
|
|
|
|
|
|
988
|
207874
|
|
|
|
|
if (namelen) { |
989
|
|
|
|
|
|
#ifdef DD_USE_OLD_ID_FORMAT |
990
|
|
|
|
|
|
idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val)); |
991
|
|
|
|
|
|
#else |
992
|
207874
|
|
|
|
|
id_buffer = PTR2UV(val); |
993
|
|
|
|
|
|
idlen = sizeof(id_buffer); |
994
|
|
|
|
|
|
#endif |
995
|
208026
|
|
|
|
|
if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) && |
996
|
456
|
|
|
|
|
(sv = *svp) && SvROK(sv) && |
997
|
152
|
|
|
|
|
(seenentry = (AV*)SvRV(sv))) |
998
|
|
|
|
|
|
{ |
999
|
|
|
|
|
|
SV *othername; |
1000
|
152
|
|
|
|
|
if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) |
1001
|
152
|
|
|
|
|
&& (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) |
1002
|
|
|
|
|
|
{ |
1003
|
16
|
|
|
|
|
sv_catpvn(retval, "${", 2); |
1004
|
16
|
|
|
|
|
sv_catsv(retval, othername); |
1005
|
16
|
|
|
|
|
sv_catpvn(retval, "}", 1); |
1006
|
16
|
|
|
|
|
return 1; |
1007
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
} |
1009
|
|
|
|
|
|
/* If we're allowed to keep only a sparse "seen" hash |
1010
|
|
|
|
|
|
* (IOW, the user does not expect it to contain everything |
1011
|
|
|
|
|
|
* after the dump, then only store in seen hash if the SV |
1012
|
|
|
|
|
|
* ref count is larger than 1. If it's 1, then we know that |
1013
|
|
|
|
|
|
* there is no other reference, duh. This is an optimization. |
1014
|
|
|
|
|
|
* Note that we'd have to check for weak-refs, too, but this is |
1015
|
|
|
|
|
|
* already the branch for non-refs only. */ |
1016
|
207722
|
|
|
|
|
else if (val != &PL_sv_undef && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) { |
1017
|
207690
|
|
|
|
|
SV * const namesv = newSVpvn("\\", 1); |
1018
|
207690
|
|
|
|
|
sv_catpvn(namesv, name, namelen); |
1019
|
207690
|
|
|
|
|
seenentry = newAV(); |
1020
|
207690
|
|
|
|
|
av_push(seenentry, namesv); |
1021
|
207690
|
|
|
|
|
av_push(seenentry, newRV_inc(val)); |
1022
|
207690
|
|
|
|
|
(void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0); |
1023
|
207690
|
|
|
|
|
SvREFCNT_dec(seenentry); |
1024
|
|
|
|
|
|
} |
1025
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
1027
|
207858
|
|
|
|
|
if (DD_is_integer(val)) { |
1028
|
|
|
|
|
|
STRLEN len; |
1029
|
78540
|
|
|
|
|
if (SvIsUV(val)) |
1030
|
0
|
|
|
|
|
len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val)); |
1031
|
|
|
|
|
|
else |
1032
|
157080
|
|
|
|
|
len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val)); |
1033
|
78540
|
|
|
|
|
if (SvPOK(val)) { |
1034
|
|
|
|
|
|
/* Need to check to see if this is a string such as " 0". |
1035
|
|
|
|
|
|
I'm assuming from sprintf isn't going to clash with utf8. |
1036
|
|
|
|
|
|
Is this valid on EBCDIC? */ |
1037
|
|
|
|
|
|
STRLEN pvlen; |
1038
|
3716
|
|
|
|
|
const char * const pv = SvPV(val, pvlen); |
1039
|
3716
|
|
|
|
|
if (pvlen != len || memNE(pv, tmpbuf, len)) |
1040
|
|
|
|
|
|
goto integer_came_from_string; |
1041
|
|
|
|
|
|
} |
1042
|
78256
|
|
|
|
|
if (len > 10) { |
1043
|
|
|
|
|
|
/* Looks like we're on a 64 bit system. Make it a string so that |
1044
|
|
|
|
|
|
if a 32 bit system reads the number it will cope better. */ |
1045
|
24
|
|
|
|
|
sv_catpvf(retval, "'%s'", tmpbuf); |
1046
|
|
|
|
|
|
} else |
1047
|
78232
|
|
|
|
|
sv_catpvn(retval, tmpbuf, len); |
1048
|
|
|
|
|
|
} |
1049
|
129318
|
|
|
|
|
else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ |
1050
|
46
|
|
|
|
|
c = SvPV(val, i); |
1051
|
46
|
|
|
|
|
if(i) ++c, --i; /* just get the name */ |
1052
|
46
|
|
|
|
|
if (i >= 6 && strncmp(c, "main::", 6) == 0) { |
1053
|
42
|
|
|
|
|
c += 4; |
1054
|
|
|
|
|
|
#if PERL_VERSION < 7 |
1055
|
|
|
|
|
|
if (i == 6 || (i == 7 && c[6] == '\0')) |
1056
|
|
|
|
|
|
#else |
1057
|
42
|
|
|
|
|
if (i == 6) |
1058
|
|
|
|
|
|
#endif |
1059
|
2
|
|
|
|
|
i = 0; else i -= 4; |
1060
|
|
|
|
|
|
} |
1061
|
46
|
|
|
|
|
if (needs_quote(c,i)) { |
1062
|
|
|
|
|
|
#ifdef GvNAMEUTF8 |
1063
|
8
|
|
|
|
|
if (GvNAMEUTF8(val)) { |
1064
|
4
|
|
|
|
|
sv_grow(retval, SvCUR(retval)+2); |
1065
|
4
|
|
|
|
|
r = SvPVX(retval)+SvCUR(retval); |
1066
|
4
|
|
|
|
|
r[0] = '*'; r[1] = '{'; |
1067
|
4
|
|
|
|
|
SvCUR_set(retval, SvCUR(retval)+2); |
1068
|
4
|
|
|
|
|
esc_q_utf8(aTHX_ retval, c, i, 1, useqq); |
1069
|
4
|
|
|
|
|
sv_grow(retval, SvCUR(retval)+2); |
1070
|
4
|
|
|
|
|
r = SvPVX(retval)+SvCUR(retval); |
1071
|
4
|
|
|
|
|
r[0] = '}'; r[1] = '\0'; |
1072
|
4
|
|
|
|
|
i = 1; |
1073
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
else |
1075
|
|
|
|
|
|
#endif |
1076
|
|
|
|
|
|
{ |
1077
|
4
|
|
|
|
|
sv_grow(retval, SvCUR(retval)+6+2*i); |
1078
|
4
|
|
|
|
|
r = SvPVX(retval)+SvCUR(retval); |
1079
|
4
|
|
|
|
|
r[0] = '*'; r[1] = '{'; r[2] = '\''; |
1080
|
4
|
|
|
|
|
i += esc_q(r+3, c, i); |
1081
|
4
|
|
|
|
|
i += 3; |
1082
|
4
|
|
|
|
|
r[i++] = '\''; r[i++] = '}'; |
1083
|
4
|
|
|
|
|
r[i] = '\0'; |
1084
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
} |
1086
|
|
|
|
|
|
else { |
1087
|
38
|
|
|
|
|
sv_grow(retval, SvCUR(retval)+i+2); |
1088
|
38
|
|
|
|
|
r = SvPVX(retval)+SvCUR(retval); |
1089
|
38
|
|
|
|
|
r[0] = '*'; strcpy(r+1, c); |
1090
|
38
|
|
|
|
|
i++; |
1091
|
|
|
|
|
|
} |
1092
|
46
|
|
|
|
|
SvCUR_set(retval, SvCUR(retval)+i); |
1093
|
|
|
|
|
|
|
1094
|
46
|
|
|
|
|
if (purity) { |
1095
|
|
|
|
|
|
static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; |
1096
|
|
|
|
|
|
static const STRLEN sizes[] = { 8, 7, 6 }; |
1097
|
|
|
|
|
|
SV *e; |
1098
|
24
|
|
|
|
|
SV * const nname = newSVpvn("", 0); |
1099
|
24
|
|
|
|
|
SV * const newapad = newSVpvn("", 0); |
1100
|
|
|
|
|
|
GV * const gv = (GV*)val; |
1101
|
|
|
|
|
|
I32 j; |
1102
|
|
|
|
|
|
|
1103
|
96
|
|
|
|
|
for (j=0; j<3; j++) { |
1104
|
72
|
|
|
|
|
e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); |
1105
|
72
|
|
|
|
|
if (!e) |
1106
|
8
|
|
|
|
|
continue; |
1107
|
64
|
|
|
|
|
if (j == 0 && !SvOK(e)) |
1108
|
0
|
|
|
|
|
continue; |
1109
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
{ |
1111
|
64
|
|
|
|
|
I32 nlevel = 0; |
1112
|
64
|
|
|
|
|
SV *postentry = newSVpvn(r,i); |
1113
|
|
|
|
|
|
|
1114
|
64
|
|
|
|
|
sv_setsv(nname, postentry); |
1115
|
64
|
|
|
|
|
sv_catpvn(nname, entries[j], sizes[j]); |
1116
|
64
|
|
|
|
|
sv_catpvn(postentry, " = ", 3); |
1117
|
64
|
|
|
|
|
av_push(postav, postentry); |
1118
|
64
|
|
|
|
|
e = newRV_inc(e); |
1119
|
|
|
|
|
|
|
1120
|
64
|
|
|
|
|
SvCUR_set(newapad, 0); |
1121
|
64
|
|
|
|
|
if (indent >= 2) |
1122
|
12
|
|
|
|
|
(void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); |
1123
|
|
|
|
|
|
|
1124
|
64
|
|
|
|
|
DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry, |
1125
|
|
|
|
|
|
seenhv, postav, &nlevel, indent, pad, xpad, |
1126
|
|
|
|
|
|
newapad, sep, pair, freezer, toaster, purity, |
1127
|
|
|
|
|
|
deepcopy, quotekeys, bless, maxdepth, |
1128
|
|
|
|
|
|
sortkeys, use_sparse_seen_hash, useqq); |
1129
|
64
|
|
|
|
|
SvREFCNT_dec(e); |
1130
|
|
|
|
|
|
} |
1131
|
|
|
|
|
|
} |
1132
|
|
|
|
|
|
|
1133
|
24
|
|
|
|
|
SvREFCNT_dec(newapad); |
1134
|
24
|
|
|
|
|
SvREFCNT_dec(nname); |
1135
|
|
|
|
|
|
} |
1136
|
|
|
|
|
|
} |
1137
|
129272
|
|
|
|
|
else if (val == &PL_sv_undef || !SvOK(val)) { |
1138
|
7378
|
|
|
|
|
sv_catpvn(retval, "undef", 5); |
1139
|
|
|
|
|
|
} |
1140
|
|
|
|
|
|
#ifdef SvVOK |
1141
|
121894
|
|
|
|
|
else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) { |
1142
|
|
|
|
|
|
# if !defined(PL_vtbl_vstring) && PERL_VERSION < 17 |
1143
|
|
|
|
|
|
SV * const vecsv = sv_newmortal(); |
1144
|
|
|
|
|
|
# if PERL_VERSION < 10 |
1145
|
|
|
|
|
|
scan_vstring(mg->mg_ptr, vecsv); |
1146
|
|
|
|
|
|
# else |
1147
|
|
|
|
|
|
scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv); |
1148
|
|
|
|
|
|
# endif |
1149
|
|
|
|
|
|
if (!sv_eq(vecsv, val)) goto integer_came_from_string; |
1150
|
|
|
|
|
|
# endif |
1151
|
12
|
|
|
|
|
sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len); |
1152
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
#endif |
1154
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
/* the pure perl and XS non-qq outputs have historically been |
1156
|
|
|
|
|
|
* different in this case, but for useqq, let's try to match |
1157
|
|
|
|
|
|
* the pure perl code. |
1158
|
|
|
|
|
|
* see [perl #74798] |
1159
|
|
|
|
|
|
*/ |
1160
|
121882
|
|
|
|
|
else if (useqq && safe_decimal_number(aTHX_ val)) { |
1161
|
72638
|
|
|
|
|
sv_catsv(retval, val); |
1162
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
else { |
1164
|
|
|
|
|
|
integer_came_from_string: |
1165
|
49528
|
|
|
|
|
c = SvPV(val, i); |
1166
|
49528
|
|
|
|
|
if (DO_UTF8(val) || useqq) |
1167
|
3326
|
|
|
|
|
i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), useqq); |
1168
|
|
|
|
|
|
else { |
1169
|
46202
|
|
|
|
|
sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */ |
1170
|
46202
|
|
|
|
|
r = SvPVX(retval) + SvCUR(retval); |
1171
|
46202
|
|
|
|
|
r[0] = '\''; |
1172
|
46202
|
|
|
|
|
i += esc_q(r+1, c, i); |
1173
|
46202
|
|
|
|
|
++i; |
1174
|
46202
|
|
|
|
|
r[i++] = '\''; |
1175
|
46202
|
|
|
|
|
r[i] = '\0'; |
1176
|
46202
|
|
|
|
|
SvCUR_set(retval, SvCUR(retval)+i); |
1177
|
|
|
|
|
|
} |
1178
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
1181
|
231052
|
|
|
|
|
if (idlen) { |
1182
|
231052
|
|
|
|
|
if (deepcopy) |
1183
|
180
|
|
|
|
|
(void)hv_delete(seenhv, id, idlen, G_DISCARD); |
1184
|
230872
|
|
|
|
|
else if (namelen && seenentry) { |
1185
|
230840
|
|
|
|
|
SV *mark = *av_fetch(seenentry, 2, TRUE); |
1186
|
230840
|
|
|
|
|
sv_setiv(mark,1); |
1187
|
|
|
|
|
|
} |
1188
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
return 1; |
1190
|
|
|
|
|
|
} |
1191
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ |
1194
|
|
|
|
|
|
|
1195
|
|
|
|
|
|
# |
1196
|
|
|
|
|
|
# This is the exact equivalent of Dump. Well, almost. The things that are |
1197
|
|
|
|
|
|
# different as of now (due to Laziness): |
1198
|
|
|
|
|
|
# * doesn't do double-quotes yet. |
1199
|
|
|
|
|
|
# |
1200
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
void |
1202
|
|
|
|
|
|
Data_Dumper_Dumpxs(href, ...) |
1203
|
|
|
|
|
|
SV *href; |
1204
|
|
|
|
|
|
PROTOTYPE: $;$$ |
1205
|
|
|
|
|
|
PPCODE: |
1206
|
|
|
|
|
|
{ |
1207
|
|
|
|
|
|
HV *hv; |
1208
|
|
|
|
|
|
SV *retval, *valstr; |
1209
|
|
|
|
|
|
HV *seenhv = NULL; |
1210
|
|
|
|
|
|
AV *postav, *todumpav, *namesav; |
1211
|
75102
|
|
|
|
|
I32 level = 0; |
1212
|
|
|
|
|
|
I32 indent, terse, useqq; |
1213
|
|
|
|
|
|
SSize_t i, imax, postlen; |
1214
|
|
|
|
|
|
SV **svp; |
1215
|
|
|
|
|
|
SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; |
1216
|
|
|
|
|
|
SV *freezer, *toaster, *bless, *sortkeys; |
1217
|
|
|
|
|
|
I32 purity, deepcopy, quotekeys, maxdepth = 0; |
1218
|
|
|
|
|
|
char tmpbuf[1024]; |
1219
|
75102
|
|
|
|
|
I32 gimme = GIMME; |
1220
|
|
|
|
|
|
int use_sparse_seen_hash = 0; |
1221
|
|
|
|
|
|
|
1222
|
148110
|
|
|
|
|
if (!SvROK(href)) { /* call new to get an object first */ |
1223
|
73008
|
|
|
|
|
if (items < 2) |
1224
|
0
|
|
|
|
|
croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); |
1225
|
|
|
|
|
|
|
1226
|
73008
|
|
|
|
|
ENTER; |
1227
|
73008
|
|
|
|
|
SAVETMPS; |
1228
|
|
|
|
|
|
|
1229
|
73008
|
|
|
|
|
PUSHMARK(sp); |
1230
|
73008
|
|
|
|
|
EXTEND(SP, 3); /* 3 == max of all branches below */ |
1231
|
73008
|
|
|
|
|
PUSHs(href); |
1232
|
73008
|
|
|
|
|
PUSHs(sv_2mortal(newSVsv(ST(1)))); |
1233
|
73008
|
|
|
|
|
if (items >= 3) |
1234
|
92
|
|
|
|
|
PUSHs(sv_2mortal(newSVsv(ST(2)))); |
1235
|
73008
|
|
|
|
|
PUTBACK; |
1236
|
73008
|
|
|
|
|
i = perl_call_method("new", G_SCALAR); |
1237
|
73008
|
|
|
|
|
SPAGAIN; |
1238
|
73008
|
|
|
|
|
if (i) |
1239
|
73008
|
|
|
|
|
href = newSVsv(POPs); |
1240
|
|
|
|
|
|
|
1241
|
73008
|
|
|
|
|
PUTBACK; |
1242
|
73008
|
|
|
|
|
FREETMPS; |
1243
|
73008
|
|
|
|
|
LEAVE; |
1244
|
73008
|
|
|
|
|
if (i) |
1245
|
73008
|
|
|
|
|
(void)sv_2mortal(href); |
1246
|
|
|
|
|
|
} |
1247
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
todumpav = namesav = NULL; |
1249
|
|
|
|
|
|
seenhv = NULL; |
1250
|
|
|
|
|
|
val = pad = xpad = apad = sep = pair = varname |
1251
|
|
|
|
|
|
= freezer = toaster = bless = sortkeys = &PL_sv_undef; |
1252
|
75102
|
|
|
|
|
name = sv_newmortal(); |
1253
|
|
|
|
|
|
indent = 2; |
1254
|
|
|
|
|
|
terse = purity = deepcopy = useqq = 0; |
1255
|
|
|
|
|
|
quotekeys = 1; |
1256
|
|
|
|
|
|
|
1257
|
75102
|
|
|
|
|
retval = newSVpvn("", 0); |
1258
|
75102
|
|
|
|
|
if (SvROK(href) |
1259
|
75102
|
|
|
|
|
&& (hv = (HV*)SvRV((SV*)href)) |
1260
|
75102
|
|
|
|
|
&& SvTYPE(hv) == SVt_PVHV) { |
1261
|
|
|
|
|
|
|
1262
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) |
1263
|
75102
|
|
|
|
|
seenhv = (HV*)SvRV(*svp); |
1264
|
|
|
|
|
|
else |
1265
|
|
|
|
|
|
use_sparse_seen_hash = 1; |
1266
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "noseen", 6, FALSE))) |
1267
|
75102
|
|
|
|
|
use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0); |
1268
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) |
1269
|
75102
|
|
|
|
|
todumpav = (AV*)SvRV(*svp); |
1270
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) |
1271
|
75102
|
|
|
|
|
namesav = (AV*)SvRV(*svp); |
1272
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "indent", 6, FALSE))) |
1273
|
75102
|
|
|
|
|
indent = SvIV(*svp); |
1274
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "purity", 6, FALSE))) |
1275
|
75102
|
|
|
|
|
purity = SvIV(*svp); |
1276
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "terse", 5, FALSE))) |
1277
|
75102
|
|
|
|
|
terse = SvTRUE(*svp); |
1278
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) |
1279
|
75102
|
|
|
|
|
useqq = SvTRUE(*svp); |
1280
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "pad", 3, FALSE))) |
1281
|
75102
|
|
|
|
|
pad = *svp; |
1282
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) |
1283
|
75102
|
|
|
|
|
xpad = *svp; |
1284
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "apad", 4, FALSE))) |
1285
|
75102
|
|
|
|
|
apad = *svp; |
1286
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "sep", 3, FALSE))) |
1287
|
75102
|
|
|
|
|
sep = *svp; |
1288
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "pair", 4, FALSE))) |
1289
|
75102
|
|
|
|
|
pair = *svp; |
1290
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "varname", 7, FALSE))) |
1291
|
75102
|
|
|
|
|
varname = *svp; |
1292
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) |
1293
|
75102
|
|
|
|
|
freezer = *svp; |
1294
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) |
1295
|
75102
|
|
|
|
|
toaster = *svp; |
1296
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) |
1297
|
75102
|
|
|
|
|
deepcopy = SvTRUE(*svp); |
1298
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) |
1299
|
75102
|
|
|
|
|
quotekeys = SvTRUE(*svp); |
1300
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "bless", 5, FALSE))) |
1301
|
75102
|
|
|
|
|
bless = *svp; |
1302
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) |
1303
|
75102
|
|
|
|
|
maxdepth = SvIV(*svp); |
1304
|
75102
|
|
|
|
|
if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { |
1305
|
75102
|
|
|
|
|
sortkeys = *svp; |
1306
|
75102
|
|
|
|
|
if (! SvTRUE(sortkeys)) |
1307
|
|
|
|
|
|
sortkeys = NULL; |
1308
|
68484
|
|
|
|
|
else if (! (SvROK(sortkeys) && |
1309
|
20
|
|
|
|
|
SvTYPE(SvRV(sortkeys)) == SVt_PVCV) ) |
1310
|
|
|
|
|
|
{ |
1311
|
|
|
|
|
|
/* flag to use qsortsv() for sorting hash keys */ |
1312
|
|
|
|
|
|
sortkeys = &PL_sv_yes; |
1313
|
|
|
|
|
|
} |
1314
|
|
|
|
|
|
} |
1315
|
75102
|
|
|
|
|
postav = newAV(); |
1316
|
|
|
|
|
|
|
1317
|
75102
|
|
|
|
|
if (todumpav) |
1318
|
75102
|
|
|
|
|
imax = av_len(todumpav); |
1319
|
|
|
|
|
|
else |
1320
|
|
|
|
|
|
imax = -1; |
1321
|
75102
|
|
|
|
|
valstr = newSVpvn("",0); |
1322
|
151706
|
|
|
|
|
for (i = 0; i <= imax; ++i) { |
1323
|
|
|
|
|
|
SV *newapad; |
1324
|
|
|
|
|
|
|
1325
|
76604
|
|
|
|
|
av_clear(postav); |
1326
|
76604
|
|
|
|
|
if ((svp = av_fetch(todumpav, i, FALSE))) |
1327
|
76604
|
|
|
|
|
val = *svp; |
1328
|
|
|
|
|
|
else |
1329
|
|
|
|
|
|
val = &PL_sv_undef; |
1330
|
76604
|
|
|
|
|
if ((svp = av_fetch(namesav, i, TRUE))) { |
1331
|
76604
|
|
|
|
|
sv_setsv(name, *svp); |
1332
|
76604
|
|
|
|
|
if (SvOK(*svp) && !SvPOK(*svp)) |
1333
|
8
|
|
|
|
|
(void)SvPV_nolen_const(name); |
1334
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
else |
1336
|
0
|
|
|
|
|
(void)SvOK_off(name); |
1337
|
|
|
|
|
|
|
1338
|
76604
|
|
|
|
|
if (SvPOK(name)) { |
1339
|
2194
|
|
|
|
|
if ((SvPVX_const(name))[0] == '*') { |
1340
|
152
|
|
|
|
|
if (SvROK(val)) { |
1341
|
150
|
|
|
|
|
switch (SvTYPE(SvRV(val))) { |
1342
|
|
|
|
|
|
case SVt_PVAV: |
1343
|
54
|
|
|
|
|
(SvPVX(name))[0] = '@'; |
1344
|
54
|
|
|
|
|
break; |
1345
|
|
|
|
|
|
case SVt_PVHV: |
1346
|
72
|
|
|
|
|
(SvPVX(name))[0] = '%'; |
1347
|
72
|
|
|
|
|
break; |
1348
|
|
|
|
|
|
case SVt_PVCV: |
1349
|
4
|
|
|
|
|
(SvPVX(name))[0] = '*'; |
1350
|
4
|
|
|
|
|
break; |
1351
|
|
|
|
|
|
default: |
1352
|
20
|
|
|
|
|
(SvPVX(name))[0] = '$'; |
1353
|
20
|
|
|
|
|
break; |
1354
|
|
|
|
|
|
} |
1355
|
|
|
|
|
|
} |
1356
|
|
|
|
|
|
else |
1357
|
2
|
|
|
|
|
(SvPVX(name))[0] = '$'; |
1358
|
|
|
|
|
|
} |
1359
|
2042
|
|
|
|
|
else if ((SvPVX_const(name))[0] != '$') |
1360
|
2040
|
|
|
|
|
sv_insert(name, 0, 0, "$", 1); |
1361
|
|
|
|
|
|
} |
1362
|
|
|
|
|
|
else { |
1363
|
|
|
|
|
|
STRLEN nchars; |
1364
|
74410
|
|
|
|
|
sv_setpvn(name, "$", 1); |
1365
|
74410
|
|
|
|
|
sv_catsv(name, varname); |
1366
|
148820
|
|
|
|
|
nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1)); |
1367
|
74410
|
|
|
|
|
sv_catpvn(name, tmpbuf, nchars); |
1368
|
|
|
|
|
|
} |
1369
|
|
|
|
|
|
|
1370
|
76604
|
|
|
|
|
if (indent >= 2 && !terse) { |
1371
|
74838
|
|
|
|
|
SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3); |
1372
|
74838
|
|
|
|
|
newapad = newSVsv(apad); |
1373
|
74838
|
|
|
|
|
sv_catsv(newapad, tmpsv); |
1374
|
74838
|
|
|
|
|
SvREFCNT_dec(tmpsv); |
1375
|
|
|
|
|
|
} |
1376
|
|
|
|
|
|
else |
1377
|
|
|
|
|
|
newapad = apad; |
1378
|
|
|
|
|
|
|
1379
|
76604
|
|
|
|
|
PUTBACK; |
1380
|
76604
|
|
|
|
|
DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, |
1381
|
|
|
|
|
|
postav, &level, indent, pad, xpad, newapad, sep, pair, |
1382
|
|
|
|
|
|
freezer, toaster, purity, deepcopy, quotekeys, |
1383
|
|
|
|
|
|
bless, maxdepth, sortkeys, use_sparse_seen_hash, useqq); |
1384
|
76604
|
|
|
|
|
SPAGAIN; |
1385
|
|
|
|
|
|
|
1386
|
76604
|
|
|
|
|
if (indent >= 2 && !terse) |
1387
|
74838
|
|
|
|
|
SvREFCNT_dec(newapad); |
1388
|
|
|
|
|
|
|
1389
|
76604
|
|
|
|
|
postlen = av_len(postav); |
1390
|
76604
|
|
|
|
|
if (postlen >= 0 || !terse) { |
1391
|
76448
|
|
|
|
|
sv_insert(valstr, 0, 0, " = ", 3); |
1392
|
76448
|
|
|
|
|
sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name)); |
1393
|
76448
|
|
|
|
|
sv_catpvn(valstr, ";", 1); |
1394
|
|
|
|
|
|
} |
1395
|
76604
|
|
|
|
|
sv_catsv(retval, pad); |
1396
|
76604
|
|
|
|
|
sv_catsv(retval, valstr); |
1397
|
76604
|
|
|
|
|
sv_catsv(retval, sep); |
1398
|
76604
|
|
|
|
|
if (postlen >= 0) { |
1399
|
|
|
|
|
|
SSize_t i; |
1400
|
64
|
|
|
|
|
sv_catsv(retval, pad); |
1401
|
304
|
|
|
|
|
for (i = 0; i <= postlen; ++i) { |
1402
|
|
|
|
|
|
SV *elem; |
1403
|
240
|
|
|
|
|
svp = av_fetch(postav, i, FALSE); |
1404
|
240
|
|
|
|
|
if (svp && (elem = *svp)) { |
1405
|
240
|
|
|
|
|
sv_catsv(retval, elem); |
1406
|
240
|
|
|
|
|
if (i < postlen) { |
1407
|
176
|
|
|
|
|
sv_catpvn(retval, ";", 1); |
1408
|
176
|
|
|
|
|
sv_catsv(retval, sep); |
1409
|
176
|
|
|
|
|
sv_catsv(retval, pad); |
1410
|
|
|
|
|
|
} |
1411
|
|
|
|
|
|
} |
1412
|
|
|
|
|
|
} |
1413
|
64
|
|
|
|
|
sv_catpvn(retval, ";", 1); |
1414
|
64
|
|
|
|
|
sv_catsv(retval, sep); |
1415
|
|
|
|
|
|
} |
1416
|
76604
|
|
|
|
|
sv_setpvn(valstr, "", 0); |
1417
|
76604
|
|
|
|
|
if (gimme == G_ARRAY) { |
1418
|
4958
|
|
|
|
|
XPUSHs(sv_2mortal(retval)); |
1419
|
4958
|
|
|
|
|
if (i < imax) /* not the last time thro ? */ |
1420
|
152
|
|
|
|
|
retval = newSVpvn("",0); |
1421
|
|
|
|
|
|
} |
1422
|
|
|
|
|
|
} |
1423
|
75102
|
|
|
|
|
SvREFCNT_dec(postav); |
1424
|
75102
|
|
|
|
|
SvREFCNT_dec(valstr); |
1425
|
|
|
|
|
|
} |
1426
|
|
|
|
|
|
else |
1427
|
0
|
|
|
|
|
croak("Call to new() method failed to return HASH ref"); |
1428
|
75102
|
|
|
|
|
if (gimme == G_SCALAR) |
1429
|
70296
|
|
|
|
|
XPUSHs(sv_2mortal(retval)); |
1430
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
SV * |
1433
|
|
|
|
|
|
Data_Dumper__vstring(sv) |
1434
|
|
|
|
|
|
SV *sv; |
1435
|
|
|
|
|
|
PROTOTYPE: $ |
1436
|
|
|
|
|
|
CODE: |
1437
|
|
|
|
|
|
{ |
1438
|
|
|
|
|
|
#ifdef SvVOK |
1439
|
|
|
|
|
|
const MAGIC *mg; |
1440
|
|
|
|
|
|
RETVAL = |
1441
|
8108
|
|
|
|
|
SvMAGICAL(sv) && (mg = mg_find(sv, 'V')) |
1442
|
12
|
|
|
|
|
? newSVpvn((const char *)mg->mg_ptr, mg->mg_len) |
1443
|
8108
|
|
|
|
|
: &PL_sv_undef; |
1444
|
|
|
|
|
|
#else |
1445
|
|
|
|
|
|
RETVAL = &PL_sv_undef; |
1446
|
|
|
|
|
|
#endif |
1447
|
|
|
|
|
|
} |
1448
|
|
|
|
|
|
OUTPUT: RETVAL |