Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* sv.c |
79072805 | 2 | * |
1129b882 | 3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
83706693 RGS |
4 | * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall |
5 | * and others | |
79072805 LW |
6 | * |
7 | * You may distribute under the terms of either the GNU General Public | |
8 | * License or the Artistic License, as specified in the README file. | |
9 | * | |
4ac71550 TC |
10 | */ |
11 | ||
12 | /* | |
13 | * 'I wonder what the Entish is for "yes" and "no",' he thought. | |
14 | * --Pippin | |
15 | * | |
16 | * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] | |
17 | */ | |
18 | ||
19 | /* | |
645c22ef DM |
20 | * |
21 | * | |
5e045b90 AMS |
22 | * This file contains the code that creates, manipulates and destroys |
23 | * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the | |
24 | * structure of an SV, so their creation and destruction is handled | |
25 | * here; higher-level functions are in av.c, hv.c, and so on. Opcode | |
26 | * level functions (eg. substr, split, join) for each of the types are | |
27 | * in the pp*.c files. | |
79072805 LW |
28 | */ |
29 | ||
30 | #include "EXTERN.h" | |
864dbfa3 | 31 | #define PERL_IN_SV_C |
79072805 | 32 | #include "perl.h" |
d2f185dc | 33 | #include "regcomp.h" |
79072805 | 34 | |
07208e09 | 35 | #ifndef HAS_C99 |
4b2d6671 | 36 | # if __STDC_VERSION__ >= 199901L && !defined(VMS) |
07208e09 CS |
37 | # define HAS_C99 1 |
38 | # endif | |
39 | #endif | |
40 | #if HAS_C99 | |
41 | # include <stdint.h> | |
42 | #endif | |
43 | ||
2f8ed50e OS |
44 | #ifdef __Lynx__ |
45 | /* Missing proto on LynxOS */ | |
46 | char *gconvert(double, int, int, char *); | |
47 | #endif | |
48 | ||
e23c8137 | 49 | #ifdef PERL_UTF8_CACHE_ASSERT |
ab455f60 | 50 | /* if adding more checks watch out for the following tests: |
e23c8137 JH |
51 | * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t |
52 | * lib/utf8.t lib/Unicode/Collate/t/index.t | |
53 | * --jhi | |
54 | */ | |
6f207bd3 | 55 | # define ASSERT_UTF8_CACHE(cache) \ |
ab455f60 NC |
56 | STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ |
57 | assert((cache)[2] <= (cache)[3]); \ | |
58 | assert((cache)[3] <= (cache)[1]);} \ | |
59 | } STMT_END | |
e23c8137 | 60 | #else |
6f207bd3 | 61 | # define ASSERT_UTF8_CACHE(cache) NOOP |
e23c8137 JH |
62 | #endif |
63 | ||
f8c7b90f | 64 | #ifdef PERL_OLD_COPY_ON_WRITE |
765f542d | 65 | #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) |
607fa7f2 | 66 | #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) |
765f542d | 67 | #endif |
645c22ef DM |
68 | |
69 | /* ============================================================================ | |
70 | ||
71 | =head1 Allocation and deallocation of SVs. | |
72 | ||
d2a0f284 JC |
73 | An SV (or AV, HV, etc.) is allocated in two parts: the head (struct |
74 | sv, av, hv...) contains type and reference count information, and for | |
75 | many types, a pointer to the body (struct xrv, xpv, xpviv...), which | |
76 | contains fields specific to each type. Some types store all they need | |
77 | in the head, so don't have a body. | |
78 | ||
486ec47a | 79 | In all but the most memory-paranoid configurations (ex: PURIFY), heads |
d2a0f284 JC |
80 | and bodies are allocated out of arenas, which by default are |
81 | approximately 4K chunks of memory parcelled up into N heads or bodies. | |
93e68bfb JC |
82 | Sv-bodies are allocated by their sv-type, guaranteeing size |
83 | consistency needed to allocate safely from arrays. | |
84 | ||
d2a0f284 JC |
85 | For SV-heads, the first slot in each arena is reserved, and holds a |
86 | link to the next arena, some flags, and a note of the number of slots. | |
87 | Snaked through each arena chain is a linked list of free items; when | |
88 | this becomes empty, an extra arena is allocated and divided up into N | |
89 | items which are threaded into the free list. | |
90 | ||
91 | SV-bodies are similar, but they use arena-sets by default, which | |
92 | separate the link and info from the arena itself, and reclaim the 1st | |
93 | slot in the arena. SV-bodies are further described later. | |
645c22ef DM |
94 | |
95 | The following global variables are associated with arenas: | |
96 | ||
97 | PL_sv_arenaroot pointer to list of SV arenas | |
98 | PL_sv_root pointer to list of free SV structures | |
99 | ||
d2a0f284 JC |
100 | PL_body_arenas head of linked-list of body arenas |
101 | PL_body_roots[] array of pointers to list of free bodies of svtype | |
102 | arrays are indexed by the svtype needed | |
93e68bfb | 103 | |
d2a0f284 JC |
104 | A few special SV heads are not allocated from an arena, but are |
105 | instead directly created in the interpreter structure, eg PL_sv_undef. | |
93e68bfb JC |
106 | The size of arenas can be changed from the default by setting |
107 | PERL_ARENA_SIZE appropriately at compile time. | |
645c22ef DM |
108 | |
109 | The SV arena serves the secondary purpose of allowing still-live SVs | |
110 | to be located and destroyed during final cleanup. | |
111 | ||
112 | At the lowest level, the macros new_SV() and del_SV() grab and free | |
113 | an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() | |
114 | to return the SV to the free list with error checking.) new_SV() calls | |
115 | more_sv() / sv_add_arena() to add an extra arena if the free list is empty. | |
116 | SVs in the free list have their SvTYPE field set to all ones. | |
117 | ||
ff276b08 | 118 | At the time of very final cleanup, sv_free_arenas() is called from |
645c22ef | 119 | perl_destruct() to physically free all the arenas allocated since the |
6a93a7e5 | 120 | start of the interpreter. |
645c22ef | 121 | |
645c22ef DM |
122 | The function visit() scans the SV arenas list, and calls a specified |
123 | function for each SV it finds which is still live - ie which has an SvTYPE | |
124 | other than all 1's, and a non-zero SvREFCNT. visit() is used by the | |
125 | following functions (specified as [function that calls visit()] / [function | |
126 | called by visit() for each SV]): | |
127 | ||
128 | sv_report_used() / do_report_used() | |
f2524eef | 129 | dump all remaining SVs (debugging aid) |
645c22ef | 130 | |
e4487e9b | 131 | sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), |
e76981f9 | 132 | do_clean_named_io_objs(),do_curse() |
645c22ef | 133 | Attempt to free all objects pointed to by RVs, |
e76981f9 FC |
134 | try to do the same for all objects indir- |
135 | ectly referenced by typeglobs too, and | |
136 | then do a final sweep, cursing any | |
137 | objects that remain. Called once from | |
645c22ef DM |
138 | perl_destruct(), prior to calling sv_clean_all() |
139 | below. | |
140 | ||
141 | sv_clean_all() / do_clean_all() | |
142 | SvREFCNT_dec(sv) each remaining SV, possibly | |
143 | triggering an sv_free(). It also sets the | |
144 | SVf_BREAK flag on the SV to indicate that the | |
145 | refcnt has been artificially lowered, and thus | |
146 | stopping sv_free() from giving spurious warnings | |
147 | about SVs which unexpectedly have a refcnt | |
148 | of zero. called repeatedly from perl_destruct() | |
149 | until there are no SVs left. | |
150 | ||
93e68bfb | 151 | =head2 Arena allocator API Summary |
645c22ef DM |
152 | |
153 | Private API to rest of sv.c | |
154 | ||
155 | new_SV(), del_SV(), | |
156 | ||
df0f0429 | 157 | new_XPVNV(), del_XPVGV(), |
645c22ef DM |
158 | etc |
159 | ||
160 | Public API: | |
161 | ||
8cf8f3d1 | 162 | sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() |
645c22ef | 163 | |
645c22ef DM |
164 | =cut |
165 | ||
3e8320cc | 166 | * ========================================================================= */ |
645c22ef | 167 | |
4561caa4 CS |
168 | /* |
169 | * "A time to plant, and a time to uproot what was planted..." | |
170 | */ | |
171 | ||
d7a2c63c MHM |
172 | #ifdef PERL_MEM_LOG |
173 | # define MEM_LOG_NEW_SV(sv, file, line, func) \ | |
174 | Perl_mem_log_new_sv(sv, file, line, func) | |
175 | # define MEM_LOG_DEL_SV(sv, file, line, func) \ | |
176 | Perl_mem_log_del_sv(sv, file, line, func) | |
177 | #else | |
178 | # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP | |
179 | # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP | |
180 | #endif | |
181 | ||
fd0854ff | 182 | #ifdef DEBUG_LEAKING_SCALARS |
484e6108 FC |
183 | # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ |
184 | if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ | |
185 | } STMT_END | |
d7a2c63c MHM |
186 | # define DEBUG_SV_SERIAL(sv) \ |
187 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ | |
188 | PTR2UV(sv), (long)(sv)->sv_debug_serial)) | |
fd0854ff DM |
189 | #else |
190 | # define FREE_SV_DEBUG_FILE(sv) | |
d7a2c63c | 191 | # define DEBUG_SV_SERIAL(sv) NOOP |
fd0854ff DM |
192 | #endif |
193 | ||
48614a46 NC |
194 | #ifdef PERL_POISON |
195 | # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) | |
daba3364 | 196 | # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) |
48614a46 NC |
197 | /* Whilst I'd love to do this, it seems that things like to check on |
198 | unreferenced scalars | |
7e337ee0 | 199 | # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) |
48614a46 | 200 | */ |
7e337ee0 JH |
201 | # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ |
202 | PoisonNew(&SvREFCNT(sv), 1, U32) | |
48614a46 NC |
203 | #else |
204 | # define SvARENA_CHAIN(sv) SvANY(sv) | |
3eef1deb | 205 | # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) |
48614a46 NC |
206 | # define POSION_SV_HEAD(sv) |
207 | #endif | |
208 | ||
990198f0 DM |
209 | /* Mark an SV head as unused, and add to free list. |
210 | * | |
211 | * If SVf_BREAK is set, skip adding it to the free list, as this SV had | |
212 | * its refcount artificially decremented during global destruction, so | |
213 | * there may be dangling pointers to it. The last thing we want in that | |
214 | * case is for it to be reused. */ | |
215 | ||
053fc874 GS |
216 | #define plant_SV(p) \ |
217 | STMT_START { \ | |
990198f0 | 218 | const U32 old_flags = SvFLAGS(p); \ |
d7a2c63c MHM |
219 | MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
220 | DEBUG_SV_SERIAL(p); \ | |
fd0854ff | 221 | FREE_SV_DEBUG_FILE(p); \ |
48614a46 | 222 | POSION_SV_HEAD(p); \ |
053fc874 | 223 | SvFLAGS(p) = SVTYPEMASK; \ |
990198f0 | 224 | if (!(old_flags & SVf_BREAK)) { \ |
3eef1deb | 225 | SvARENA_CHAIN_SET(p, PL_sv_root); \ |
990198f0 DM |
226 | PL_sv_root = (p); \ |
227 | } \ | |
053fc874 GS |
228 | --PL_sv_count; \ |
229 | } STMT_END | |
a0d0e21e | 230 | |
053fc874 GS |
231 | #define uproot_SV(p) \ |
232 | STMT_START { \ | |
233 | (p) = PL_sv_root; \ | |
daba3364 | 234 | PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ |
053fc874 GS |
235 | ++PL_sv_count; \ |
236 | } STMT_END | |
237 | ||
645c22ef | 238 | |
cac9b346 NC |
239 | /* make some more SVs by adding another arena */ |
240 | ||
cac9b346 NC |
241 | STATIC SV* |
242 | S_more_sv(pTHX) | |
243 | { | |
97aff369 | 244 | dVAR; |
cac9b346 | 245 | SV* sv; |
9a87bd09 NC |
246 | char *chunk; /* must use New here to match call to */ |
247 | Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ | |
248 | sv_add_arena(chunk, PERL_ARENA_SIZE, 0); | |
cac9b346 NC |
249 | uproot_SV(sv); |
250 | return sv; | |
251 | } | |
252 | ||
645c22ef DM |
253 | /* new_SV(): return a new, empty SV head */ |
254 | ||
eba0f806 DM |
255 | #ifdef DEBUG_LEAKING_SCALARS |
256 | /* provide a real function for a debugger to play with */ | |
257 | STATIC SV* | |
d7a2c63c | 258 | S_new_SV(pTHX_ const char *file, int line, const char *func) |
eba0f806 DM |
259 | { |
260 | SV* sv; | |
261 | ||
eba0f806 DM |
262 | if (PL_sv_root) |
263 | uproot_SV(sv); | |
264 | else | |
cac9b346 | 265 | sv = S_more_sv(aTHX); |
eba0f806 DM |
266 | SvANY(sv) = 0; |
267 | SvREFCNT(sv) = 1; | |
268 | SvFLAGS(sv) = 0; | |
fd0854ff | 269 | sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; |
e385c3bf DM |
270 | sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE |
271 | ? PL_parser->copline | |
272 | : PL_curcop | |
f24aceb1 DM |
273 | ? CopLINE(PL_curcop) |
274 | : 0 | |
e385c3bf | 275 | ); |
fd0854ff | 276 | sv->sv_debug_inpad = 0; |
cd676548 | 277 | sv->sv_debug_parent = NULL; |
484e6108 | 278 | sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; |
d7a2c63c MHM |
279 | |
280 | sv->sv_debug_serial = PL_sv_serial++; | |
281 | ||
282 | MEM_LOG_NEW_SV(sv, file, line, func); | |
283 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", | |
284 | PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); | |
285 | ||
eba0f806 DM |
286 | return sv; |
287 | } | |
d7a2c63c | 288 | # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) |
eba0f806 DM |
289 | |
290 | #else | |
291 | # define new_SV(p) \ | |
053fc874 | 292 | STMT_START { \ |
053fc874 GS |
293 | if (PL_sv_root) \ |
294 | uproot_SV(p); \ | |
295 | else \ | |
cac9b346 | 296 | (p) = S_more_sv(aTHX); \ |
053fc874 GS |
297 | SvANY(p) = 0; \ |
298 | SvREFCNT(p) = 1; \ | |
299 | SvFLAGS(p) = 0; \ | |
d7a2c63c | 300 | MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
053fc874 | 301 | } STMT_END |
eba0f806 | 302 | #endif |
463ee0b2 | 303 | |
645c22ef DM |
304 | |
305 | /* del_SV(): return an empty SV head to the free list */ | |
306 | ||
a0d0e21e | 307 | #ifdef DEBUGGING |
4561caa4 | 308 | |
053fc874 GS |
309 | #define del_SV(p) \ |
310 | STMT_START { \ | |
aea4f609 | 311 | if (DEBUG_D_TEST) \ |
053fc874 GS |
312 | del_sv(p); \ |
313 | else \ | |
314 | plant_SV(p); \ | |
053fc874 | 315 | } STMT_END |
a0d0e21e | 316 | |
76e3520e | 317 | STATIC void |
cea2e8a9 | 318 | S_del_sv(pTHX_ SV *p) |
463ee0b2 | 319 | { |
97aff369 | 320 | dVAR; |
7918f24d NC |
321 | |
322 | PERL_ARGS_ASSERT_DEL_SV; | |
323 | ||
aea4f609 | 324 | if (DEBUG_D_TEST) { |
4633a7c4 | 325 | SV* sva; |
a3b680e6 | 326 | bool ok = 0; |
daba3364 | 327 | for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
53c1dcc0 AL |
328 | const SV * const sv = sva + 1; |
329 | const SV * const svend = &sva[SvREFCNT(sva)]; | |
c0ff570e | 330 | if (p >= sv && p < svend) { |
a0d0e21e | 331 | ok = 1; |
c0ff570e NC |
332 | break; |
333 | } | |
a0d0e21e LW |
334 | } |
335 | if (!ok) { | |
9b387841 NC |
336 | Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
337 | "Attempt to free non-arena SV: 0x%"UVxf | |
338 | pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); | |
a0d0e21e LW |
339 | return; |
340 | } | |
341 | } | |
4561caa4 | 342 | plant_SV(p); |
463ee0b2 | 343 | } |
a0d0e21e | 344 | |
4561caa4 CS |
345 | #else /* ! DEBUGGING */ |
346 | ||
347 | #define del_SV(p) plant_SV(p) | |
348 | ||
349 | #endif /* DEBUGGING */ | |
463ee0b2 | 350 | |
645c22ef DM |
351 | |
352 | /* | |
ccfc67b7 JH |
353 | =head1 SV Manipulation Functions |
354 | ||
645c22ef DM |
355 | =for apidoc sv_add_arena |
356 | ||
357 | Given a chunk of memory, link it to the head of the list of arenas, | |
358 | and split it into a list of free SVs. | |
359 | ||
360 | =cut | |
361 | */ | |
362 | ||
d2bd4e7f NC |
363 | static void |
364 | S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) | |
463ee0b2 | 365 | { |
97aff369 | 366 | dVAR; |
daba3364 | 367 | SV *const sva = MUTABLE_SV(ptr); |
eb578fdb KW |
368 | SV* sv; |
369 | SV* svend; | |
4633a7c4 | 370 | |
7918f24d NC |
371 | PERL_ARGS_ASSERT_SV_ADD_ARENA; |
372 | ||
4633a7c4 | 373 | /* The first SV in an arena isn't an SV. */ |
3280af22 | 374 | SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ |
4633a7c4 LW |
375 | SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ |
376 | SvFLAGS(sva) = flags; /* FAKE if not to be freed */ | |
377 | ||
3280af22 NIS |
378 | PL_sv_arenaroot = sva; |
379 | PL_sv_root = sva + 1; | |
4633a7c4 LW |
380 | |
381 | svend = &sva[SvREFCNT(sva) - 1]; | |
382 | sv = sva + 1; | |
463ee0b2 | 383 | while (sv < svend) { |
3eef1deb | 384 | SvARENA_CHAIN_SET(sv, (sv + 1)); |
03e36789 | 385 | #ifdef DEBUGGING |
978b032e | 386 | SvREFCNT(sv) = 0; |
03e36789 | 387 | #endif |
4b69cbe3 | 388 | /* Must always set typemask because it's always checked in on cleanup |
03e36789 | 389 | when the arenas are walked looking for objects. */ |
8990e307 | 390 | SvFLAGS(sv) = SVTYPEMASK; |
463ee0b2 LW |
391 | sv++; |
392 | } | |
3eef1deb | 393 | SvARENA_CHAIN_SET(sv, 0); |
03e36789 NC |
394 | #ifdef DEBUGGING |
395 | SvREFCNT(sv) = 0; | |
396 | #endif | |
4633a7c4 LW |
397 | SvFLAGS(sv) = SVTYPEMASK; |
398 | } | |
399 | ||
055972dc DM |
400 | /* visit(): call the named function for each non-free SV in the arenas |
401 | * whose flags field matches the flags/mask args. */ | |
645c22ef | 402 | |
5226ed68 | 403 | STATIC I32 |
de37a194 | 404 | S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) |
8990e307 | 405 | { |
97aff369 | 406 | dVAR; |
4633a7c4 | 407 | SV* sva; |
5226ed68 | 408 | I32 visited = 0; |
8990e307 | 409 | |
7918f24d NC |
410 | PERL_ARGS_ASSERT_VISIT; |
411 | ||
daba3364 | 412 | for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
eb578fdb KW |
413 | const SV * const svend = &sva[SvREFCNT(sva)]; |
414 | SV* sv; | |
4561caa4 | 415 | for (sv = sva + 1; sv < svend; ++sv) { |
e4787c0c | 416 | if (SvTYPE(sv) != (svtype)SVTYPEMASK |
055972dc DM |
417 | && (sv->sv_flags & mask) == flags |
418 | && SvREFCNT(sv)) | |
419 | { | |
942481a7 | 420 | (*f)(aTHX_ sv); |
5226ed68 JH |
421 | ++visited; |
422 | } | |
8990e307 LW |
423 | } |
424 | } | |
5226ed68 | 425 | return visited; |
8990e307 LW |
426 | } |
427 | ||
758a08c3 JH |
428 | #ifdef DEBUGGING |
429 | ||
645c22ef DM |
430 | /* called by sv_report_used() for each live SV */ |
431 | ||
432 | static void | |
5fa45a31 | 433 | do_report_used(pTHX_ SV *const sv) |
645c22ef | 434 | { |
e4787c0c | 435 | if (SvTYPE(sv) != (svtype)SVTYPEMASK) { |
645c22ef DM |
436 | PerlIO_printf(Perl_debug_log, "****\n"); |
437 | sv_dump(sv); | |
438 | } | |
439 | } | |
758a08c3 | 440 | #endif |
645c22ef DM |
441 | |
442 | /* | |
443 | =for apidoc sv_report_used | |
444 | ||
fde67290 | 445 | Dump the contents of all SVs not yet freed (debugging aid). |
645c22ef DM |
446 | |
447 | =cut | |
448 | */ | |
449 | ||
8990e307 | 450 | void |
864dbfa3 | 451 | Perl_sv_report_used(pTHX) |
4561caa4 | 452 | { |
ff270d3a | 453 | #ifdef DEBUGGING |
055972dc | 454 | visit(do_report_used, 0, 0); |
96a5add6 AL |
455 | #else |
456 | PERL_UNUSED_CONTEXT; | |
ff270d3a | 457 | #endif |
4561caa4 CS |
458 | } |
459 | ||
645c22ef DM |
460 | /* called by sv_clean_objs() for each live SV */ |
461 | ||
462 | static void | |
de37a194 | 463 | do_clean_objs(pTHX_ SV *const ref) |
645c22ef | 464 | { |
97aff369 | 465 | dVAR; |
ea724faa NC |
466 | assert (SvROK(ref)); |
467 | { | |
823a54a3 AL |
468 | SV * const target = SvRV(ref); |
469 | if (SvOBJECT(target)) { | |
470 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); | |
471 | if (SvWEAKREF(ref)) { | |
472 | sv_del_backref(target, ref); | |
473 | SvWEAKREF_off(ref); | |
474 | SvRV_set(ref, NULL); | |
475 | } else { | |
476 | SvROK_off(ref); | |
477 | SvRV_set(ref, NULL); | |
fc2b2dca | 478 | SvREFCNT_dec_NN(target); |
823a54a3 | 479 | } |
645c22ef DM |
480 | } |
481 | } | |
645c22ef DM |
482 | } |
483 | ||
645c22ef | 484 | |
e4487e9b DM |
485 | /* clear any slots in a GV which hold objects - except IO; |
486 | * called by sv_clean_objs() for each live GV */ | |
487 | ||
645c22ef | 488 | static void |
f30de749 | 489 | do_clean_named_objs(pTHX_ SV *const sv) |
645c22ef | 490 | { |
97aff369 | 491 | dVAR; |
57ef47cc | 492 | SV *obj; |
ea724faa | 493 | assert(SvTYPE(sv) == SVt_PVGV); |
d011219a | 494 | assert(isGV_with_GP(sv)); |
57ef47cc DM |
495 | if (!GvGP(sv)) |
496 | return; | |
497 | ||
498 | /* freeing GP entries may indirectly free the current GV; | |
499 | * hold onto it while we mess with the GP slots */ | |
500 | SvREFCNT_inc(sv); | |
501 | ||
502 | if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { | |
503 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
504 | "Cleaning named glob SV object:\n "), sv_dump(obj))); | |
505 | GvSV(sv) = NULL; | |
fc2b2dca | 506 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
507 | } |
508 | if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { | |
509 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
510 | "Cleaning named glob AV object:\n "), sv_dump(obj))); | |
511 | GvAV(sv) = NULL; | |
fc2b2dca | 512 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
513 | } |
514 | if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { | |
515 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
516 | "Cleaning named glob HV object:\n "), sv_dump(obj))); | |
517 | GvHV(sv) = NULL; | |
fc2b2dca | 518 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
519 | } |
520 | if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { | |
521 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
522 | "Cleaning named glob CV object:\n "), sv_dump(obj))); | |
c43ae56f | 523 | GvCV_set(sv, NULL); |
fc2b2dca | 524 | SvREFCNT_dec_NN(obj); |
57ef47cc | 525 | } |
fc2b2dca | 526 | SvREFCNT_dec_NN(sv); /* undo the inc above */ |
e4487e9b DM |
527 | } |
528 | ||
68b590d9 | 529 | /* clear any IO slots in a GV which hold objects (except stderr, defout); |
e4487e9b DM |
530 | * called by sv_clean_objs() for each live GV */ |
531 | ||
532 | static void | |
533 | do_clean_named_io_objs(pTHX_ SV *const sv) | |
534 | { | |
535 | dVAR; | |
536 | SV *obj; | |
537 | assert(SvTYPE(sv) == SVt_PVGV); | |
538 | assert(isGV_with_GP(sv)); | |
68b590d9 | 539 | if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) |
e4487e9b DM |
540 | return; |
541 | ||
542 | SvREFCNT_inc(sv); | |
57ef47cc DM |
543 | if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { |
544 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
545 | "Cleaning named glob IO object:\n "), sv_dump(obj))); | |
546 | GvIOp(sv) = NULL; | |
fc2b2dca | 547 | SvREFCNT_dec_NN(obj); |
645c22ef | 548 | } |
fc2b2dca | 549 | SvREFCNT_dec_NN(sv); /* undo the inc above */ |
645c22ef | 550 | } |
645c22ef | 551 | |
4155e4fe FC |
552 | /* Void wrapper to pass to visit() */ |
553 | static void | |
554 | do_curse(pTHX_ SV * const sv) { | |
c2910e6c FC |
555 | if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) |
556 | || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) | |
4155e4fe FC |
557 | return; |
558 | (void)curse(sv, 0); | |
559 | } | |
560 | ||
645c22ef DM |
561 | /* |
562 | =for apidoc sv_clean_objs | |
563 | ||
fde67290 | 564 | Attempt to destroy all objects not yet freed. |
645c22ef DM |
565 | |
566 | =cut | |
567 | */ | |
568 | ||
4561caa4 | 569 | void |
864dbfa3 | 570 | Perl_sv_clean_objs(pTHX) |
4561caa4 | 571 | { |
97aff369 | 572 | dVAR; |
68b590d9 | 573 | GV *olddef, *olderr; |
3280af22 | 574 | PL_in_clean_objs = TRUE; |
055972dc | 575 | visit(do_clean_objs, SVf_ROK, SVf_ROK); |
e4487e9b DM |
576 | /* Some barnacles may yet remain, clinging to typeglobs. |
577 | * Run the non-IO destructors first: they may want to output | |
578 | * error messages, close files etc */ | |
d011219a | 579 | visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
e4487e9b | 580 | visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
4155e4fe FC |
581 | /* And if there are some very tenacious barnacles clinging to arrays, |
582 | closures, or what have you.... */ | |
583 | visit(do_curse, SVs_OBJECT, SVs_OBJECT); | |
68b590d9 DM |
584 | olddef = PL_defoutgv; |
585 | PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ | |
586 | if (olddef && isGV_with_GP(olddef)) | |
587 | do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); | |
588 | olderr = PL_stderrgv; | |
589 | PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ | |
590 | if (olderr && isGV_with_GP(olderr)) | |
591 | do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); | |
592 | SvREFCNT_dec(olddef); | |
3280af22 | 593 | PL_in_clean_objs = FALSE; |
4561caa4 CS |
594 | } |
595 | ||
645c22ef DM |
596 | /* called by sv_clean_all() for each live SV */ |
597 | ||
598 | static void | |
de37a194 | 599 | do_clean_all(pTHX_ SV *const sv) |
645c22ef | 600 | { |
97aff369 | 601 | dVAR; |
daba3364 | 602 | if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { |
cddfcddc | 603 | /* don't clean pid table and strtab */ |
d17ea597 | 604 | return; |
cddfcddc | 605 | } |
645c22ef DM |
606 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); |
607 | SvFLAGS(sv) |= SVf_BREAK; | |
fc2b2dca | 608 | SvREFCNT_dec_NN(sv); |
645c22ef DM |
609 | } |
610 | ||
611 | /* | |
612 | =for apidoc sv_clean_all | |
613 | ||
614 | Decrement the refcnt of each remaining SV, possibly triggering a | |
fde67290 | 615 | cleanup. This function may have to be called multiple times to free |
ff276b08 | 616 | SVs which are in complex self-referential hierarchies. |
645c22ef DM |
617 | |
618 | =cut | |
619 | */ | |
620 | ||
5226ed68 | 621 | I32 |
864dbfa3 | 622 | Perl_sv_clean_all(pTHX) |
8990e307 | 623 | { |
97aff369 | 624 | dVAR; |
5226ed68 | 625 | I32 cleaned; |
3280af22 | 626 | PL_in_clean_all = TRUE; |
055972dc | 627 | cleaned = visit(do_clean_all, 0,0); |
5226ed68 | 628 | return cleaned; |
8990e307 | 629 | } |
463ee0b2 | 630 | |
5e258f8c JC |
631 | /* |
632 | ARENASETS: a meta-arena implementation which separates arena-info | |
633 | into struct arena_set, which contains an array of struct | |
634 | arena_descs, each holding info for a single arena. By separating | |
635 | the meta-info from the arena, we recover the 1st slot, formerly | |
636 | borrowed for list management. The arena_set is about the size of an | |
39244528 | 637 | arena, avoiding the needless malloc overhead of a naive linked-list. |
5e258f8c JC |
638 | |
639 | The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused | |
640 | memory in the last arena-set (1/2 on average). In trade, we get | |
641 | back the 1st slot in each arena (ie 1.7% of a CV-arena, less for | |
d2a0f284 | 642 | smaller types). The recovery of the wasted space allows use of |
e15dad31 JC |
643 | small arenas for large, rare body types, by changing array* fields |
644 | in body_details_by_type[] below. | |
5e258f8c | 645 | */ |
5e258f8c | 646 | struct arena_desc { |
398c677b NC |
647 | char *arena; /* the raw storage, allocated aligned */ |
648 | size_t size; /* its size ~4k typ */ | |
e5973ed5 | 649 | svtype utype; /* bodytype stored in arena */ |
5e258f8c JC |
650 | }; |
651 | ||
e6148039 NC |
652 | struct arena_set; |
653 | ||
654 | /* Get the maximum number of elements in set[] such that struct arena_set | |
e15dad31 | 655 | will fit within PERL_ARENA_SIZE, which is probably just under 4K, and |
e6148039 NC |
656 | therefore likely to be 1 aligned memory page. */ |
657 | ||
658 | #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ | |
659 | - 2 * sizeof(int)) / sizeof (struct arena_desc)) | |
5e258f8c JC |
660 | |
661 | struct arena_set { | |
662 | struct arena_set* next; | |
0a848332 NC |
663 | unsigned int set_size; /* ie ARENAS_PER_SET */ |
664 | unsigned int curr; /* index of next available arena-desc */ | |
5e258f8c JC |
665 | struct arena_desc set[ARENAS_PER_SET]; |
666 | }; | |
667 | ||
645c22ef DM |
668 | /* |
669 | =for apidoc sv_free_arenas | |
670 | ||
fde67290 | 671 | Deallocate the memory used by all arenas. Note that all the individual SV |
645c22ef DM |
672 | heads and bodies within the arenas must already have been freed. |
673 | ||
674 | =cut | |
675 | */ | |
4633a7c4 | 676 | void |
864dbfa3 | 677 | Perl_sv_free_arenas(pTHX) |
4633a7c4 | 678 | { |
97aff369 | 679 | dVAR; |
4633a7c4 LW |
680 | SV* sva; |
681 | SV* svanext; | |
0a848332 | 682 | unsigned int i; |
4633a7c4 LW |
683 | |
684 | /* Free arenas here, but be careful about fake ones. (We assume | |
685 | contiguity of the fake ones with the corresponding real ones.) */ | |
686 | ||
3280af22 | 687 | for (sva = PL_sv_arenaroot; sva; sva = svanext) { |
daba3364 | 688 | svanext = MUTABLE_SV(SvANY(sva)); |
4633a7c4 | 689 | while (svanext && SvFAKE(svanext)) |
daba3364 | 690 | svanext = MUTABLE_SV(SvANY(svanext)); |
4633a7c4 LW |
691 | |
692 | if (!SvFAKE(sva)) | |
1df70142 | 693 | Safefree(sva); |
4633a7c4 | 694 | } |
93e68bfb | 695 | |
5e258f8c | 696 | { |
0a848332 NC |
697 | struct arena_set *aroot = (struct arena_set*) PL_body_arenas; |
698 | ||
699 | while (aroot) { | |
700 | struct arena_set *current = aroot; | |
701 | i = aroot->curr; | |
702 | while (i--) { | |
5e258f8c JC |
703 | assert(aroot->set[i].arena); |
704 | Safefree(aroot->set[i].arena); | |
705 | } | |
0a848332 NC |
706 | aroot = aroot->next; |
707 | Safefree(current); | |
5e258f8c JC |
708 | } |
709 | } | |
dc8220bf | 710 | PL_body_arenas = 0; |
fdda85ca | 711 | |
0a848332 NC |
712 | i = PERL_ARENA_ROOTS_SIZE; |
713 | while (i--) | |
93e68bfb | 714 | PL_body_roots[i] = 0; |
93e68bfb | 715 | |
3280af22 NIS |
716 | PL_sv_arenaroot = 0; |
717 | PL_sv_root = 0; | |
4633a7c4 LW |
718 | } |
719 | ||
bd81e77b NC |
720 | /* |
721 | Here are mid-level routines that manage the allocation of bodies out | |
722 | of the various arenas. There are 5 kinds of arenas: | |
29489e7c | 723 | |
bd81e77b NC |
724 | 1. SV-head arenas, which are discussed and handled above |
725 | 2. regular body arenas | |
726 | 3. arenas for reduced-size bodies | |
727 | 4. Hash-Entry arenas | |
29489e7c | 728 | |
bd81e77b NC |
729 | Arena types 2 & 3 are chained by body-type off an array of |
730 | arena-root pointers, which is indexed by svtype. Some of the | |
731 | larger/less used body types are malloced singly, since a large | |
732 | unused block of them is wasteful. Also, several svtypes dont have | |
733 | bodies; the data fits into the sv-head itself. The arena-root | |
734 | pointer thus has a few unused root-pointers (which may be hijacked | |
735 | later for arena types 4,5) | |
29489e7c | 736 | |
bd81e77b NC |
737 | 3 differs from 2 as an optimization; some body types have several |
738 | unused fields in the front of the structure (which are kept in-place | |
739 | for consistency). These bodies can be allocated in smaller chunks, | |
740 | because the leading fields arent accessed. Pointers to such bodies | |
741 | are decremented to point at the unused 'ghost' memory, knowing that | |
742 | the pointers are used with offsets to the real memory. | |
29489e7c | 743 | |
d2a0f284 JC |
744 | |
745 | =head1 SV-Body Allocation | |
746 | ||
747 | Allocation of SV-bodies is similar to SV-heads, differing as follows; | |
748 | the allocation mechanism is used for many body types, so is somewhat | |
749 | more complicated, it uses arena-sets, and has no need for still-live | |
750 | SV detection. | |
751 | ||
752 | At the outermost level, (new|del)_X*V macros return bodies of the | |
753 | appropriate type. These macros call either (new|del)_body_type or | |
754 | (new|del)_body_allocated macro pairs, depending on specifics of the | |
755 | type. Most body types use the former pair, the latter pair is used to | |
756 | allocate body types with "ghost fields". | |
757 | ||
758 | "ghost fields" are fields that are unused in certain types, and | |
69ba284b | 759 | consequently don't need to actually exist. They are declared because |
d2a0f284 JC |
760 | they're part of a "base type", which allows use of functions as |
761 | methods. The simplest examples are AVs and HVs, 2 aggregate types | |
762 | which don't use the fields which support SCALAR semantics. | |
763 | ||
69ba284b | 764 | For these types, the arenas are carved up into appropriately sized |
d2a0f284 JC |
765 | chunks, we thus avoid wasted memory for those unaccessed members. |
766 | When bodies are allocated, we adjust the pointer back in memory by the | |
69ba284b | 767 | size of the part not allocated, so it's as if we allocated the full |
d2a0f284 JC |
768 | structure. (But things will all go boom if you write to the part that |
769 | is "not there", because you'll be overwriting the last members of the | |
770 | preceding structure in memory.) | |
771 | ||
69ba284b NC |
772 | We calculate the correction using the STRUCT_OFFSET macro on the first |
773 | member present. If the allocated structure is smaller (no initial NV | |
774 | actually allocated) then the net effect is to subtract the size of the NV | |
775 | from the pointer, to return a new pointer as if an initial NV were actually | |
776 | allocated. (We were using structures named *_allocated for this, but | |
777 | this turned out to be a subtle bug, because a structure without an NV | |
778 | could have a lower alignment constraint, but the compiler is allowed to | |
779 | optimised accesses based on the alignment constraint of the actual pointer | |
780 | to the full structure, for example, using a single 64 bit load instruction | |
781 | because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) | |
d2a0f284 JC |
782 | |
783 | This is the same trick as was used for NV and IV bodies. Ironically it | |
784 | doesn't need to be used for NV bodies any more, because NV is now at | |
785 | the start of the structure. IV bodies don't need it either, because | |
786 | they are no longer allocated. | |
787 | ||
788 | In turn, the new_body_* allocators call S_new_body(), which invokes | |
789 | new_body_inline macro, which takes a lock, and takes a body off the | |
1e30fcd5 | 790 | linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if |
d2a0f284 JC |
791 | necessary to refresh an empty list. Then the lock is released, and |
792 | the body is returned. | |
793 | ||
99816f8d | 794 | Perl_more_bodies allocates a new arena, and carves it up into an array of N |
d2a0f284 JC |
795 | bodies, which it strings into a linked list. It looks up arena-size |
796 | and body-size from the body_details table described below, thus | |
797 | supporting the multiple body-types. | |
798 | ||
799 | If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and | |
800 | the (new|del)_X*V macros are mapped directly to malloc/free. | |
801 | ||
d2a0f284 JC |
802 | For each sv-type, struct body_details bodies_by_type[] carries |
803 | parameters which control these aspects of SV handling: | |
804 | ||
805 | Arena_size determines whether arenas are used for this body type, and if | |
806 | so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to | |
807 | zero, forcing individual mallocs and frees. | |
808 | ||
809 | Body_size determines how big a body is, and therefore how many fit into | |
810 | each arena. Offset carries the body-pointer adjustment needed for | |
69ba284b | 811 | "ghost fields", and is used in *_allocated macros. |
d2a0f284 JC |
812 | |
813 | But its main purpose is to parameterize info needed in | |
814 | Perl_sv_upgrade(). The info here dramatically simplifies the function | |
69ba284b | 815 | vs the implementation in 5.8.8, making it table-driven. All fields |
d2a0f284 JC |
816 | are used for this, except for arena_size. |
817 | ||
818 | For the sv-types that have no bodies, arenas are not used, so those | |
819 | PL_body_roots[sv_type] are unused, and can be overloaded. In | |
820 | something of a special case, SVt_NULL is borrowed for HE arenas; | |
c6f8b1d0 | 821 | PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the |
d2a0f284 | 822 | bodies_by_type[SVt_NULL] slot is not used, as the table is not |
c6f8b1d0 | 823 | available in hv.c. |
d2a0f284 | 824 | |
29489e7c DM |
825 | */ |
826 | ||
bd81e77b | 827 | struct body_details { |
0fb58b32 | 828 | U8 body_size; /* Size to allocate */ |
10666ae3 | 829 | U8 copy; /* Size of structure to copy (may be shorter) */ |
0fb58b32 | 830 | U8 offset; |
10666ae3 NC |
831 | unsigned int type : 4; /* We have space for a sanity check. */ |
832 | unsigned int cant_upgrade : 1; /* Cannot upgrade this type */ | |
833 | unsigned int zero_nv : 1; /* zero the NV when upgrading from this */ | |
834 | unsigned int arena : 1; /* Allocated from an arena */ | |
835 | size_t arena_size; /* Size of arena to allocate */ | |
bd81e77b | 836 | }; |
29489e7c | 837 | |
bd81e77b NC |
838 | #define HADNV FALSE |
839 | #define NONV TRUE | |
29489e7c | 840 | |
d2a0f284 | 841 | |
bd81e77b NC |
842 | #ifdef PURIFY |
843 | /* With -DPURFIY we allocate everything directly, and don't use arenas. | |
844 | This seems a rather elegant way to simplify some of the code below. */ | |
845 | #define HASARENA FALSE | |
846 | #else | |
847 | #define HASARENA TRUE | |
848 | #endif | |
849 | #define NOARENA FALSE | |
29489e7c | 850 | |
d2a0f284 JC |
851 | /* Size the arenas to exactly fit a given number of bodies. A count |
852 | of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, | |
853 | simplifying the default. If count > 0, the arena is sized to fit | |
854 | only that many bodies, allowing arenas to be used for large, rare | |
855 | bodies (XPVFM, XPVIO) without undue waste. The arena size is | |
856 | limited by PERL_ARENA_SIZE, so we can safely oversize the | |
857 | declarations. | |
858 | */ | |
95db5f15 MB |
859 | #define FIT_ARENA0(body_size) \ |
860 | ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) | |
861 | #define FIT_ARENAn(count,body_size) \ | |
862 | ( count * body_size <= PERL_ARENA_SIZE) \ | |
863 | ? count * body_size \ | |
864 | : FIT_ARENA0 (body_size) | |
865 | #define FIT_ARENA(count,body_size) \ | |
866 | count \ | |
867 | ? FIT_ARENAn (count, body_size) \ | |
868 | : FIT_ARENA0 (body_size) | |
d2a0f284 | 869 | |
bd81e77b NC |
870 | /* Calculate the length to copy. Specifically work out the length less any |
871 | final padding the compiler needed to add. See the comment in sv_upgrade | |
872 | for why copying the padding proved to be a bug. */ | |
29489e7c | 873 | |
bd81e77b NC |
874 | #define copy_length(type, last_member) \ |
875 | STRUCT_OFFSET(type, last_member) \ | |
daba3364 | 876 | + sizeof (((type*)SvANY((const SV *)0))->last_member) |
29489e7c | 877 | |
bd81e77b | 878 | static const struct body_details bodies_by_type[] = { |
829cd18a NC |
879 | /* HEs use this offset for their arena. */ |
880 | { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, | |
d2a0f284 | 881 | |
db93c0c4 NC |
882 | /* IVs are in the head, so the allocation size is 0. */ |
883 | { 0, | |
d2a0f284 | 884 | sizeof(IV), /* This is used to copy out the IV body. */ |
10666ae3 | 885 | STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, |
db93c0c4 | 886 | NOARENA /* IVS don't need an arena */, 0 |
d2a0f284 JC |
887 | }, |
888 | ||
6e128786 NC |
889 | { sizeof(NV), sizeof(NV), |
890 | STRUCT_OFFSET(XPVNV, xnv_u), | |
891 | SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, | |
d2a0f284 | 892 | |
bc337e5c | 893 | { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
894 | copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), |
895 | + STRUCT_OFFSET(XPV, xpv_cur), | |
69ba284b | 896 | SVt_PV, FALSE, NONV, HASARENA, |
889d28b2 | 897 | FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
d2a0f284 | 898 | |
d361b004 KW |
899 | { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), |
900 | copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), | |
901 | + STRUCT_OFFSET(XPV, xpv_cur), | |
902 | SVt_INVLIST, TRUE, NONV, HASARENA, | |
903 | FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
e94d9b54 | 904 | |
bc337e5c | 905 | { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
906 | copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
907 | + STRUCT_OFFSET(XPV, xpv_cur), | |
908 | SVt_PVIV, FALSE, NONV, HASARENA, | |
909 | FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
d2a0f284 | 910 | |
bc337e5c | 911 | { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
912 | copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
913 | + STRUCT_OFFSET(XPV, xpv_cur), | |
914 | SVt_PVNV, FALSE, HADNV, HASARENA, | |
915 | FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
d2a0f284 | 916 | |
6e128786 | 917 | { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, |
d2a0f284 | 918 | HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, |
4df7f6af | 919 | |
601dfd0a NC |
920 | { sizeof(regexp), |
921 | sizeof(regexp), | |
922 | 0, | |
ecff11eb | 923 | SVt_REGEXP, TRUE, NONV, HASARENA, |
eaeb1e7f | 924 | FIT_ARENA(0, sizeof(regexp)) |
5c35adbb | 925 | }, |
4df7f6af | 926 | |
10666ae3 | 927 | { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, |
d2a0f284 JC |
928 | HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, |
929 | ||
10666ae3 | 930 | { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, |
d2a0f284 JC |
931 | HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, |
932 | ||
601dfd0a | 933 | { sizeof(XPVAV), |
4f7003f5 | 934 | copy_length(XPVAV, xav_alloc), |
601dfd0a | 935 | 0, |
69ba284b | 936 | SVt_PVAV, TRUE, NONV, HASARENA, |
601dfd0a | 937 | FIT_ARENA(0, sizeof(XPVAV)) }, |
d2a0f284 | 938 | |
601dfd0a | 939 | { sizeof(XPVHV), |
359164a0 | 940 | copy_length(XPVHV, xhv_max), |
601dfd0a | 941 | 0, |
69ba284b | 942 | SVt_PVHV, TRUE, NONV, HASARENA, |
601dfd0a | 943 | FIT_ARENA(0, sizeof(XPVHV)) }, |
d2a0f284 | 944 | |
601dfd0a NC |
945 | { sizeof(XPVCV), |
946 | sizeof(XPVCV), | |
947 | 0, | |
69ba284b | 948 | SVt_PVCV, TRUE, NONV, HASARENA, |
601dfd0a | 949 | FIT_ARENA(0, sizeof(XPVCV)) }, |
69ba284b | 950 | |
601dfd0a NC |
951 | { sizeof(XPVFM), |
952 | sizeof(XPVFM), | |
953 | 0, | |
69ba284b | 954 | SVt_PVFM, TRUE, NONV, NOARENA, |
601dfd0a | 955 | FIT_ARENA(20, sizeof(XPVFM)) }, |
d2a0f284 | 956 | |
601dfd0a NC |
957 | { sizeof(XPVIO), |
958 | sizeof(XPVIO), | |
959 | 0, | |
b6f60916 | 960 | SVt_PVIO, TRUE, NONV, HASARENA, |
601dfd0a | 961 | FIT_ARENA(24, sizeof(XPVIO)) }, |
bd81e77b | 962 | }; |
29489e7c | 963 | |
bd81e77b | 964 | #define new_body_allocated(sv_type) \ |
d2a0f284 | 965 | (void *)((char *)S_new_body(aTHX_ sv_type) \ |
bd81e77b | 966 | - bodies_by_type[sv_type].offset) |
29489e7c | 967 | |
26359cfa NC |
968 | /* return a thing to the free list */ |
969 | ||
970 | #define del_body(thing, root) \ | |
971 | STMT_START { \ | |
972 | void ** const thing_copy = (void **)thing; \ | |
973 | *thing_copy = *root; \ | |
974 | *root = (void*)thing_copy; \ | |
975 | } STMT_END | |
29489e7c | 976 | |
bd81e77b | 977 | #ifdef PURIFY |
29489e7c | 978 | |
beeec492 NC |
979 | #define new_XNV() safemalloc(sizeof(XPVNV)) |
980 | #define new_XPVNV() safemalloc(sizeof(XPVNV)) | |
981 | #define new_XPVMG() safemalloc(sizeof(XPVMG)) | |
29489e7c | 982 | |
beeec492 | 983 | #define del_XPVGV(p) safefree(p) |
29489e7c | 984 | |
bd81e77b | 985 | #else /* !PURIFY */ |
29489e7c | 986 | |
65ac1738 | 987 | #define new_XNV() new_body_allocated(SVt_NV) |
65ac1738 | 988 | #define new_XPVNV() new_body_allocated(SVt_PVNV) |
65ac1738 | 989 | #define new_XPVMG() new_body_allocated(SVt_PVMG) |
645c22ef | 990 | |
26359cfa NC |
991 | #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ |
992 | &PL_body_roots[SVt_PVGV]) | |
1d7c1841 | 993 | |
bd81e77b | 994 | #endif /* PURIFY */ |
93e68bfb | 995 | |
bd81e77b | 996 | /* no arena for you! */ |
93e68bfb | 997 | |
bd81e77b | 998 | #define new_NOARENA(details) \ |
beeec492 | 999 | safemalloc((details)->body_size + (details)->offset) |
bd81e77b | 1000 | #define new_NOARENAZ(details) \ |
beeec492 | 1001 | safecalloc((details)->body_size + (details)->offset, 1) |
d2a0f284 | 1002 | |
1e30fcd5 NC |
1003 | void * |
1004 | Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, | |
1005 | const size_t arena_size) | |
d2a0f284 JC |
1006 | { |
1007 | dVAR; | |
1008 | void ** const root = &PL_body_roots[sv_type]; | |
99816f8d NC |
1009 | struct arena_desc *adesc; |
1010 | struct arena_set *aroot = (struct arena_set *) PL_body_arenas; | |
1011 | unsigned int curr; | |
d2a0f284 JC |
1012 | char *start; |
1013 | const char *end; | |
02982131 | 1014 | const size_t good_arena_size = Perl_malloc_good_size(arena_size); |
0b2d3faa | 1015 | #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) |
23e9d66c NC |
1016 | static bool done_sanity_check; |
1017 | ||
0b2d3faa JH |
1018 | /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global |
1019 | * variables like done_sanity_check. */ | |
10666ae3 | 1020 | if (!done_sanity_check) { |
ea471437 | 1021 | unsigned int i = SVt_LAST; |
10666ae3 NC |
1022 | |
1023 | done_sanity_check = TRUE; | |
1024 | ||
1025 | while (i--) | |
1026 | assert (bodies_by_type[i].type == i); | |
1027 | } | |
1028 | #endif | |
1029 | ||
02982131 | 1030 | assert(arena_size); |
23e9d66c | 1031 | |
99816f8d NC |
1032 | /* may need new arena-set to hold new arena */ |
1033 | if (!aroot || aroot->curr >= aroot->set_size) { | |
1034 | struct arena_set *newroot; | |
1035 | Newxz(newroot, 1, struct arena_set); | |
1036 | newroot->set_size = ARENAS_PER_SET; | |
1037 | newroot->next = aroot; | |
1038 | aroot = newroot; | |
1039 | PL_body_arenas = (void *) newroot; | |
1040 | DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); | |
1041 | } | |
1042 | ||
1043 | /* ok, now have arena-set with at least 1 empty/available arena-desc */ | |
1044 | curr = aroot->curr++; | |
1045 | adesc = &(aroot->set[curr]); | |
1046 | assert(!adesc->arena); | |
1047 | ||
1048 | Newx(adesc->arena, good_arena_size, char); | |
1049 | adesc->size = good_arena_size; | |
1050 | adesc->utype = sv_type; | |
1051 | DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", | |
1052 | curr, (void*)adesc->arena, (UV)good_arena_size)); | |
1053 | ||
1054 | start = (char *) adesc->arena; | |
d2a0f284 | 1055 | |
29657bb6 NC |
1056 | /* Get the address of the byte after the end of the last body we can fit. |
1057 | Remember, this is integer division: */ | |
02982131 | 1058 | end = start + good_arena_size / body_size * body_size; |
d2a0f284 | 1059 | |
486ec47a | 1060 | /* computed count doesn't reflect the 1st slot reservation */ |
d8fca402 NC |
1061 | #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) |
1062 | DEBUG_m(PerlIO_printf(Perl_debug_log, | |
1063 | "arena %p end %p arena-size %d (from %d) type %d " | |
1064 | "size %d ct %d\n", | |
02982131 NC |
1065 | (void*)start, (void*)end, (int)good_arena_size, |
1066 | (int)arena_size, sv_type, (int)body_size, | |
1067 | (int)good_arena_size / (int)body_size)); | |
d8fca402 | 1068 | #else |
d2a0f284 JC |
1069 | DEBUG_m(PerlIO_printf(Perl_debug_log, |
1070 | "arena %p end %p arena-size %d type %d size %d ct %d\n", | |
6c9570dc | 1071 | (void*)start, (void*)end, |
02982131 NC |
1072 | (int)arena_size, sv_type, (int)body_size, |
1073 | (int)good_arena_size / (int)body_size)); | |
d8fca402 | 1074 | #endif |
d2a0f284 JC |
1075 | *root = (void *)start; |
1076 | ||
29657bb6 NC |
1077 | while (1) { |
1078 | /* Where the next body would start: */ | |
d2a0f284 | 1079 | char * const next = start + body_size; |
29657bb6 NC |
1080 | |
1081 | if (next >= end) { | |
1082 | /* This is the last body: */ | |
1083 | assert(next == end); | |
1084 | ||
1085 | *(void **)start = 0; | |
1086 | return *root; | |
1087 | } | |
1088 | ||
d2a0f284 JC |
1089 | *(void**) start = (void *)next; |
1090 | start = next; | |
1091 | } | |
d2a0f284 JC |
1092 | } |
1093 | ||
1094 | /* grab a new thing from the free list, allocating more if necessary. | |
1095 | The inline version is used for speed in hot routines, and the | |
1096 | function using it serves the rest (unless PURIFY). | |
1097 | */ | |
1098 | #define new_body_inline(xpv, sv_type) \ | |
1099 | STMT_START { \ | |
1100 | void ** const r3wt = &PL_body_roots[sv_type]; \ | |
11b79775 | 1101 | xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ |
1e30fcd5 | 1102 | ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ |
02982131 NC |
1103 | bodies_by_type[sv_type].body_size,\ |
1104 | bodies_by_type[sv_type].arena_size)); \ | |
d2a0f284 | 1105 | *(r3wt) = *(void**)(xpv); \ |
d2a0f284 JC |
1106 | } STMT_END |
1107 | ||
1108 | #ifndef PURIFY | |
1109 | ||
1110 | STATIC void * | |
de37a194 | 1111 | S_new_body(pTHX_ const svtype sv_type) |
d2a0f284 JC |
1112 | { |
1113 | dVAR; | |
1114 | void *xpv; | |
1115 | new_body_inline(xpv, sv_type); | |
1116 | return xpv; | |
1117 | } | |
1118 | ||
1119 | #endif | |
93e68bfb | 1120 | |
238b27b3 NC |
1121 | static const struct body_details fake_rv = |
1122 | { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; | |
1123 | ||
bd81e77b NC |
1124 | /* |
1125 | =for apidoc sv_upgrade | |
93e68bfb | 1126 | |
bd81e77b NC |
1127 | Upgrade an SV to a more complex form. Generally adds a new body type to the |
1128 | SV, then copies across as much information as possible from the old body. | |
9521ca61 FC |
1129 | It croaks if the SV is already in a more complex form than requested. You |
1130 | generally want to use the C<SvUPGRADE> macro wrapper, which checks the type | |
1131 | before calling C<sv_upgrade>, and hence does not croak. See also | |
1132 | C<svtype>. | |
93e68bfb | 1133 | |
bd81e77b | 1134 | =cut |
93e68bfb | 1135 | */ |
93e68bfb | 1136 | |
bd81e77b | 1137 | void |
5aaab254 | 1138 | Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) |
cac9b346 | 1139 | { |
97aff369 | 1140 | dVAR; |
bd81e77b NC |
1141 | void* old_body; |
1142 | void* new_body; | |
42d0e0b7 | 1143 | const svtype old_type = SvTYPE(sv); |
d2a0f284 | 1144 | const struct body_details *new_type_details; |
238b27b3 | 1145 | const struct body_details *old_type_details |
bd81e77b | 1146 | = bodies_by_type + old_type; |
4df7f6af | 1147 | SV *referant = NULL; |
cac9b346 | 1148 | |
7918f24d NC |
1149 | PERL_ARGS_ASSERT_SV_UPGRADE; |
1150 | ||
1776cbe8 NC |
1151 | if (old_type == new_type) |
1152 | return; | |
1153 | ||
1154 | /* This clause was purposefully added ahead of the early return above to | |
1155 | the shared string hackery for (sort {$a <=> $b} keys %hash), with the | |
1156 | inference by Nick I-S that it would fix other troublesome cases. See | |
1157 | changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) | |
1158 | ||
1159 | Given that shared hash key scalars are no longer PVIV, but PV, there is | |
1160 | no longer need to unshare so as to free up the IVX slot for its proper | |
1161 | purpose. So it's safe to move the early return earlier. */ | |
1162 | ||
093085a8 | 1163 | if (new_type > SVt_PVMG && SvIsCOW(sv)) { |
bd81e77b NC |
1164 | sv_force_normal_flags(sv, 0); |
1165 | } | |
cac9b346 | 1166 | |
bd81e77b | 1167 | old_body = SvANY(sv); |
de042e1d | 1168 | |
bd81e77b NC |
1169 | /* Copying structures onto other structures that have been neatly zeroed |
1170 | has a subtle gotcha. Consider XPVMG | |
cac9b346 | 1171 | |
bd81e77b NC |
1172 | +------+------+------+------+------+-------+-------+ |
1173 | | NV | CUR | LEN | IV | MAGIC | STASH | | |
1174 | +------+------+------+------+------+-------+-------+ | |
1175 | 0 4 8 12 16 20 24 28 | |
645c22ef | 1176 | |
bd81e77b NC |
1177 | where NVs are aligned to 8 bytes, so that sizeof that structure is |
1178 | actually 32 bytes long, with 4 bytes of padding at the end: | |
08742458 | 1179 | |
bd81e77b NC |
1180 | +------+------+------+------+------+-------+-------+------+ |
1181 | | NV | CUR | LEN | IV | MAGIC | STASH | ??? | | |
1182 | +------+------+------+------+------+-------+-------+------+ | |
1183 | 0 4 8 12 16 20 24 28 32 | |
08742458 | 1184 | |
bd81e77b | 1185 | so what happens if you allocate memory for this structure: |
30f9da9e | 1186 | |
bd81e77b NC |
1187 | +------+------+------+------+------+-------+-------+------+------+... |
1188 | | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | | |
1189 | +------+------+------+------+------+-------+-------+------+------+... | |
1190 | 0 4 8 12 16 20 24 28 32 36 | |
bfc44f79 | 1191 | |
bd81e77b NC |
1192 | zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you |
1193 | expect, because you copy the area marked ??? onto GP. Now, ??? may have | |
1194 | started out as zero once, but it's quite possible that it isn't. So now, | |
1195 | rather than a nicely zeroed GP, you have it pointing somewhere random. | |
1196 | Bugs ensue. | |
bfc44f79 | 1197 | |
bd81e77b NC |
1198 | (In fact, GP ends up pointing at a previous GP structure, because the |
1199 | principle cause of the padding in XPVMG getting garbage is a copy of | |
6c9e42f7 NC |
1200 | sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now |
1201 | this happens to be moot because XPVGV has been re-ordered, with GP | |
1202 | no longer after STASH) | |
30f9da9e | 1203 | |
bd81e77b NC |
1204 | So we are careful and work out the size of used parts of all the |
1205 | structures. */ | |
bfc44f79 | 1206 | |
bd81e77b NC |
1207 | switch (old_type) { |
1208 | case SVt_NULL: | |
1209 | break; | |
1210 | case SVt_IV: | |
4df7f6af NC |
1211 | if (SvROK(sv)) { |
1212 | referant = SvRV(sv); | |
238b27b3 NC |
1213 | old_type_details = &fake_rv; |
1214 | if (new_type == SVt_NV) | |
1215 | new_type = SVt_PVNV; | |
4df7f6af NC |
1216 | } else { |
1217 | if (new_type < SVt_PVIV) { | |
1218 | new_type = (new_type == SVt_NV) | |
1219 | ? SVt_PVNV : SVt_PVIV; | |
1220 | } | |
bd81e77b NC |
1221 | } |
1222 | break; | |
1223 | case SVt_NV: | |
1224 | if (new_type < SVt_PVNV) { | |
1225 | new_type = SVt_PVNV; | |
bd81e77b NC |
1226 | } |
1227 | break; | |
bd81e77b NC |
1228 | case SVt_PV: |
1229 | assert(new_type > SVt_PV); | |
1230 | assert(SVt_IV < SVt_PV); | |
1231 | assert(SVt_NV < SVt_PV); | |
1232 | break; | |
1233 | case SVt_PVIV: | |
1234 | break; | |
1235 | case SVt_PVNV: | |
1236 | break; | |
1237 | case SVt_PVMG: | |
1238 | /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, | |
1239 | there's no way that it can be safely upgraded, because perl.c | |
1240 | expects to Safefree(SvANY(PL_mess_sv)) */ | |
1241 | assert(sv != PL_mess_sv); | |
1242 | /* This flag bit is used to mean other things in other scalar types. | |
1243 | Given that it only has meaning inside the pad, it shouldn't be set | |
1244 | on anything that can get upgraded. */ | |
00b1698f | 1245 | assert(!SvPAD_TYPED(sv)); |
bd81e77b NC |
1246 | break; |
1247 | default: | |
2439e033 | 1248 | if (UNLIKELY(old_type_details->cant_upgrade)) |
c81225bc NC |
1249 | Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, |
1250 | sv_reftype(sv, 0), (UV) old_type, (UV) new_type); | |
bd81e77b | 1251 | } |
3376de98 | 1252 | |
2439e033 | 1253 | if (UNLIKELY(old_type > new_type)) |
3376de98 NC |
1254 | Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", |
1255 | (int)old_type, (int)new_type); | |
1256 | ||
2fa1109b | 1257 | new_type_details = bodies_by_type + new_type; |
645c22ef | 1258 | |
bd81e77b NC |
1259 | SvFLAGS(sv) &= ~SVTYPEMASK; |
1260 | SvFLAGS(sv) |= new_type; | |
932e9ff9 | 1261 | |
ab4416c0 NC |
1262 | /* This can't happen, as SVt_NULL is <= all values of new_type, so one of |
1263 | the return statements above will have triggered. */ | |
1264 | assert (new_type != SVt_NULL); | |
bd81e77b | 1265 | switch (new_type) { |
bd81e77b NC |
1266 | case SVt_IV: |
1267 | assert(old_type == SVt_NULL); | |
1268 | SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); | |
1269 | SvIV_set(sv, 0); | |
1270 | return; | |
1271 | case SVt_NV: | |
1272 | assert(old_type == SVt_NULL); | |
1273 | SvANY(sv) = new_XNV(); | |
1274 | SvNV_set(sv, 0); | |
1275 | return; | |
bd81e77b | 1276 | case SVt_PVHV: |
bd81e77b | 1277 | case SVt_PVAV: |
d2a0f284 | 1278 | assert(new_type_details->body_size); |
c1ae03ae NC |
1279 | |
1280 | #ifndef PURIFY | |
1281 | assert(new_type_details->arena); | |
d2a0f284 | 1282 | assert(new_type_details->arena_size); |
c1ae03ae | 1283 | /* This points to the start of the allocated area. */ |
d2a0f284 JC |
1284 | new_body_inline(new_body, new_type); |
1285 | Zero(new_body, new_type_details->body_size, char); | |
c1ae03ae NC |
1286 | new_body = ((char *)new_body) - new_type_details->offset; |
1287 | #else | |
1288 | /* We always allocated the full length item with PURIFY. To do this | |
1289 | we fake things so that arena is false for all 16 types.. */ | |
1290 | new_body = new_NOARENAZ(new_type_details); | |
1291 | #endif | |
1292 | SvANY(sv) = new_body; | |
1293 | if (new_type == SVt_PVAV) { | |
1294 | AvMAX(sv) = -1; | |
1295 | AvFILLp(sv) = -1; | |
1296 | AvREAL_only(sv); | |
64484faa | 1297 | if (old_type_details->body_size) { |
ac572bf4 NC |
1298 | AvALLOC(sv) = 0; |
1299 | } else { | |
1300 | /* It will have been zeroed when the new body was allocated. | |
1301 | Lets not write to it, in case it confuses a write-back | |
1302 | cache. */ | |
1303 | } | |
78ac7dd9 NC |
1304 | } else { |
1305 | assert(!SvOK(sv)); | |
1306 | SvOK_off(sv); | |
1307 | #ifndef NODEFAULT_SHAREKEYS | |
1308 | HvSHAREKEYS_on(sv); /* key-sharing on by default */ | |
1309 | #endif | |
586fc6a3 S |
1310 | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ |
1311 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; | |
c1ae03ae | 1312 | } |
aeb18a1e | 1313 | |
bd81e77b NC |
1314 | /* SVt_NULL isn't the only thing upgraded to AV or HV. |
1315 | The target created by newSVrv also is, and it can have magic. | |
1316 | However, it never has SvPVX set. | |
1317 | */ | |
4df7f6af NC |
1318 | if (old_type == SVt_IV) { |
1319 | assert(!SvROK(sv)); | |
1320 | } else if (old_type >= SVt_PV) { | |
bd81e77b NC |
1321 | assert(SvPVX_const(sv) == 0); |
1322 | } | |
aeb18a1e | 1323 | |
bd81e77b | 1324 | if (old_type >= SVt_PVMG) { |
e736a858 | 1325 | SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); |
bd81e77b | 1326 | SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); |
797c7171 NC |
1327 | } else { |
1328 | sv->sv_u.svu_array = NULL; /* or svu_hash */ | |
bd81e77b NC |
1329 | } |
1330 | break; | |
93e68bfb | 1331 | |
bd81e77b NC |
1332 | case SVt_PVIV: |
1333 | /* XXX Is this still needed? Was it ever needed? Surely as there is | |
1334 | no route from NV to PVIV, NOK can never be true */ | |
1335 | assert(!SvNOKp(sv)); | |
1336 | assert(!SvNOK(sv)); | |
1337 | case SVt_PVIO: | |
1338 | case SVt_PVFM: | |
bd81e77b NC |
1339 | case SVt_PVGV: |
1340 | case SVt_PVCV: | |
1341 | case SVt_PVLV: | |
d361b004 | 1342 | case SVt_INVLIST: |
12c45b25 | 1343 | case SVt_REGEXP: |
bd81e77b NC |
1344 | case SVt_PVMG: |
1345 | case SVt_PVNV: | |
1346 | case SVt_PV: | |
93e68bfb | 1347 | |
d2a0f284 | 1348 | assert(new_type_details->body_size); |
bd81e77b NC |
1349 | /* We always allocated the full length item with PURIFY. To do this |
1350 | we fake things so that arena is false for all 16 types.. */ | |
1351 | if(new_type_details->arena) { | |
1352 | /* This points to the start of the allocated area. */ | |
d2a0f284 JC |
1353 | new_body_inline(new_body, new_type); |
1354 | Zero(new_body, new_type_details->body_size, char); | |
bd81e77b NC |
1355 | new_body = ((char *)new_body) - new_type_details->offset; |
1356 | } else { | |
1357 | new_body = new_NOARENAZ(new_type_details); | |
1358 | } | |
1359 | SvANY(sv) = new_body; | |
5e2fc214 | 1360 | |
bd81e77b | 1361 | if (old_type_details->copy) { |
f9ba3d20 NC |
1362 | /* There is now the potential for an upgrade from something without |
1363 | an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ | |
1364 | int offset = old_type_details->offset; | |
1365 | int length = old_type_details->copy; | |
1366 | ||
1367 | if (new_type_details->offset > old_type_details->offset) { | |
d4c19fe8 | 1368 | const int difference |
f9ba3d20 NC |
1369 | = new_type_details->offset - old_type_details->offset; |
1370 | offset += difference; | |
1371 | length -= difference; | |
1372 | } | |
1373 | assert (length >= 0); | |
1374 | ||
1375 | Copy((char *)old_body + offset, (char *)new_body + offset, length, | |
1376 | char); | |
bd81e77b NC |
1377 | } |
1378 | ||
1379 | #ifndef NV_ZERO_IS_ALLBITS_ZERO | |
f2524eef | 1380 | /* If NV 0.0 is stores as all bits 0 then Zero() already creates a |
e5ce394c NC |
1381 | * correct 0.0 for us. Otherwise, if the old body didn't have an |
1382 | * NV slot, but the new one does, then we need to initialise the | |
1383 | * freshly created NV slot with whatever the correct bit pattern is | |
1384 | * for 0.0 */ | |
e22a937e NC |
1385 | if (old_type_details->zero_nv && !new_type_details->zero_nv |
1386 | && !isGV_with_GP(sv)) | |
bd81e77b | 1387 | SvNV_set(sv, 0); |
82048762 | 1388 | #endif |
5e2fc214 | 1389 | |
2439e033 | 1390 | if (UNLIKELY(new_type == SVt_PVIO)) { |
85dca89a | 1391 | IO * const io = MUTABLE_IO(sv); |
d963bf01 | 1392 | GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); |
85dca89a NC |
1393 | |
1394 | SvOBJECT_on(io); | |
1395 | /* Clear the stashcache because a new IO could overrule a package | |
1396 | name */ | |
103f5a36 | 1397 | DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); |
85dca89a NC |
1398 | hv_clear(PL_stashcache); |
1399 | ||
85dca89a | 1400 | SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); |
f2524eef | 1401 | IoPAGE_LEN(sv) = 60; |
85dca89a | 1402 | } |
2439e033 | 1403 | if (UNLIKELY(new_type == SVt_REGEXP)) |
8d919b0a FC |
1404 | sv->sv_u.svu_rx = (regexp *)new_body; |
1405 | else if (old_type < SVt_PV) { | |
4df7f6af NC |
1406 | /* referant will be NULL unless the old type was SVt_IV emulating |
1407 | SVt_RV */ | |
1408 | sv->sv_u.svu_rv = referant; | |
1409 | } | |
bd81e77b NC |
1410 | break; |
1411 | default: | |
afd78fd5 JH |
1412 | Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", |
1413 | (unsigned long)new_type); | |
bd81e77b | 1414 | } |
73171d91 | 1415 | |
db93c0c4 | 1416 | if (old_type > SVt_IV) { |
bd81e77b | 1417 | #ifdef PURIFY |
beeec492 | 1418 | safefree(old_body); |
bd81e77b | 1419 | #else |
bc786448 GG |
1420 | /* Note that there is an assumption that all bodies of types that |
1421 | can be upgraded came from arenas. Only the more complex non- | |
1422 | upgradable types are allowed to be directly malloc()ed. */ | |
1423 | assert(old_type_details->arena); | |
bd81e77b NC |
1424 | del_body((void*)((char*)old_body + old_type_details->offset), |
1425 | &PL_body_roots[old_type]); | |
1426 | #endif | |
1427 | } | |
1428 | } | |
73171d91 | 1429 | |
bd81e77b NC |
1430 | /* |
1431 | =for apidoc sv_backoff | |
73171d91 | 1432 | |
fde67290 | 1433 | Remove any string offset. You should normally use the C<SvOOK_off> macro |
bd81e77b | 1434 | wrapper instead. |
73171d91 | 1435 | |
bd81e77b | 1436 | =cut |
73171d91 NC |
1437 | */ |
1438 | ||
bd81e77b | 1439 | int |
5aaab254 | 1440 | Perl_sv_backoff(pTHX_ SV *const sv) |
bd81e77b | 1441 | { |
69240efd | 1442 | STRLEN delta; |
7a4bba22 | 1443 | const char * const s = SvPVX_const(sv); |
7918f24d NC |
1444 | |
1445 | PERL_ARGS_ASSERT_SV_BACKOFF; | |
96a5add6 | 1446 | PERL_UNUSED_CONTEXT; |
7918f24d | 1447 | |
bd81e77b NC |
1448 | assert(SvOOK(sv)); |
1449 | assert(SvTYPE(sv) != SVt_PVHV); | |
1450 | assert(SvTYPE(sv) != SVt_PVAV); | |
7a4bba22 | 1451 | |
69240efd NC |
1452 | SvOOK_offset(sv, delta); |
1453 | ||
7a4bba22 NC |
1454 | SvLEN_set(sv, SvLEN(sv) + delta); |
1455 | SvPV_set(sv, SvPVX(sv) - delta); | |
1456 | Move(s, SvPVX(sv), SvCUR(sv)+1, char); | |
bd81e77b NC |
1457 | SvFLAGS(sv) &= ~SVf_OOK; |
1458 | return 0; | |
1459 | } | |
73171d91 | 1460 | |
bd81e77b NC |
1461 | /* |
1462 | =for apidoc sv_grow | |
73171d91 | 1463 | |
bd81e77b NC |
1464 | Expands the character buffer in the SV. If necessary, uses C<sv_unref> and |
1465 | upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. | |
1466 | Use the C<SvGROW> wrapper instead. | |
93e68bfb | 1467 | |
bd81e77b NC |
1468 | =cut |
1469 | */ | |
93e68bfb | 1470 | |
e0060e30 FC |
1471 | static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags); |
1472 | ||
bd81e77b | 1473 | char * |
5aaab254 | 1474 | Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) |
bd81e77b | 1475 | { |
eb578fdb | 1476 | char *s; |
93e68bfb | 1477 | |
7918f24d NC |
1478 | PERL_ARGS_ASSERT_SV_GROW; |
1479 | ||
bd81e77b NC |
1480 | if (SvROK(sv)) |
1481 | sv_unref(sv); | |
1482 | if (SvTYPE(sv) < SVt_PV) { | |
1483 | sv_upgrade(sv, SVt_PV); | |
1484 | s = SvPVX_mutable(sv); | |
1485 | } | |
1486 | else if (SvOOK(sv)) { /* pv is offset? */ | |
1487 | sv_backoff(sv); | |
1488 | s = SvPVX_mutable(sv); | |
1489 | if (newlen > SvLEN(sv)) | |
1490 | newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ | |
bd81e77b NC |
1491 | } |
1492 | else | |
db2c6cb3 | 1493 | { |
e0060e30 | 1494 | if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); |
bd81e77b | 1495 | s = SvPVX_mutable(sv); |
db2c6cb3 | 1496 | } |
aeb18a1e | 1497 | |
cbcb2a16 DM |
1498 | #ifdef PERL_NEW_COPY_ON_WRITE |
1499 | /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare) | |
1500 | * to store the COW count. So in general, allocate one more byte than | |
1501 | * asked for, to make it likely this byte is always spare: and thus | |
1502 | * make more strings COW-able. | |
1503 | * If the new size is a big power of two, don't bother: we assume the | |
1504 | * caller wanted a nice 2^N sized block and will be annoyed at getting | |
1505 | * 2^N+1 */ | |
1506 | if (newlen & 0xff) | |
1507 | newlen++; | |
1508 | #endif | |
1509 | ||
bd81e77b | 1510 | if (newlen > SvLEN(sv)) { /* need more room? */ |
f1200559 WH |
1511 | STRLEN minlen = SvCUR(sv); |
1512 | minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; | |
1513 | if (newlen < minlen) | |
1514 | newlen = minlen; | |
aedff202 | 1515 | #ifndef Perl_safesysmalloc_size |
bd81e77b | 1516 | newlen = PERL_STRLEN_ROUNDUP(newlen); |
bd81e77b | 1517 | #endif |
98653f18 | 1518 | if (SvLEN(sv) && s) { |
10edeb5d | 1519 | s = (char*)saferealloc(s, newlen); |
bd81e77b NC |
1520 | } |
1521 | else { | |
10edeb5d | 1522 | s = (char*)safemalloc(newlen); |
bd81e77b NC |
1523 | if (SvPVX_const(sv) && SvCUR(sv)) { |
1524 | Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); | |
1525 | } | |
1526 | } | |
1527 | SvPV_set(sv, s); | |
ca7c1a29 | 1528 | #ifdef Perl_safesysmalloc_size |
98653f18 NC |
1529 | /* Do this here, do it once, do it right, and then we will never get |
1530 | called back into sv_grow() unless there really is some growing | |
1531 | needed. */ | |
ca7c1a29 | 1532 | SvLEN_set(sv, Perl_safesysmalloc_size(s)); |
98653f18 | 1533 | #else |
bd81e77b | 1534 | SvLEN_set(sv, newlen); |
98653f18 | 1535 | #endif |
bd81e77b NC |
1536 | } |
1537 | return s; | |
1538 | } | |
aeb18a1e | 1539 | |
bd81e77b NC |
1540 | /* |
1541 | =for apidoc sv_setiv | |
932e9ff9 | 1542 | |
bd81e77b NC |
1543 | Copies an integer into the given SV, upgrading first if necessary. |
1544 | Does not handle 'set' magic. See also C<sv_setiv_mg>. | |
463ee0b2 | 1545 | |
bd81e77b NC |
1546 | =cut |
1547 | */ | |
463ee0b2 | 1548 | |
bd81e77b | 1549 | void |
5aaab254 | 1550 | Perl_sv_setiv(pTHX_ SV *const sv, const IV i) |
bd81e77b | 1551 | { |
97aff369 | 1552 | dVAR; |
7918f24d NC |
1553 | |
1554 | PERL_ARGS_ASSERT_SV_SETIV; | |
1555 | ||
bd81e77b NC |
1556 | SV_CHECK_THINKFIRST_COW_DROP(sv); |
1557 | switch (SvTYPE(sv)) { | |
1558 | case SVt_NULL: | |
bd81e77b | 1559 | case SVt_NV: |
3376de98 | 1560 | sv_upgrade(sv, SVt_IV); |
bd81e77b | 1561 | break; |
bd81e77b NC |
1562 | case SVt_PV: |
1563 | sv_upgrade(sv, SVt_PVIV); | |
1564 | break; | |
463ee0b2 | 1565 | |
bd81e77b | 1566 | case SVt_PVGV: |
6e592b3a BM |
1567 | if (!isGV_with_GP(sv)) |
1568 | break; | |
bd81e77b NC |
1569 | case SVt_PVAV: |
1570 | case SVt_PVHV: | |
1571 | case SVt_PVCV: | |
1572 | case SVt_PVFM: | |
1573 | case SVt_PVIO: | |
22e74366 | 1574 | /* diag_listed_as: Can't coerce %s to %s in %s */ |
bd81e77b NC |
1575 | Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), |
1576 | OP_DESC(PL_op)); | |
42d0e0b7 | 1577 | default: NOOP; |
bd81e77b NC |
1578 | } |
1579 | (void)SvIOK_only(sv); /* validate number */ | |
1580 | SvIV_set(sv, i); | |
1581 | SvTAINT(sv); | |
1582 | } | |
932e9ff9 | 1583 | |
bd81e77b NC |
1584 | /* |
1585 | =for apidoc sv_setiv_mg | |
d33b2eba | 1586 | |
bd81e77b | 1587 | Like C<sv_setiv>, but also handles 'set' magic. |
1c846c1f | 1588 | |
bd81e77b NC |
1589 | =cut |
1590 | */ | |
d33b2eba | 1591 | |
bd81e77b | 1592 | void |
5aaab254 | 1593 | Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i) |
bd81e77b | 1594 | { |
7918f24d NC |
1595 | PERL_ARGS_ASSERT_SV_SETIV_MG; |
1596 | ||
bd81e77b NC |
1597 | sv_setiv(sv,i); |
1598 | SvSETMAGIC(sv); | |
1599 | } | |
727879eb | 1600 | |
bd81e77b NC |
1601 | /* |
1602 | =for apidoc sv_setuv | |
d33b2eba | 1603 | |
bd81e77b NC |
1604 | Copies an unsigned integer into the given SV, upgrading first if necessary. |
1605 | Does not handle 'set' magic. See also C<sv_setuv_mg>. | |
9b94d1dd | 1606 | |
bd81e77b NC |
1607 | =cut |
1608 | */ | |
d33b2eba | 1609 | |
bd81e77b | 1610 | void |
5aaab254 | 1611 | Perl_sv_setuv(pTHX_ SV *const sv, const UV u) |
bd81e77b | 1612 | { |
7918f24d NC |
1613 | PERL_ARGS_ASSERT_SV_SETUV; |
1614 | ||
013abb9b NC |
1615 | /* With the if statement to ensure that integers are stored as IVs whenever |
1616 | possible: | |
bd81e77b | 1617 | u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 |
d33b2eba | 1618 | |
bd81e77b NC |
1619 | without |
1620 | u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 | |
1c846c1f | 1621 | |
013abb9b NC |
1622 | If you wish to remove the following if statement, so that this routine |
1623 | (and its callers) always return UVs, please benchmark to see what the | |
1624 | effect is. Modern CPUs may be different. Or may not :-) | |
bd81e77b NC |
1625 | */ |
1626 | if (u <= (UV)IV_MAX) { | |
1627 | sv_setiv(sv, (IV)u); | |
1628 | return; | |
1629 | } | |
1630 | sv_setiv(sv, 0); | |
1631 | SvIsUV_on(sv); | |
1632 | SvUV_set(sv, u); | |
1633 | } | |
d33b2eba | 1634 | |
bd81e77b NC |
1635 | /* |
1636 | =for apidoc sv_setuv_mg | |
727879eb | 1637 | |
bd81e77b | 1638 | Like C<sv_setuv>, but also handles 'set' magic. |
9b94d1dd | 1639 | |
bd81e77b NC |
1640 | =cut |
1641 | */ | |
5e2fc214 | 1642 | |
bd81e77b | 1643 | void |
5aaab254 | 1644 | Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u) |
bd81e77b | 1645 | { |
7918f24d NC |
1646 | PERL_ARGS_ASSERT_SV_SETUV_MG; |
1647 | ||
bd81e77b NC |
1648 | sv_setuv(sv,u); |
1649 | SvSETMAGIC(sv); | |
1650 | } | |
5e2fc214 | 1651 | |
954c1994 | 1652 | /* |
bd81e77b | 1653 | =for apidoc sv_setnv |
954c1994 | 1654 | |
bd81e77b NC |
1655 | Copies a double into the given SV, upgrading first if necessary. |
1656 | Does not handle 'set' magic. See also C<sv_setnv_mg>. | |
954c1994 GS |
1657 | |
1658 | =cut | |
1659 | */ | |
1660 | ||
63f97190 | 1661 | void |
5aaab254 | 1662 | Perl_sv_setnv(pTHX_ SV *const sv, const NV num) |
79072805 | 1663 | { |
97aff369 | 1664 | dVAR; |
7918f24d NC |
1665 | |
1666 | PERL_ARGS_ASSERT_SV_SETNV; | |
1667 | ||
bd81e77b NC |
1668 | SV_CHECK_THINKFIRST_COW_DROP(sv); |
1669 | switch (SvTYPE(sv)) { | |
79072805 | 1670 | case SVt_NULL: |
79072805 | 1671 | case SVt_IV: |
bd81e77b | 1672 | sv_upgrade(sv, SVt_NV); |
79072805 LW |
1673 | break; |
1674 | case SVt_PV: | |
79072805 | 1675 | case SVt_PVIV: |
bd81e77b | 1676 | sv_upgrade(sv, SVt_PVNV); |
79072805 | 1677 | break; |
bd4b1eb5 | 1678 | |
bd4b1eb5 | 1679 | case SVt_PVGV: |
6e592b3a BM |
1680 | if (!isGV_with_GP(sv)) |
1681 | break; | |
bd81e77b NC |
1682 | case SVt_PVAV: |
1683 | case SVt_PVHV: | |
79072805 | 1684 | case SVt_PVCV: |
bd81e77b NC |
1685 | case SVt_PVFM: |
1686 | case SVt_PVIO: | |
22e74366 | 1687 | /* diag_listed_as: Can't coerce %s to %s in %s */ |
bd81e77b | 1688 | Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), |
94bbb3f4 | 1689 | OP_DESC(PL_op)); |
42d0e0b7 | 1690 | default: NOOP; |
2068cd4d | 1691 | } |
bd81e77b NC |
1692 | SvNV_set(sv, num); |
1693 | (void)SvNOK_only(sv); /* validate number */ | |
1694 | SvTAINT(sv); | |
79072805 LW |
1695 | } |
1696 | ||
645c22ef | 1697 | /* |
bd81e77b | 1698 | =for apidoc sv_setnv_mg |
645c22ef | 1699 | |
bd81e77b | 1700 | Like C<sv_setnv>, but also handles 'set' magic. |
645c22ef DM |
1701 | |
1702 | =cut | |
1703 | */ | |
1704 | ||
bd81e77b | 1705 | void |
5aaab254 | 1706 | Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) |
79072805 | 1707 | { |
7918f24d NC |
1708 | PERL_ARGS_ASSERT_SV_SETNV_MG; |
1709 | ||
bd81e77b NC |
1710 | sv_setnv(sv,num); |
1711 | SvSETMAGIC(sv); | |
79072805 LW |
1712 | } |
1713 | ||
8140a7a8 TC |
1714 | /* Return a cleaned-up, printable version of sv, for non-numeric, or |
1715 | * not incrementable warning display. | |
1716 | * Originally part of S_not_a_number(). | |
1717 | * The return value may be != tmpbuf. | |
bd81e77b | 1718 | */ |
954c1994 | 1719 | |
8140a7a8 TC |
1720 | STATIC const char * |
1721 | S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { | |
1722 | const char *pv; | |
94463019 | 1723 | |
8140a7a8 | 1724 | PERL_ARGS_ASSERT_SV_DISPLAY; |
7918f24d | 1725 | |
94463019 | 1726 | if (DO_UTF8(sv)) { |
8140a7a8 | 1727 | SV *dsv = newSVpvs_flags("", SVs_TEMP); |
472394e4 | 1728 | pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT); |
94463019 JH |
1729 | } else { |
1730 | char *d = tmpbuf; | |
8140a7a8 | 1731 | const char * const limit = tmpbuf + tmpbuf_size - 8; |
94463019 JH |
1732 | /* each *s can expand to 4 chars + "...\0", |
1733 | i.e. need room for 8 chars */ | |
ecdeb87c | 1734 | |
00b6aa41 AL |
1735 | const char *s = SvPVX_const(sv); |
1736 | const char * const end = s + SvCUR(sv); | |
1737 | for ( ; s < end && d < limit; s++ ) { | |
94463019 | 1738 | int ch = *s & 0xFF; |
bd27cf70 | 1739 | if (! isASCII(ch) && !isPRINT_LC(ch)) { |
94463019 JH |
1740 | *d++ = 'M'; |
1741 | *d++ = '-'; | |
bd27cf70 KW |
1742 | |
1743 | /* Map to ASCII "equivalent" of Latin1 */ | |
1744 | ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); | |
94463019 JH |
1745 | } |
1746 | if (ch == '\n') { | |
1747 | *d++ = '\\'; | |
1748 | *d++ = 'n'; | |
1749 | } | |
1750 | else if (ch == '\r') { | |
1751 | *d++ = '\\'; | |
1752 | *d++ = 'r'; | |
1753 | } | |
1754 | else if (ch == '\f') { | |
1755 | *d++ = '\\'; | |
1756 | *d++ = 'f'; | |
1757 | } | |
1758 | else if (ch == '\\') { | |
1759 | *d++ = '\\'; | |
1760 | *d++ = '\\'; | |
1761 | } | |
1762 | else if (ch == '\0') { | |
1763 | *d++ = '\\'; | |
1764 | *d++ = '0'; | |
1765 | } | |
1766 | else if (isPRINT_LC(ch)) | |
1767 | *d++ = ch; | |
1768 | else { | |
1769 | *d++ = '^'; | |
1770 | *d++ = toCTRL(ch); | |
1771 | } | |
1772 | } | |
1773 | if (s < end) { | |
1774 | *d++ = '.'; | |
1775 | *d++ = '.'; | |
1776 | *d++ = '.'; | |
1777 | } | |
1778 | *d = '\0'; | |
1779 | pv = tmpbuf; | |
a0d0e21e | 1780 | } |
a0d0e21e | 1781 | |
8140a7a8 TC |
1782 | return pv; |
1783 | } | |
1784 | ||
1785 | /* Print an "isn't numeric" warning, using a cleaned-up, | |
1786 | * printable version of the offending string | |
1787 | */ | |
1788 | ||
1789 | STATIC void | |
1790 | S_not_a_number(pTHX_ SV *const sv) | |
1791 | { | |
1792 | dVAR; | |
1793 | char tmpbuf[64]; | |
1794 | const char *pv; | |
1795 | ||
1796 | PERL_ARGS_ASSERT_NOT_A_NUMBER; | |
1797 | ||
1798 | pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); | |
1799 | ||
533c011a | 1800 | if (PL_op) |
9014280d | 1801 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
734856a2 | 1802 | /* diag_listed_as: Argument "%s" isn't numeric%s */ |
94463019 JH |
1803 | "Argument \"%s\" isn't numeric in %s", pv, |
1804 | OP_DESC(PL_op)); | |
a0d0e21e | 1805 | else |
9014280d | 1806 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
734856a2 | 1807 | /* diag_listed_as: Argument "%s" isn't numeric%s */ |
94463019 | 1808 | "Argument \"%s\" isn't numeric", pv); |
a0d0e21e LW |
1809 | } |
1810 | ||
8140a7a8 TC |
1811 | STATIC void |
1812 | S_not_incrementable(pTHX_ SV *const sv) { | |
1813 | dVAR; | |
1814 | char tmpbuf[64]; | |
1815 | const char *pv; | |
1816 | ||
1817 | PERL_ARGS_ASSERT_NOT_INCREMENTABLE; | |
1818 | ||
1819 | pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); | |
1820 | ||
1821 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), | |
1822 | "Argument \"%s\" treated as 0 in increment (++)", pv); | |
1823 | } | |
1824 | ||
c2988b20 NC |
1825 | /* |
1826 | =for apidoc looks_like_number | |
1827 | ||
645c22ef DM |
1828 | Test if the content of an SV looks like a number (or is a number). |
1829 | C<Inf> and C<Infinity> are treated as numbers (so will not issue a | |
f52e41ad FC |
1830 | non-numeric warning), even if your atof() doesn't grok them. Get-magic is |
1831 | ignored. | |
c2988b20 NC |
1832 | |
1833 | =cut | |
1834 | */ | |
1835 | ||
1836 | I32 | |
aad570aa | 1837 | Perl_looks_like_number(pTHX_ SV *const sv) |
c2988b20 | 1838 | { |
eb578fdb | 1839 | const char *sbegin; |
c2988b20 NC |
1840 | STRLEN len; |
1841 | ||
7918f24d NC |
1842 | PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; |
1843 | ||
f52e41ad FC |
1844 | if (SvPOK(sv) || SvPOKp(sv)) { |
1845 | sbegin = SvPV_nomg_const(sv, len); | |
c2988b20 | 1846 | } |
c2988b20 | 1847 | else |
e0ab1c0e | 1848 | return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); |
c2988b20 NC |
1849 | return grok_number(sbegin, len, NULL); |
1850 | } | |
25da4f38 | 1851 | |
19f6321d NC |
1852 | STATIC bool |
1853 | S_glob_2number(pTHX_ GV * const gv) | |
180488f8 | 1854 | { |
7918f24d NC |
1855 | PERL_ARGS_ASSERT_GLOB_2NUMBER; |
1856 | ||
675c862f AL |
1857 | /* We know that all GVs stringify to something that is not-a-number, |
1858 | so no need to test that. */ | |
1859 | if (ckWARN(WARN_NUMERIC)) | |
8e629ff4 FC |
1860 | { |
1861 | SV *const buffer = sv_newmortal(); | |
1862 | gv_efullname3(buffer, gv, "*"); | |
675c862f | 1863 | not_a_number(buffer); |
8e629ff4 | 1864 | } |
675c862f AL |
1865 | /* We just want something true to return, so that S_sv_2iuv_common |
1866 | can tail call us and return true. */ | |
19f6321d | 1867 | return TRUE; |
675c862f AL |
1868 | } |
1869 | ||
25da4f38 IZ |
1870 | /* Actually, ISO C leaves conversion of UV to IV undefined, but |
1871 | until proven guilty, assume that things are not that bad... */ | |
1872 | ||
645c22ef DM |
1873 | /* |
1874 | NV_PRESERVES_UV: | |
1875 | ||
1876 | As 64 bit platforms often have an NV that doesn't preserve all bits of | |
28e5dec8 JH |
1877 | an IV (an assumption perl has been based on to date) it becomes necessary |
1878 | to remove the assumption that the NV always carries enough precision to | |
1879 | recreate the IV whenever needed, and that the NV is the canonical form. | |
1880 | Instead, IV/UV and NV need to be given equal rights. So as to not lose | |
645c22ef | 1881 | precision as a side effect of conversion (which would lead to insanity |
28e5dec8 JH |
1882 | and the dragon(s) in t/op/numconvert.t getting very angry) the intent is |
1883 | 1) to distinguish between IV/UV/NV slots that have cached a valid | |
1884 | conversion where precision was lost and IV/UV/NV slots that have a | |
1885 | valid conversion which has lost no precision | |
645c22ef | 1886 | 2) to ensure that if a numeric conversion to one form is requested that |
28e5dec8 JH |
1887 | would lose precision, the precise conversion (or differently |
1888 | imprecise conversion) is also performed and cached, to prevent | |
1889 | requests for different numeric formats on the same SV causing | |
1890 | lossy conversion chains. (lossless conversion chains are perfectly | |
1891 | acceptable (still)) | |
1892 | ||
1893 | ||
1894 | flags are used: | |
1895 | SvIOKp is true if the IV slot contains a valid value | |
1896 | SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) | |
1897 | SvNOKp is true if the NV slot contains a valid value | |
1898 | SvNOK is true only if the NV value is accurate | |
1899 | ||
1900 | so | |
645c22ef | 1901 | while converting from PV to NV, check to see if converting that NV to an |
28e5dec8 JH |
1902 | IV(or UV) would lose accuracy over a direct conversion from PV to |
1903 | IV(or UV). If it would, cache both conversions, return NV, but mark | |
1904 | SV as IOK NOKp (ie not NOK). | |
1905 | ||
645c22ef | 1906 | While converting from PV to IV, check to see if converting that IV to an |
28e5dec8 JH |
1907 | NV would lose accuracy over a direct conversion from PV to NV. If it |
1908 | would, cache both conversions, flag similarly. | |
1909 | ||
1910 | Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite | |
1911 | correctly because if IV & NV were set NV *always* overruled. | |
645c22ef DM |
1912 | Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning |
1913 | changes - now IV and NV together means that the two are interchangeable: | |
28e5dec8 | 1914 | SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; |
d460ef45 | 1915 | |
645c22ef DM |
1916 | The benefit of this is that operations such as pp_add know that if |
1917 | SvIOK is true for both left and right operands, then integer addition | |
1918 | can be used instead of floating point (for cases where the result won't | |
1919 | overflow). Before, floating point was always used, which could lead to | |
28e5dec8 JH |
1920 | loss of precision compared with integer addition. |
1921 | ||
1922 | * making IV and NV equal status should make maths accurate on 64 bit | |
1923 | platforms | |
1924 | * may speed up maths somewhat if pp_add and friends start to use | |
645c22ef | 1925 | integers when possible instead of fp. (Hopefully the overhead in |
28e5dec8 JH |
1926 | looking for SvIOK and checking for overflow will not outweigh the |
1927 | fp to integer speedup) | |
1928 | * will slow down integer operations (callers of SvIV) on "inaccurate" | |
1929 | values, as the change from SvIOK to SvIOKp will cause a call into | |
1930 | sv_2iv each time rather than a macro access direct to the IV slot | |
1931 | * should speed up number->string conversion on integers as IV is | |
645c22ef | 1932 | favoured when IV and NV are equally accurate |
28e5dec8 JH |
1933 | |
1934 | #################################################################### | |
645c22ef DM |
1935 | You had better be using SvIOK_notUV if you want an IV for arithmetic: |
1936 | SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. | |
1937 | On the other hand, SvUOK is true iff UV. | |
28e5dec8 JH |
1938 | #################################################################### |
1939 | ||
645c22ef | 1940 | Your mileage will vary depending your CPU's relative fp to integer |
28e5dec8 JH |
1941 | performance ratio. |
1942 | */ | |
1943 | ||
1944 | #ifndef NV_PRESERVES_UV | |
645c22ef DM |
1945 | # define IS_NUMBER_UNDERFLOW_IV 1 |
1946 | # define IS_NUMBER_UNDERFLOW_UV 2 | |
1947 | # define IS_NUMBER_IV_AND_UV 2 | |
1948 | # define IS_NUMBER_OVERFLOW_IV 4 | |
1949 | # define IS_NUMBER_OVERFLOW_UV 5 | |
1950 | ||
1951 | /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ | |
28e5dec8 JH |
1952 | |
1953 | /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ | |
1954 | STATIC int | |
5aaab254 | 1955 | S_sv_2iuv_non_preserve(pTHX_ SV *const sv |
47031da6 NC |
1956 | # ifdef DEBUGGING |
1957 | , I32 numtype | |
1958 | # endif | |
1959 | ) | |
28e5dec8 | 1960 | { |
97aff369 | 1961 | dVAR; |
7918f24d NC |
1962 | |
1963 | PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; | |
1964 | ||
3f7c398e | 1965 | DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); |
28e5dec8 JH |
1966 | if (SvNVX(sv) < (NV)IV_MIN) { |
1967 | (void)SvIOKp_on(sv); | |
1968 | (void)SvNOK_on(sv); | |
45977657 | 1969 | SvIV_set(sv, IV_MIN); |
28e5dec8 JH |
1970 | return IS_NUMBER_UNDERFLOW_IV; |
1971 | } | |
1972 | if (SvNVX(sv) > (NV)UV_MAX) { | |
1973 | (void)SvIOKp_on(sv); | |
1974 | (void)SvNOK_on(sv); | |
1975 | SvIsUV_on(sv); | |
607fa7f2 | 1976 | SvUV_set(sv, UV_MAX); |
28e5dec8 JH |
1977 | return IS_NUMBER_OVERFLOW_UV; |
1978 | } | |
c2988b20 NC |
1979 | (void)SvIOKp_on(sv); |
1980 | (void)SvNOK_on(sv); | |
1981 | /* Can't use strtol etc to convert this string. (See truth table in | |
1982 | sv_2iv */ | |
1983 | if (SvNVX(sv) <= (UV)IV_MAX) { | |
45977657 | 1984 | SvIV_set(sv, I_V(SvNVX(sv))); |
c2988b20 NC |
1985 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) { |
1986 | SvIOK_on(sv); /* Integer is precise. NOK, IOK */ | |
1987 | } else { | |
1988 | /* Integer is imprecise. NOK, IOKp */ | |
1989 | } | |
1990 | return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; | |
1991 | } | |
1992 | SvIsUV_on(sv); | |
607fa7f2 | 1993 | SvUV_set(sv, U_V(SvNVX(sv))); |
c2988b20 NC |
1994 | if ((NV)(SvUVX(sv)) == SvNVX(sv)) { |
1995 | if (SvUVX(sv) == UV_MAX) { | |
1996 | /* As we know that NVs don't preserve UVs, UV_MAX cannot | |
1997 | possibly be preserved by NV. Hence, it must be overflow. | |
1998 | NOK, IOKp */ | |
1999 | return IS_NUMBER_OVERFLOW_UV; | |
2000 | } | |
2001 | SvIOK_on(sv); /* Integer is precise. NOK, UOK */ | |
2002 | } else { | |
2003 | /* Integer is imprecise. NOK, IOKp */ | |
28e5dec8 | 2004 | } |
c2988b20 | 2005 | return IS_NUMBER_OVERFLOW_IV; |
28e5dec8 | 2006 | } |
645c22ef DM |
2007 | #endif /* !NV_PRESERVES_UV*/ |
2008 | ||
af359546 | 2009 | STATIC bool |
7918f24d NC |
2010 | S_sv_2iuv_common(pTHX_ SV *const sv) |
2011 | { | |
97aff369 | 2012 | dVAR; |
7918f24d NC |
2013 | |
2014 | PERL_ARGS_ASSERT_SV_2IUV_COMMON; | |
2015 | ||
af359546 | 2016 | if (SvNOKp(sv)) { |
28e5dec8 JH |
2017 | /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv |
2018 | * without also getting a cached IV/UV from it at the same time | |
2019 | * (ie PV->NV conversion should detect loss of accuracy and cache | |
af359546 NC |
2020 | * IV or UV at same time to avoid this. */ |
2021 | /* IV-over-UV optimisation - choose to cache IV if possible */ | |
25da4f38 IZ |
2022 | |
2023 | if (SvTYPE(sv) == SVt_NV) | |
2024 | sv_upgrade(sv, SVt_PVNV); | |
2025 | ||
28e5dec8 JH |
2026 | (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ |
2027 | /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost | |
2028 | certainly cast into the IV range at IV_MAX, whereas the correct | |
2029 | answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary | |
2030 | cases go to UV */ | |
cab190d4 JD |
2031 | #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) |
2032 | if (Perl_isnan(SvNVX(sv))) { | |
2033 | SvUV_set(sv, 0); | |
2034 | SvIsUV_on(sv); | |
fdbe6d7c | 2035 | return FALSE; |
cab190d4 | 2036 | } |
cab190d4 | 2037 | #endif |
28e5dec8 | 2038 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
45977657 | 2039 | SvIV_set(sv, I_V(SvNVX(sv))); |
28e5dec8 JH |
2040 | if (SvNVX(sv) == (NV) SvIVX(sv) |
2041 | #ifndef NV_PRESERVES_UV | |
2042 | && (((UV)1 << NV_PRESERVES_UV_BITS) > | |
2043 | (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) | |
2044 | /* Don't flag it as "accurately an integer" if the number | |
2045 | came from a (by definition imprecise) NV operation, and | |
2046 | we're outside the range of NV integer precision */ | |
2047 | #endif | |
2048 | ) { | |
a43d94f2 NC |
2049 | if (SvNOK(sv)) |
2050 | SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ | |
2051 | else { | |
2052 | /* scalar has trailing garbage, eg "42a" */ | |
2053 | } | |
28e5dec8 | 2054 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
7234c960 | 2055 | "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", |
28e5dec8 JH |
2056 | PTR2UV(sv), |
2057 | SvNVX(sv), | |
2058 | SvIVX(sv))); | |
2059 | ||
2060 | } else { | |
2061 | /* IV not precise. No need to convert from PV, as NV | |
2062 | conversion would already have cached IV if it detected | |
2063 | that PV->IV would be better than PV->NV->IV | |
2064 | flags already correct - don't set public IOK. */ | |
2065 | DEBUG_c(PerlIO_printf(Perl_debug_log, | |
7234c960 | 2066 | "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", |
28e5dec8 JH |
2067 | PTR2UV(sv), |
2068 | SvNVX(sv), | |
2069 | SvIVX(sv))); | |
2070 | } | |
2071 | /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, | |
2072 | but the cast (NV)IV_MIN rounds to a the value less (more | |
2073 | negative) than IV_MIN which happens to be equal to SvNVX ?? | |
2074 | Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and | |
2075 | NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and | |
2076 | (NV)UVX == NVX are both true, but the values differ. :-( | |
2077 | Hopefully for 2s complement IV_MIN is something like | |
2078 | 0x8000000000000000 which will be exact. NWC */ | |
d460ef45 | 2079 | } |
25da4f38 | 2080 | else { |
607fa7f2 | 2081 | SvUV_set(sv, U_V(SvNVX(sv))); |
28e5dec8 JH |
2082 | if ( |
2083 | (SvNVX(sv) == (NV) SvUVX(sv)) | |
2084 | #ifndef NV_PRESERVES_UV | |
2085 | /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ | |
2086 | /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ | |
2087 | && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) | |
2088 | /* Don't flag it as "accurately an integer" if the number | |
2089 | came from a (by definition imprecise) NV operation, and | |
2090 | we're outside the range of NV integer precision */ | |
2091 | #endif | |
a43d94f2 | 2092 | && SvNOK(sv) |
28e5dec8 JH |
2093 | ) |
2094 | SvIOK_on(sv); | |
25da4f38 | 2095 | SvIsUV_on(sv); |
1c846c1f | 2096 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
57def98f | 2097 | "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", |
56431972 | 2098 | PTR2UV(sv), |
57def98f JH |
2099 | SvUVX(sv), |
2100 | SvUVX(sv))); | |
25da4f38 | 2101 | } |
748a9306 | 2102 | } |
cd84013a | 2103 | else if (SvPOKp(sv)) { |
c2988b20 | 2104 | UV value; |
504618e9 | 2105 | const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
af359546 | 2106 | /* We want to avoid a possible problem when we cache an IV/ a UV which |
25da4f38 | 2107 | may be later translated to an NV, and the resulting NV is not |
c2988b20 NC |
2108 | the same as the direct translation of the initial string |
2109 | (eg 123.456 can shortcut to the IV 123 with atol(), but we must | |
2110 | be careful to ensure that the value with the .456 is around if the | |
2111 | NV value is requested in the future). | |
1c846c1f | 2112 | |
af359546 | 2113 | This means that if we cache such an IV/a UV, we need to cache the |
25da4f38 | 2114 | NV as well. Moreover, we trade speed for space, and do not |
28e5dec8 | 2115 | cache the NV if we are sure it's not needed. |
25da4f38 | 2116 | */ |
16b7a9a4 | 2117 | |
c2988b20 NC |
2118 | /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ |
2119 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2120 | == IS_NUMBER_IN_UV) { | |
5e045b90 | 2121 | /* It's definitely an integer, only upgrade to PVIV */ |
28e5dec8 JH |
2122 | if (SvTYPE(sv) < SVt_PVIV) |
2123 | sv_upgrade(sv, SVt_PVIV); | |
f7bbb42a | 2124 | (void)SvIOK_on(sv); |
c2988b20 NC |
2125 | } else if (SvTYPE(sv) < SVt_PVNV) |
2126 | sv_upgrade(sv, SVt_PVNV); | |
28e5dec8 | 2127 | |
f2524eef | 2128 | /* If NVs preserve UVs then we only use the UV value if we know that |
c2988b20 NC |
2129 | we aren't going to call atof() below. If NVs don't preserve UVs |
2130 | then the value returned may have more precision than atof() will | |
2131 | return, even though value isn't perfectly accurate. */ | |
2132 | if ((numtype & (IS_NUMBER_IN_UV | |
2133 | #ifdef NV_PRESERVES_UV | |
2134 | | IS_NUMBER_NOT_INT | |
2135 | #endif | |
2136 | )) == IS_NUMBER_IN_UV) { | |
2137 | /* This won't turn off the public IOK flag if it was set above */ | |
2138 | (void)SvIOKp_on(sv); | |
2139 | ||
2140 | if (!(numtype & IS_NUMBER_NEG)) { | |
2141 | /* positive */; | |
2142 | if (value <= (UV)IV_MAX) { | |
45977657 | 2143 | SvIV_set(sv, (IV)value); |
c2988b20 | 2144 | } else { |
af359546 | 2145 | /* it didn't overflow, and it was positive. */ |
607fa7f2 | 2146 | SvUV_set(sv, value); |
c2988b20 NC |
2147 | SvIsUV_on(sv); |
2148 | } | |
2149 | } else { | |
2150 | /* 2s complement assumption */ | |
2151 | if (value <= (UV)IV_MIN) { | |
45977657 | 2152 | SvIV_set(sv, -(IV)value); |
c2988b20 NC |
2153 | } else { |
2154 | /* Too negative for an IV. This is a double upgrade, but | |
d1be9408 | 2155 | I'm assuming it will be rare. */ |
c2988b20 NC |
2156 | if (SvTYPE(sv) < SVt_PVNV) |
2157 | sv_upgrade(sv, SVt_PVNV); | |
2158 | SvNOK_on(sv); | |
2159 | SvIOK_off(sv); | |
2160 | SvIOKp_on(sv); | |
9d6ce603 | 2161 | SvNV_set(sv, -(NV)value); |
45977657 | 2162 | SvIV_set(sv, IV_MIN); |
c2988b20 NC |
2163 | } |
2164 | } | |
2165 | } | |
2166 | /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we | |
2167 | will be in the previous block to set the IV slot, and the next | |
2168 | block to set the NV slot. So no else here. */ | |
2169 | ||
2170 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2171 | != IS_NUMBER_IN_UV) { | |
2172 | /* It wasn't an (integer that doesn't overflow the UV). */ | |
3f7c398e | 2173 | SvNV_set(sv, Atof(SvPVX_const(sv))); |
28e5dec8 | 2174 | |
c2988b20 NC |
2175 | if (! numtype && ckWARN(WARN_NUMERIC)) |
2176 | not_a_number(sv); | |
28e5dec8 | 2177 | |
65202027 | 2178 | #if defined(USE_LONG_DOUBLE) |
c2988b20 NC |
2179 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", |
2180 | PTR2UV(sv), SvNVX(sv))); | |
65202027 | 2181 | #else |
1779d84d | 2182 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", |
c2988b20 | 2183 | PTR2UV(sv), SvNVX(sv))); |
65202027 | 2184 | #endif |
28e5dec8 | 2185 | |
28e5dec8 | 2186 | #ifdef NV_PRESERVES_UV |
af359546 NC |
2187 | (void)SvIOKp_on(sv); |
2188 | (void)SvNOK_on(sv); | |
2189 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { | |
2190 | SvIV_set(sv, I_V(SvNVX(sv))); | |
2191 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) { | |
2192 | SvIOK_on(sv); | |
2193 | } else { | |
6f207bd3 | 2194 | NOOP; /* Integer is imprecise. NOK, IOKp */ |
af359546 NC |
2195 | } |
2196 | /* UV will not work better than IV */ | |
2197 | } else { | |
2198 | if (SvNVX(sv) > (NV)UV_MAX) { | |
2199 | SvIsUV_on(sv); | |
2200 | /* Integer is inaccurate. NOK, IOKp, is UV */ | |
2201 | SvUV_set(sv, UV_MAX); | |
af359546 NC |
2202 | } else { |
2203 | SvUV_set(sv, U_V(SvNVX(sv))); | |
2204 | /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs | |
2205 | NV preservse UV so can do correct comparison. */ | |
2206 | if ((NV)(SvUVX(sv)) == SvNVX(sv)) { | |
2207 | SvIOK_on(sv); | |
af359546 | 2208 | } else { |
6f207bd3 | 2209 | NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ |
af359546 NC |
2210 | } |
2211 | } | |
4b0c9573 | 2212 | SvIsUV_on(sv); |
af359546 | 2213 | } |
28e5dec8 | 2214 | #else /* NV_PRESERVES_UV */ |
c2988b20 NC |
2215 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2216 | == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { | |
af359546 | 2217 | /* The IV/UV slot will have been set from value returned by |
c2988b20 NC |
2218 | grok_number above. The NV slot has just been set using |
2219 | Atof. */ | |
560b0c46 | 2220 | SvNOK_on(sv); |
c2988b20 NC |
2221 | assert (SvIOKp(sv)); |
2222 | } else { | |
2223 | if (((UV)1 << NV_PRESERVES_UV_BITS) > | |
2224 | U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { | |
2225 | /* Small enough to preserve all bits. */ | |
2226 | (void)SvIOKp_on(sv); | |
2227 | SvNOK_on(sv); | |
45977657 | 2228 | SvIV_set(sv, I_V(SvNVX(sv))); |
c2988b20 NC |
2229 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) |
2230 | SvIOK_on(sv); | |
2231 | /* Assumption: first non-preserved integer is < IV_MAX, | |
2232 | this NV is in the preserved range, therefore: */ | |
2233 | if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) | |
2234 | < (UV)IV_MAX)) { | |
32fdb065 | 2235 | Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); |
c2988b20 NC |
2236 | } |
2237 | } else { | |
2238 | /* IN_UV NOT_INT | |
2239 | 0 0 already failed to read UV. | |
2240 | 0 1 already failed to read UV. | |
2241 | 1 0 you won't get here in this case. IV/UV | |
2242 | slot set, public IOK, Atof() unneeded. | |
2243 | 1 1 already read UV. | |
2244 | so there's no point in sv_2iuv_non_preserve() attempting | |
2245 | to use atol, strtol, strtoul etc. */ | |
47031da6 | 2246 | # ifdef DEBUGGING |
40a17c4c | 2247 | sv_2iuv_non_preserve (sv, numtype); |
47031da6 NC |
2248 | # else |
2249 | sv_2iuv_non_preserve (sv); | |
2250 | # endif | |
c2988b20 NC |
2251 | } |
2252 | } | |
28e5dec8 | 2253 | #endif /* NV_PRESERVES_UV */ |
a43d94f2 NC |
2254 | /* It might be more code efficient to go through the entire logic above |
2255 | and conditionally set with SvIOKp_on() rather than SvIOK(), but it | |
2256 | gets complex and potentially buggy, so more programmer efficient | |
2257 | to do it this way, by turning off the public flags: */ | |
2258 | if (!numtype) | |
2259 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); | |
25da4f38 | 2260 | } |
af359546 NC |
2261 | } |
2262 | else { | |
675c862f | 2263 | if (isGV_with_GP(sv)) |
159b6efe | 2264 | return glob_2number(MUTABLE_GV(sv)); |
180488f8 | 2265 | |
4f62cd62 | 2266 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
af359546 | 2267 | report_uninit(sv); |
25da4f38 IZ |
2268 | if (SvTYPE(sv) < SVt_IV) |
2269 | /* Typically the caller expects that sv_any is not NULL now. */ | |
2270 | sv_upgrade(sv, SVt_IV); | |
af359546 NC |
2271 | /* Return 0 from the caller. */ |
2272 | return TRUE; | |
2273 | } | |
2274 | return FALSE; | |
2275 | } | |
2276 | ||
2277 | /* | |
2278 | =for apidoc sv_2iv_flags | |
2279 | ||
2280 | Return the integer value of an SV, doing any necessary string | |
2281 | conversion. If flags includes SV_GMAGIC, does an mg_get() first. | |
2282 | Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. | |
2283 | ||
2284 | =cut | |
2285 | */ | |
2286 | ||
2287 | IV | |
5aaab254 | 2288 | Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) |
af359546 | 2289 | { |
97aff369 | 2290 | dVAR; |
4bac9ae4 | 2291 | |
af359546 | 2292 | if (!sv) |
a0d0e21e | 2293 | return 0; |
4bac9ae4 | 2294 | |
217f6fa3 FC |
2295 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2296 | && SvTYPE(sv) != SVt_PVFM); | |
2297 | ||
4bac9ae4 CS |
2298 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
2299 | mg_get(sv); | |
2300 | ||
2301 | if (SvROK(sv)) { | |
2302 | if (SvAMAGIC(sv)) { | |
2303 | SV * tmpstr; | |
2304 | if (flags & SV_SKIP_OVERLOAD) | |
2305 | return 0; | |
2306 | tmpstr = AMG_CALLunary(sv, numer_amg); | |
2307 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2308 | return SvIV(tmpstr); | |
2309 | } | |
2310 | } | |
2311 | return PTR2IV(SvRV(sv)); | |
2312 | } | |
2313 | ||
8d919b0a | 2314 | if (SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d NC |
2315 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
2316 | the same flag bit as SVf_IVisUV, so must not let them cache IVs. | |
2317 | In practice they are extremely unlikely to actually get anywhere | |
2318 | accessible by user Perl code - the only way that I'm aware of is when | |
2319 | a constant subroutine which is used as the second argument to index. | |
cd84013a FC |
2320 | |
2321 | Regexps have no SvIVX and SvNVX fields. | |
2b2b6d6d | 2322 | */ |
8d919b0a | 2323 | assert(isREGEXP(sv) || SvPOKp(sv)); |
e20b6c3b | 2324 | { |
71c558c3 | 2325 | UV value; |
8d919b0a FC |
2326 | const char * const ptr = |
2327 | isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); | |
71c558c3 | 2328 | const int numtype |
8d919b0a | 2329 | = grok_number(ptr, SvCUR(sv), &value); |
71c558c3 NC |
2330 | |
2331 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2332 | == IS_NUMBER_IN_UV) { | |
2333 | /* It's definitely an integer */ | |
2334 | if (numtype & IS_NUMBER_NEG) { | |
2335 | if (value < (UV)IV_MIN) | |
2336 | return -(IV)value; | |
2337 | } else { | |
2338 | if (value < (UV)IV_MAX) | |
2339 | return (IV)value; | |
2340 | } | |
2341 | } | |
2342 | if (!numtype) { | |
2343 | if (ckWARN(WARN_NUMERIC)) | |
2344 | not_a_number(sv); | |
2345 | } | |
8d919b0a | 2346 | return I_V(Atof(ptr)); |
e20b6c3b | 2347 | } |
4bac9ae4 CS |
2348 | } |
2349 | ||
2350 | if (SvTHINKFIRST(sv)) { | |
73381561 | 2351 | #ifdef PERL_OLD_COPY_ON_WRITE |
af359546 NC |
2352 | if (SvIsCOW(sv)) { |
2353 | sv_force_normal_flags(sv, 0); | |
2354 | } | |
73381561 | 2355 | #endif |
af359546 NC |
2356 | if (SvREADONLY(sv) && !SvOK(sv)) { |
2357 | if (ckWARN(WARN_UNINITIALIZED)) | |
2358 | report_uninit(sv); | |
2359 | return 0; | |
2360 | } | |
2361 | } | |
4bac9ae4 | 2362 | |
af359546 NC |
2363 | if (!SvIOKp(sv)) { |
2364 | if (S_sv_2iuv_common(aTHX_ sv)) | |
2365 | return 0; | |
79072805 | 2366 | } |
4bac9ae4 | 2367 | |
1d7c1841 GS |
2368 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", |
2369 | PTR2UV(sv),SvIVX(sv))); | |
25da4f38 | 2370 | return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); |
79072805 LW |
2371 | } |
2372 | ||
645c22ef | 2373 | /* |
891f9566 | 2374 | =for apidoc sv_2uv_flags |
645c22ef DM |
2375 | |
2376 | Return the unsigned integer value of an SV, doing any necessary string | |
891f9566 YST |
2377 | conversion. If flags includes SV_GMAGIC, does an mg_get() first. |
2378 | Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros. | |
645c22ef DM |
2379 | |
2380 | =cut | |
2381 | */ | |
2382 | ||
ff68c719 | 2383 | UV |
5aaab254 | 2384 | Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) |
ff68c719 | 2385 | { |
97aff369 | 2386 | dVAR; |
4bac9ae4 | 2387 | |
ff68c719 | 2388 | if (!sv) |
2389 | return 0; | |
4bac9ae4 CS |
2390 | |
2391 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) | |
2392 | mg_get(sv); | |
2393 | ||
2394 | if (SvROK(sv)) { | |
2395 | if (SvAMAGIC(sv)) { | |
2396 | SV *tmpstr; | |
2397 | if (flags & SV_SKIP_OVERLOAD) | |
2398 | return 0; | |
2399 | tmpstr = AMG_CALLunary(sv, numer_amg); | |
2400 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2401 | return SvUV(tmpstr); | |
2402 | } | |
2403 | } | |
2404 | return PTR2UV(SvRV(sv)); | |
2405 | } | |
2406 | ||
8d919b0a | 2407 | if (SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d | 2408 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
cd84013a FC |
2409 | the same flag bit as SVf_IVisUV, so must not let them cache IVs. |
2410 | Regexps have no SvIVX and SvNVX fields. */ | |
8d919b0a | 2411 | assert(isREGEXP(sv) || SvPOKp(sv)); |
e20b6c3b | 2412 | { |
71c558c3 | 2413 | UV value; |
8d919b0a FC |
2414 | const char * const ptr = |
2415 | isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); | |
71c558c3 | 2416 | const int numtype |
8d919b0a | 2417 | = grok_number(ptr, SvCUR(sv), &value); |
71c558c3 NC |
2418 | |
2419 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2420 | == IS_NUMBER_IN_UV) { | |
2421 | /* It's definitely an integer */ | |
2422 | if (!(numtype & IS_NUMBER_NEG)) | |
2423 | return value; | |
2424 | } | |
2425 | if (!numtype) { | |
2426 | if (ckWARN(WARN_NUMERIC)) | |
2427 | not_a_number(sv); | |
2428 | } | |
8d919b0a | 2429 | return U_V(Atof(ptr)); |
e20b6c3b | 2430 | } |
4bac9ae4 CS |
2431 | } |
2432 | ||
2433 | if (SvTHINKFIRST(sv)) { | |
73381561 | 2434 | #ifdef PERL_OLD_COPY_ON_WRITE |
765f542d NC |
2435 | if (SvIsCOW(sv)) { |
2436 | sv_force_normal_flags(sv, 0); | |
8a818333 | 2437 | } |
73381561 | 2438 | #endif |
0336b60e | 2439 | if (SvREADONLY(sv) && !SvOK(sv)) { |
0336b60e | 2440 | if (ckWARN(WARN_UNINITIALIZED)) |
29489e7c | 2441 | report_uninit(sv); |
ff68c719 | 2442 | return 0; |
2443 | } | |
2444 | } | |
4bac9ae4 | 2445 | |
af359546 NC |
2446 | if (!SvIOKp(sv)) { |
2447 | if (S_sv_2iuv_common(aTHX_ sv)) | |
2448 | return 0; | |
ff68c719 | 2449 | } |
25da4f38 | 2450 | |
1d7c1841 GS |
2451 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", |
2452 | PTR2UV(sv),SvUVX(sv))); | |
25da4f38 | 2453 | return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); |
ff68c719 | 2454 | } |
2455 | ||
645c22ef | 2456 | /* |
196007d1 | 2457 | =for apidoc sv_2nv_flags |
645c22ef DM |
2458 | |
2459 | Return the num value of an SV, doing any necessary string or integer | |
fde67290 | 2460 | conversion. If flags includes SV_GMAGIC, does an mg_get() first. |
39d5de13 | 2461 | Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros. |
645c22ef DM |
2462 | |
2463 | =cut | |
2464 | */ | |
2465 | ||
65202027 | 2466 | NV |
5aaab254 | 2467 | Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) |
79072805 | 2468 | { |
97aff369 | 2469 | dVAR; |
79072805 LW |
2470 | if (!sv) |
2471 | return 0.0; | |
217f6fa3 FC |
2472 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2473 | && SvTYPE(sv) != SVt_PVFM); | |
8d919b0a | 2474 | if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d | 2475 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
cd84013a FC |
2476 | the same flag bit as SVf_IVisUV, so must not let them cache NVs. |
2477 | Regexps have no SvIVX and SvNVX fields. */ | |
8d919b0a | 2478 | const char *ptr; |
39d5de13 DM |
2479 | if (flags & SV_GMAGIC) |
2480 | mg_get(sv); | |
463ee0b2 LW |
2481 | if (SvNOKp(sv)) |
2482 | return SvNVX(sv); | |
cd84013a | 2483 | if (SvPOKp(sv) && !SvIOKp(sv)) { |
8d919b0a FC |
2484 | ptr = SvPVX_const(sv); |
2485 | grokpv: | |
041457d9 | 2486 | if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && |
8d919b0a | 2487 | !grok_number(ptr, SvCUR(sv), NULL)) |
a0d0e21e | 2488 | not_a_number(sv); |
8d919b0a | 2489 | return Atof(ptr); |
a0d0e21e | 2490 | } |
25da4f38 | 2491 | if (SvIOKp(sv)) { |
1c846c1f | 2492 | if (SvIsUV(sv)) |
65202027 | 2493 | return (NV)SvUVX(sv); |
25da4f38 | 2494 | else |
65202027 | 2495 | return (NV)SvIVX(sv); |
47a72cb8 NC |
2496 | } |
2497 | if (SvROK(sv)) { | |
2498 | goto return_rok; | |
2499 | } | |
8d919b0a FC |
2500 | if (isREGEXP(sv)) { |
2501 | ptr = RX_WRAPPED((REGEXP *)sv); | |
2502 | goto grokpv; | |
2503 | } | |
47a72cb8 NC |
2504 | assert(SvTYPE(sv) >= SVt_PVMG); |
2505 | /* This falls through to the report_uninit near the end of the | |
2506 | function. */ | |
2507 | } else if (SvTHINKFIRST(sv)) { | |
a0d0e21e | 2508 | if (SvROK(sv)) { |
47a72cb8 | 2509 | return_rok: |
deb46114 | 2510 | if (SvAMAGIC(sv)) { |
aee036bb DM |
2511 | SV *tmpstr; |
2512 | if (flags & SV_SKIP_OVERLOAD) | |
2513 | return 0; | |
31d632c3 | 2514 | tmpstr = AMG_CALLunary(sv, numer_amg); |
deb46114 NC |
2515 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
2516 | return SvNV(tmpstr); | |
2517 | } | |
2518 | } | |
2519 | return PTR2NV(SvRV(sv)); | |
a0d0e21e | 2520 | } |
73381561 | 2521 | #ifdef PERL_OLD_COPY_ON_WRITE |
765f542d NC |
2522 | if (SvIsCOW(sv)) { |
2523 | sv_force_normal_flags(sv, 0); | |
8a818333 | 2524 | } |
73381561 | 2525 | #endif |
0336b60e | 2526 | if (SvREADONLY(sv) && !SvOK(sv)) { |
599cee73 | 2527 | if (ckWARN(WARN_UNINITIALIZED)) |
29489e7c | 2528 | report_uninit(sv); |
ed6116ce LW |
2529 | return 0.0; |
2530 | } | |
79072805 LW |
2531 | } |
2532 | if (SvTYPE(sv) < SVt_NV) { | |
7e25a7e9 NC |
2533 | /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ |
2534 | sv_upgrade(sv, SVt_NV); | |
906f284f | 2535 | #ifdef USE_LONG_DOUBLE |
097ee67d | 2536 | DEBUG_c({ |
f93f4e46 | 2537 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
1d7c1841 GS |
2538 | PerlIO_printf(Perl_debug_log, |
2539 | "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", | |
2540 | PTR2UV(sv), SvNVX(sv)); | |
572bbb43 GS |
2541 | RESTORE_NUMERIC_LOCAL(); |
2542 | }); | |
65202027 | 2543 | #else |
572bbb43 | 2544 | DEBUG_c({ |
f93f4e46 | 2545 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
1779d84d | 2546 | PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", |
1d7c1841 | 2547 | PTR2UV(sv), SvNVX(sv)); |
097ee67d JH |
2548 | RESTORE_NUMERIC_LOCAL(); |
2549 | }); | |
572bbb43 | 2550 | #endif |
79072805 LW |
2551 | } |
2552 | else if (SvTYPE(sv) < SVt_PVNV) | |
2553 | sv_upgrade(sv, SVt_PVNV); | |
59d8ce62 NC |
2554 | if (SvNOKp(sv)) { |
2555 | return SvNVX(sv); | |
61604483 | 2556 | } |
59d8ce62 | 2557 | if (SvIOKp(sv)) { |
9d6ce603 | 2558 | SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); |
28e5dec8 | 2559 | #ifdef NV_PRESERVES_UV |
a43d94f2 NC |
2560 | if (SvIOK(sv)) |
2561 | SvNOK_on(sv); | |
2562 | else | |
2563 | SvNOKp_on(sv); | |
28e5dec8 JH |
2564 | #else |
2565 | /* Only set the public NV OK flag if this NV preserves the IV */ | |
2566 | /* Check it's not 0xFFFFFFFFFFFFFFFF */ | |
a43d94f2 NC |
2567 | if (SvIOK(sv) && |
2568 | SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) | |
28e5dec8 JH |
2569 | : (SvIVX(sv) == I_V(SvNVX(sv)))) |
2570 | SvNOK_on(sv); | |
2571 | else | |
2572 | SvNOKp_on(sv); | |
2573 | #endif | |
93a17b20 | 2574 | } |
cd84013a | 2575 | else if (SvPOKp(sv)) { |
c2988b20 | 2576 | UV value; |
3f7c398e | 2577 | const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
041457d9 | 2578 | if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) |
a0d0e21e | 2579 | not_a_number(sv); |
28e5dec8 | 2580 | #ifdef NV_PRESERVES_UV |
c2988b20 NC |
2581 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2582 | == IS_NUMBER_IN_UV) { | |
5e045b90 | 2583 | /* It's definitely an integer */ |
9d6ce603 | 2584 | SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); |
c2988b20 | 2585 | } else |
3f7c398e | 2586 | SvNV_set(sv, Atof(SvPVX_const(sv))); |
a43d94f2 NC |
2587 | if (numtype) |
2588 | SvNOK_on(sv); | |
2589 | else | |
2590 | SvNOKp_on(sv); | |
28e5dec8 | 2591 | #else |
3f7c398e | 2592 | SvNV_set(sv, Atof(SvPVX_const(sv))); |
28e5dec8 JH |
2593 | /* Only set the public NV OK flag if this NV preserves the value in |
2594 | the PV at least as well as an IV/UV would. | |
2595 | Not sure how to do this 100% reliably. */ | |
2596 | /* if that shift count is out of range then Configure's test is | |
2597 | wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == | |
2598 | UV_BITS */ | |
2599 | if (((UV)1 << NV_PRESERVES_UV_BITS) > | |
c2988b20 | 2600 | U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { |
28e5dec8 | 2601 | SvNOK_on(sv); /* Definitely small enough to preserve all bits */ |
c2988b20 NC |
2602 | } else if (!(numtype & IS_NUMBER_IN_UV)) { |
2603 | /* Can't use strtol etc to convert this string, so don't try. | |
2604 | sv_2iv and sv_2uv will use the NV to convert, not the PV. */ | |
2605 | SvNOK_on(sv); | |
2606 | } else { | |
2607 | /* value has been set. It may not be precise. */ | |
2608 | if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { | |
2609 | /* 2s complement assumption for (UV)IV_MIN */ | |
2610 | SvNOK_on(sv); /* Integer is too negative. */ | |
2611 | } else { | |
2612 | SvNOKp_on(sv); | |
2613 | SvIOKp_on(sv); | |
6fa402ec | 2614 | |
c2988b20 | 2615 | if (numtype & IS_NUMBER_NEG) { |
45977657 | 2616 | SvIV_set(sv, -(IV)value); |
c2988b20 | 2617 | } else if (value <= (UV)IV_MAX) { |
45977657 | 2618 | SvIV_set(sv, (IV)value); |
c2988b20 | 2619 | } else { |
607fa7f2 | 2620 | SvUV_set(sv, value); |
c2988b20 NC |
2621 | SvIsUV_on(sv); |
2622 | } | |
2623 | ||
2624 | if (numtype & IS_NUMBER_NOT_INT) { | |
2625 | /* I believe that even if the original PV had decimals, | |
2626 | they are lost beyond the limit of the FP precision. | |
2627 | However, neither is canonical, so both only get p | |
2628 | flags. NWC, 2000/11/25 */ | |
2629 | /* Both already have p flags, so do nothing */ | |
2630 | } else { | |
66a1b24b | 2631 | const NV nv = SvNVX(sv); |
c2988b20 NC |
2632 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
2633 | if (SvIVX(sv) == I_V(nv)) { | |
2634 | SvNOK_on(sv); | |
c2988b20 | 2635 | } else { |
c2988b20 NC |
2636 | /* It had no "." so it must be integer. */ |
2637 | } | |
00b6aa41 | 2638 | SvIOK_on(sv); |
c2988b20 NC |
2639 | } else { |
2640 | /* between IV_MAX and NV(UV_MAX). | |
2641 | Could be slightly > UV_MAX */ | |
6fa402ec | 2642 | |
c2988b20 NC |
2643 | if (numtype & IS_NUMBER_NOT_INT) { |
2644 | /* UV and NV both imprecise. */ | |
2645 | } else { | |
66a1b24b | 2646 | const UV nv_as_uv = U_V(nv); |
c2988b20 NC |
2647 | |
2648 | if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { | |
2649 | SvNOK_on(sv); | |
c2988b20 | 2650 | } |
00b6aa41 | 2651 | SvIOK_on(sv); |
c2988b20 NC |
2652 | } |
2653 | } | |
2654 | } | |
2655 | } | |
2656 | } | |
a43d94f2 NC |
2657 | /* It might be more code efficient to go through the entire logic above |
2658 | and conditionally set with SvNOKp_on() rather than SvNOK(), but it | |
2659 | gets complex and potentially buggy, so more programmer efficient | |
2660 | to do it this way, by turning off the public flags: */ | |
2661 | if (!numtype) | |
2662 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); | |
28e5dec8 | 2663 | #endif /* NV_PRESERVES_UV */ |
93a17b20 | 2664 | } |
79072805 | 2665 | else { |
f7877b28 | 2666 | if (isGV_with_GP(sv)) { |
159b6efe | 2667 | glob_2number(MUTABLE_GV(sv)); |
180488f8 NC |
2668 | return 0.0; |
2669 | } | |
2670 | ||
4f62cd62 | 2671 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
29489e7c | 2672 | report_uninit(sv); |
7e25a7e9 NC |
2673 | assert (SvTYPE(sv) >= SVt_NV); |
2674 | /* Typically the caller expects that sv_any is not NULL now. */ | |
2675 | /* XXX Ilya implies that this is a bug in callers that assume this | |
2676 | and ideally should be fixed. */ | |
a0d0e21e | 2677 | return 0.0; |
79072805 | 2678 | } |
572bbb43 | 2679 | #if defined(USE_LONG_DOUBLE) |
097ee67d | 2680 | DEBUG_c({ |
f93f4e46 | 2681 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
1d7c1841 GS |
2682 | PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", |
2683 | PTR2UV(sv), SvNVX(sv)); | |
572bbb43 GS |
2684 | RESTORE_NUMERIC_LOCAL(); |
2685 | }); | |
65202027 | 2686 | #else |
572bbb43 | 2687 | DEBUG_c({ |
f93f4e46 | 2688 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
1779d84d | 2689 | PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", |
1d7c1841 | 2690 | PTR2UV(sv), SvNVX(sv)); |
097ee67d JH |
2691 | RESTORE_NUMERIC_LOCAL(); |
2692 | }); | |
572bbb43 | 2693 | #endif |
463ee0b2 | 2694 | return SvNVX(sv); |
79072805 LW |
2695 | } |
2696 | ||
800401ee JH |
2697 | /* |
2698 | =for apidoc sv_2num | |
2699 | ||
2700 | Return an SV with the numeric value of the source SV, doing any necessary | |
a196a5fa JH |
2701 | reference or overload conversion. You must use the C<SvNUM(sv)> macro to |
2702 | access this function. | |
800401ee JH |
2703 | |
2704 | =cut | |
2705 | */ | |
2706 | ||
2707 | SV * | |
5aaab254 | 2708 | Perl_sv_2num(pTHX_ SV *const sv) |
800401ee | 2709 | { |
7918f24d NC |
2710 | PERL_ARGS_ASSERT_SV_2NUM; |
2711 | ||
b9ee0594 RGS |
2712 | if (!SvROK(sv)) |
2713 | return sv; | |
800401ee | 2714 | if (SvAMAGIC(sv)) { |
31d632c3 | 2715 | SV * const tmpsv = AMG_CALLunary(sv, numer_amg); |
a02ec77a | 2716 | TAINT_IF(tmpsv && SvTAINTED(tmpsv)); |
800401ee JH |
2717 | if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) |
2718 | return sv_2num(tmpsv); | |
2719 | } | |
2720 | return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); | |
2721 | } | |
2722 | ||
645c22ef DM |
2723 | /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or |
2724 | * UV as a string towards the end of buf, and return pointers to start and | |
2725 | * end of it. | |
2726 | * | |
2727 | * We assume that buf is at least TYPE_CHARS(UV) long. | |
2728 | */ | |
2729 | ||
864dbfa3 | 2730 | static char * |
5de3775c | 2731 | S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) |
25da4f38 | 2732 | { |
25da4f38 | 2733 | char *ptr = buf + TYPE_CHARS(UV); |
823a54a3 | 2734 | char * const ebuf = ptr; |
25da4f38 | 2735 | int sign; |
25da4f38 | 2736 | |
7918f24d NC |
2737 | PERL_ARGS_ASSERT_UIV_2BUF; |
2738 | ||
25da4f38 IZ |
2739 | if (is_uv) |
2740 | sign = 0; | |
2741 | else if (iv >= 0) { | |
2742 | uv = iv; | |
2743 | sign = 0; | |
2744 | } else { | |
2745 | uv = -iv; | |
2746 | sign = 1; | |
2747 | } | |
2748 | do { | |
eb160463 | 2749 | *--ptr = '0' + (char)(uv % 10); |
25da4f38 IZ |
2750 | } while (uv /= 10); |
2751 | if (sign) | |
2752 | *--ptr = '-'; | |
2753 | *peob = ebuf; | |
2754 | return ptr; | |
2755 | } | |
2756 | ||
645c22ef DM |
2757 | /* |
2758 | =for apidoc sv_2pv_flags | |
2759 | ||
ff276b08 | 2760 | Returns a pointer to the string value of an SV, and sets *lp to its length. |
fde67290 FC |
2761 | If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a |
2762 | string if necessary. Normally invoked via the C<SvPV_flags> macro. | |
2763 | C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too. | |
645c22ef DM |
2764 | |
2765 | =cut | |
2766 | */ | |
2767 | ||
8d6d96c1 | 2768 | char * |
5aaab254 | 2769 | Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) |
8d6d96c1 | 2770 | { |
97aff369 | 2771 | dVAR; |
eb578fdb | 2772 | char *s; |
79072805 | 2773 | |
463ee0b2 | 2774 | if (!sv) { |
cdb061a3 NC |
2775 | if (lp) |
2776 | *lp = 0; | |
73d840c0 | 2777 | return (char *)""; |
463ee0b2 | 2778 | } |
217f6fa3 FC |
2779 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2780 | && SvTYPE(sv) != SVt_PVFM); | |
4bac9ae4 CS |
2781 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
2782 | mg_get(sv); | |
2783 | if (SvROK(sv)) { | |
2784 | if (SvAMAGIC(sv)) { | |
2785 | SV *tmpstr; | |
2786 | if (flags & SV_SKIP_OVERLOAD) | |
2787 | return NULL; | |
2788 | tmpstr = AMG_CALLunary(sv, string_amg); | |
2789 | TAINT_IF(tmpstr && SvTAINTED(tmpstr)); | |
2790 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2791 | /* Unwrap this: */ | |
2792 | /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); | |
2793 | */ | |
75dfc8ec | 2794 | |
4bac9ae4 CS |
2795 | char *pv; |
2796 | if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { | |
2797 | if (flags & SV_CONST_RETURN) { | |
2798 | pv = (char *) SvPVX_const(tmpstr); | |
50adf7d2 | 2799 | } else { |
4bac9ae4 CS |
2800 | pv = (flags & SV_MUTABLE_RETURN) |
2801 | ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); | |
50adf7d2 | 2802 | } |
4bac9ae4 CS |
2803 | if (lp) |
2804 | *lp = SvCUR(tmpstr); | |
2805 | } else { | |
2806 | pv = sv_2pv_flags(tmpstr, lp, flags); | |
50adf7d2 | 2807 | } |
4bac9ae4 CS |
2808 | if (SvUTF8(tmpstr)) |
2809 | SvUTF8_on(sv); | |
2810 | else | |
2811 | SvUTF8_off(sv); | |
2812 | return pv; | |
deb46114 | 2813 | } |
4bac9ae4 CS |
2814 | } |
2815 | { | |
2816 | STRLEN len; | |
2817 | char *retval; | |
2818 | char *buffer; | |
2819 | SV *const referent = SvRV(sv); | |
2820 | ||
2821 | if (!referent) { | |
2822 | len = 7; | |
2823 | retval = buffer = savepvn("NULLREF", len); | |
2824 | } else if (SvTYPE(referent) == SVt_REGEXP && | |
2825 | (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || | |
2826 | amagic_is_enabled(string_amg))) { | |
2827 | REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); | |
2828 | ||
2829 | assert(re); | |
67d2d14d | 2830 | |
4bac9ae4 CS |
2831 | /* If the regex is UTF-8 we want the containing scalar to |
2832 | have an UTF-8 flag too */ | |
2833 | if (RX_UTF8(re)) | |
2834 | SvUTF8_on(sv); | |
2835 | else | |
2836 | SvUTF8_off(sv); | |
67d2d14d | 2837 | |
4bac9ae4 CS |
2838 | if (lp) |
2839 | *lp = RX_WRAPLEN(re); | |
67d2d14d | 2840 | |
4bac9ae4 CS |
2841 | return RX_WRAPPED(re); |
2842 | } else { | |
2843 | const char *const typestr = sv_reftype(referent, 0); | |
2844 | const STRLEN typelen = strlen(typestr); | |
2845 | UV addr = PTR2UV(referent); | |
2846 | const char *stashname = NULL; | |
2847 | STRLEN stashnamelen = 0; /* hush, gcc */ | |
2848 | const char *buffer_end; | |
2849 | ||
2850 | if (SvOBJECT(referent)) { | |
2851 | const HEK *const name = HvNAME_HEK(SvSTASH(referent)); | |
2852 | ||
2853 | if (name) { | |
2854 | stashname = HEK_KEY(name); | |
2855 | stashnamelen = HEK_LEN(name); | |
2856 | ||
2857 | if (HEK_UTF8(name)) { | |
2858 | SvUTF8_on(sv); | |
fafee734 | 2859 | } else { |
4bac9ae4 | 2860 | SvUTF8_off(sv); |
fafee734 | 2861 | } |
fafee734 | 2862 | } else { |
4bac9ae4 CS |
2863 | stashname = "__ANON__"; |
2864 | stashnamelen = 8; | |
fafee734 | 2865 | } |
4bac9ae4 CS |
2866 | len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ |
2867 | + 2 * sizeof(UV) + 2 /* )\0 */; | |
2868 | } else { | |
2869 | len = typelen + 3 /* (0x */ | |
2870 | + 2 * sizeof(UV) + 2 /* )\0 */; | |
2871 | } | |
fafee734 | 2872 | |
4bac9ae4 CS |
2873 | Newx(buffer, len, char); |
2874 | buffer_end = retval = buffer + len; | |
2875 | ||
2876 | /* Working backwards */ | |
2877 | *--retval = '\0'; | |
2878 | *--retval = ')'; | |
2879 | do { | |
2880 | *--retval = PL_hexdigit[addr & 15]; | |
2881 | } while (addr >>= 4); | |
2882 | *--retval = 'x'; | |
2883 | *--retval = '0'; | |
2884 | *--retval = '('; | |
2885 | ||
2886 | retval -= typelen; | |
2887 | memcpy(retval, typestr, typelen); | |
2888 | ||
2889 | if (stashname) { | |
2890 | *--retval = '='; | |
2891 | retval -= stashnamelen; | |
2892 | memcpy(retval, stashname, stashnamelen); | |
c080367d | 2893 | } |
4bac9ae4 CS |
2894 | /* retval may not necessarily have reached the start of the |
2895 | buffer here. */ | |
2896 | assert (retval >= buffer); | |
2897 | ||
2898 | len = buffer_end - retval - 1; /* -1 for that \0 */ | |
463ee0b2 | 2899 | } |
cdb061a3 | 2900 | if (lp) |
4bac9ae4 CS |
2901 | *lp = len; |
2902 | SAVEFREEPV(buffer); | |
2903 | return retval; | |
79072805 | 2904 | } |
79072805 | 2905 | } |
4bac9ae4 CS |
2906 | |
2907 | if (SvPOKp(sv)) { | |
2908 | if (lp) | |
2909 | *lp = SvCUR(sv); | |
2910 | if (flags & SV_MUTABLE_RETURN) | |
2911 | return SvPVX_mutable(sv); | |
2912 | if (flags & SV_CONST_RETURN) | |
2913 | return (char *)SvPVX_const(sv); | |
2914 | return SvPVX(sv); | |
2915 | } | |
2916 | ||
2917 | if (SvIOK(sv)) { | |
28e5dec8 JH |
2918 | /* I'm assuming that if both IV and NV are equally valid then |
2919 | converting the IV is going to be more efficient */ | |
e1ec3a88 | 2920 | const U32 isUIOK = SvIsUV(sv); |
28e5dec8 JH |
2921 | char buf[TYPE_CHARS(UV)]; |
2922 | char *ebuf, *ptr; | |
97a130b8 | 2923 | STRLEN len; |
28e5dec8 JH |
2924 | |
2925 | if (SvTYPE(sv) < SVt_PVIV) | |
2926 | sv_upgrade(sv, SVt_PVIV); | |
4ea1d550 | 2927 | ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); |
97a130b8 | 2928 | len = ebuf - ptr; |
5902b6a9 | 2929 | /* inlined from sv_setpvn */ |
97a130b8 NC |
2930 | s = SvGROW_mutable(sv, len + 1); |
2931 | Move(ptr, s, len, char); | |
2932 | s += len; | |
28e5dec8 | 2933 | *s = '\0'; |
b127e37e | 2934 | SvPOK_on(sv); |
28e5dec8 | 2935 | } |
4bac9ae4 | 2936 | else if (SvNOK(sv)) { |
79072805 LW |
2937 | if (SvTYPE(sv) < SVt_PVNV) |
2938 | sv_upgrade(sv, SVt_PVNV); | |
29912d93 NC |
2939 | if (SvNVX(sv) == 0.0) { |
2940 | s = SvGROW_mutable(sv, 2); | |
2941 | *s++ = '0'; | |
2942 | *s = '\0'; | |
2943 | } else { | |
2944 | dSAVE_ERRNO; | |
2945 | /* The +20 is pure guesswork. Configure test needed. --jhi */ | |
2946 | s = SvGROW_mutable(sv, NV_DIG + 20); | |
2947 | /* some Xenix systems wipe out errno here */ | |
b127e37e | 2948 | |
b127e37e | 2949 | #ifndef USE_LOCALE_NUMERIC |
68e8f474 | 2950 | Gconvert(SvNVX(sv), NV_DIG, 0, s); |
b127e37e | 2951 | SvPOK_on(sv); |
68e8f474 KW |
2952 | #else |
2953 | /* Gconvert always uses the current locale. That's the right thing | |
2954 | * to do if we're supposed to be using locales. But otherwise, we | |
2955 | * want the result to be based on the C locale, so we need to | |
2956 | * change to the C locale during the Gconvert and then change back. | |
2957 | * But if we're already in the C locale (PL_numeric_standard is | |
2958 | * TRUE in that case), no need to do any changing */ | |
7187d38e | 2959 | if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) { |
68e8f474 | 2960 | Gconvert(SvNVX(sv), NV_DIG, 0, s); |
28acfe03 KW |
2961 | |
2962 | /* If the radix character is UTF-8, and actually is in the | |
2963 | * output, turn on the UTF-8 flag for the scalar */ | |
2964 | if (! PL_numeric_standard | |
2965 | && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) | |
2966 | && instr(s, SvPVX_const(PL_numeric_radix_sv))) | |
2967 | { | |
2968 | SvUTF8_on(sv); | |
2969 | } | |
68e8f474 KW |
2970 | } |
2971 | else { | |
2972 | char *loc = savepv(setlocale(LC_NUMERIC, NULL)); | |
2973 | setlocale(LC_NUMERIC, "C"); | |
2974 | Gconvert(SvNVX(sv), NV_DIG, 0, s); | |
2975 | setlocale(LC_NUMERIC, loc); | |
2976 | Safefree(loc); | |
28acfe03 | 2977 | |
68e8f474 KW |
2978 | } |
2979 | ||
2980 | /* We don't call SvPOK_on(), because it may come to pass that the | |
2981 | * locale changes so that the stringification we just did is no | |
2982 | * longer correct. We will have to re-stringify every time it is | |
2983 | * needed */ | |
b127e37e | 2984 | #endif |
29912d93 NC |
2985 | RESTORE_ERRNO; |
2986 | while (*s) s++; | |
bbce6d69 | 2987 | } |
79072805 | 2988 | } |
4bac9ae4 CS |
2989 | else if (isGV_with_GP(sv)) { |
2990 | GV *const gv = MUTABLE_GV(sv); | |
2991 | SV *const buffer = sv_newmortal(); | |
8d1c3e26 | 2992 | |
4bac9ae4 | 2993 | gv_efullname3(buffer, gv, "*"); |
180488f8 | 2994 | |
4bac9ae4 CS |
2995 | assert(SvPOK(buffer)); |
2996 | if (SvUTF8(buffer)) | |
2997 | SvUTF8_on(sv); | |
2998 | if (lp) | |
2999 | *lp = SvCUR(buffer); | |
3000 | return SvPVX(buffer); | |
3001 | } | |
8d919b0a FC |
3002 | else if (isREGEXP(sv)) { |
3003 | if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); | |
3004 | return RX_WRAPPED((REGEXP *)sv); | |
3005 | } | |
4bac9ae4 | 3006 | else { |
cdb061a3 | 3007 | if (lp) |
00b6aa41 | 3008 | *lp = 0; |
9f621bb0 NC |
3009 | if (flags & SV_UNDEF_RETURNS_NULL) |
3010 | return NULL; | |
4f62cd62 | 3011 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
9f621bb0 | 3012 | report_uninit(sv); |
4bac9ae4 CS |
3013 | /* Typically the caller expects that sv_any is not NULL now. */ |
3014 | if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) | |
25da4f38 | 3015 | sv_upgrade(sv, SVt_PV); |
73d840c0 | 3016 | return (char *)""; |
79072805 | 3017 | } |
4bac9ae4 | 3018 | |
cdb061a3 | 3019 | { |
823a54a3 | 3020 | const STRLEN len = s - SvPVX_const(sv); |
cdb061a3 NC |
3021 | if (lp) |
3022 | *lp = len; | |
3023 | SvCUR_set(sv, len); | |
3024 | } | |
1d7c1841 | 3025 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", |
3f7c398e | 3026 | PTR2UV(sv),SvPVX_const(sv))); |
4d84ee25 NC |
3027 | if (flags & SV_CONST_RETURN) |
3028 | return (char *)SvPVX_const(sv); | |
10516c54 NC |
3029 | if (flags & SV_MUTABLE_RETURN) |
3030 | return SvPVX_mutable(sv); | |
463ee0b2 LW |
3031 | return SvPVX(sv); |
3032 | } | |
3033 | ||
645c22ef | 3034 | /* |
6050d10e JP |
3035 | =for apidoc sv_copypv |
3036 | ||
3037 | Copies a stringified representation of the source SV into the | |
3038 | destination SV. Automatically performs any necessary mg_get and | |
54f0641b | 3039 | coercion of numeric values into strings. Guaranteed to preserve |
2575c402 | 3040 | UTF8 flag even from overloaded objects. Similar in nature to |
54f0641b NIS |
3041 | sv_2pv[_flags] but operates directly on an SV instead of just the |
3042 | string. Mostly uses sv_2pv_flags to do its work, except when that | |
6050d10e JP |
3043 | would lose the UTF-8'ness of the PV. |
3044 | ||
4bac9ae4 CS |
3045 | =for apidoc sv_copypv_nomg |
3046 | ||
3047 | Like sv_copypv, but doesn't invoke get magic first. | |
3048 | ||
3049 | =for apidoc sv_copypv_flags | |
3050 | ||
3051 | Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags | |
3052 | include SV_GMAGIC. | |
3053 | ||
6050d10e JP |
3054 | =cut |
3055 | */ | |
3056 | ||
3057 | void | |
5aaab254 | 3058 | Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) |
6050d10e | 3059 | { |
4bac9ae4 CS |
3060 | PERL_ARGS_ASSERT_SV_COPYPV; |
3061 | ||
3062 | sv_copypv_flags(dsv, ssv, 0); | |
3063 | } | |
3064 | ||
3065 | void | |
5aaab254 | 3066 | Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) |
4bac9ae4 | 3067 | { |
446eaa42 | 3068 | STRLEN len; |
4bac9ae4 | 3069 | const char *s; |
7918f24d | 3070 | |
4bac9ae4 | 3071 | PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; |
7918f24d | 3072 | |
4bac9ae4 CS |
3073 | if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv)) |
3074 | mg_get(ssv); | |
3075 | s = SvPV_nomg_const(ssv,len); | |
cb50f42d | 3076 | sv_setpvn(dsv,s,len); |
446eaa42 | 3077 | if (SvUTF8(ssv)) |
cb50f42d | 3078 | SvUTF8_on(dsv); |
446eaa42 | 3079 | else |
cb50f42d | 3080 | SvUTF8_off(dsv); |
6050d10e JP |
3081 | } |
3082 | ||
3083 | /* | |
645c22ef DM |
3084 | =for apidoc sv_2pvbyte |
3085 | ||
3086 | Return a pointer to the byte-encoded representation of the SV, and set *lp | |
1e54db1a | 3087 | to its length. May cause the SV to be downgraded from UTF-8 as a |
645c22ef DM |
3088 | side-effect. |
3089 | ||
3090 | Usually accessed via the C<SvPVbyte> macro. | |
3091 | ||
3092 | =cut | |
3093 | */ | |
3094 | ||
7340a771 | 3095 | char * |
5aaab254 | 3096 | Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) |
7340a771 | 3097 | { |
7918f24d NC |
3098 | PERL_ARGS_ASSERT_SV_2PVBYTE; |
3099 | ||
48120f8f | 3100 | SvGETMAGIC(sv); |
4499db73 FC |
3101 | if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
3102 | || isGV_with_GP(sv) || SvROK(sv)) { | |
a901b181 | 3103 | SV *sv2 = sv_newmortal(); |
48120f8f | 3104 | sv_copypv_nomg(sv2,sv); |
a901b181 FC |
3105 | sv = sv2; |
3106 | } | |
0875d2fe | 3107 | sv_utf8_downgrade(sv,0); |
71eb6d8c | 3108 | return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
7340a771 GS |
3109 | } |
3110 | ||
645c22ef | 3111 | /* |
035cbb0e RGS |
3112 | =for apidoc sv_2pvutf8 |
3113 | ||
3114 | Return a pointer to the UTF-8-encoded representation of the SV, and set *lp | |
3115 | to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. | |
3116 | ||
3117 | Usually accessed via the C<SvPVutf8> macro. | |
3118 | ||
3119 | =cut | |
3120 | */ | |
645c22ef | 3121 | |
7340a771 | 3122 | char * |
5aaab254 | 3123 | Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) |
7340a771 | 3124 | { |
7918f24d NC |
3125 | PERL_ARGS_ASSERT_SV_2PVUTF8; |
3126 | ||
4499db73 FC |
3127 | if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
3128 | || isGV_with_GP(sv) || SvROK(sv)) | |
fe46cbda | 3129 | sv = sv_mortalcopy(sv); |
4bac9ae4 CS |
3130 | else |
3131 | SvGETMAGIC(sv); | |
3132 | sv_utf8_upgrade_nomg(sv); | |
c3ec315f | 3133 | return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
7340a771 | 3134 | } |
1c846c1f | 3135 | |
7ee2227d | 3136 | |
645c22ef DM |
3137 | /* |
3138 | =for apidoc sv_2bool | |
3139 | ||
06c841cf FC |
3140 | This macro is only used by sv_true() or its macro equivalent, and only if |
3141 | the latter's argument is neither SvPOK, SvIOK nor SvNOK. | |
3142 | It calls sv_2bool_flags with the SV_GMAGIC flag. | |
3143 | ||
3144 | =for apidoc sv_2bool_flags | |
3145 | ||
3146 | This function is only used by sv_true() and friends, and only if | |
fde67290 | 3147 | the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags |
06c841cf FC |
3148 | contain SV_GMAGIC, then it does an mg_get() first. |
3149 | ||
645c22ef DM |
3150 | |
3151 | =cut | |
3152 | */ | |
3153 | ||
463ee0b2 | 3154 | bool |
5aaab254 | 3155 | Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags) |
463ee0b2 | 3156 | { |
97aff369 | 3157 | dVAR; |
7918f24d | 3158 | |
06c841cf | 3159 | PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; |
7918f24d | 3160 | |
06c841cf | 3161 | if(flags & SV_GMAGIC) SvGETMAGIC(sv); |
463ee0b2 | 3162 | |
a0d0e21e LW |
3163 | if (!SvOK(sv)) |
3164 | return 0; | |
3165 | if (SvROK(sv)) { | |
fabdb6c0 | 3166 | if (SvAMAGIC(sv)) { |
31d632c3 | 3167 | SV * const tmpsv = AMG_CALLunary(sv, bool__amg); |
fabdb6c0 | 3168 | if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) |
f2338a2e | 3169 | return cBOOL(SvTRUE(tmpsv)); |
fabdb6c0 AL |
3170 | } |
3171 | return SvRV(sv) != 0; | |
a0d0e21e | 3172 | } |
85b7d9b3 FC |
3173 | if (isREGEXP(sv)) |
3174 | return | |
3175 | RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); | |
4bac9ae4 | 3176 | return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); |
79072805 LW |
3177 | } |
3178 | ||
c461cf8f JH |
3179 | /* |
3180 | =for apidoc sv_utf8_upgrade | |
3181 | ||
78ea37eb | 3182 | Converts the PV of an SV to its UTF-8-encoded form. |
645c22ef | 3183 | Forces the SV to string form if it is not already. |
2bbc8d55 | 3184 | Will C<mg_get> on C<sv> if appropriate. |
4411f3b6 | 3185 | Always sets the SvUTF8 flag to avoid future validity checks even |
2bbc8d55 SP |
3186 | if the whole string is the same in UTF-8 as not. |
3187 | Returns the number of bytes in the converted string | |
c461cf8f | 3188 | |
0efd0472 | 3189 | This is not a general purpose byte encoding to Unicode interface: |
13a6c0e0 JH |
3190 | use the Encode extension for that. |
3191 | ||
fe749c9a KW |
3192 | =for apidoc sv_utf8_upgrade_nomg |
3193 | ||
fde67290 | 3194 | Like sv_utf8_upgrade, but doesn't do magic on C<sv>. |
fe749c9a | 3195 | |
8d6d96c1 HS |
3196 | =for apidoc sv_utf8_upgrade_flags |
3197 | ||
78ea37eb | 3198 | Converts the PV of an SV to its UTF-8-encoded form. |
645c22ef | 3199 | Forces the SV to string form if it is not already. |
8d6d96c1 | 3200 | Always sets the SvUTF8 flag to avoid future validity checks even |
960b0271 FC |
3201 | if all the bytes are invariant in UTF-8. |
3202 | If C<flags> has C<SV_GMAGIC> bit set, | |
2bbc8d55 SP |
3203 | will C<mg_get> on C<sv> if appropriate, else not. |
3204 | Returns the number of bytes in the converted string | |
3205 | C<sv_utf8_upgrade> and | |
8d6d96c1 HS |
3206 | C<sv_utf8_upgrade_nomg> are implemented in terms of this function. |
3207 | ||
0efd0472 | 3208 | This is not a general purpose byte encoding to Unicode interface: |
13a6c0e0 JH |
3209 | use the Encode extension for that. |
3210 | ||
8d6d96c1 | 3211 | =cut |
b3ab6785 KW |
3212 | |
3213 | The grow version is currently not externally documented. It adds a parameter, | |
3214 | extra, which is the number of unused bytes the string of 'sv' is guaranteed to | |
3215 | have free after it upon return. This allows the caller to reserve extra space | |
3216 | that it intends to fill, to avoid extra grows. | |
3217 | ||
3218 | Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE, | |
3219 | which can be used to tell this function to not first check to see if there are | |
3220 | any characters that are different in UTF-8 (variant characters) which would | |
3221 | force it to allocate a new string to sv, but to assume there are. Typically | |
3222 | this flag is used by a routine that has already parsed the string to find that | |
3223 | there are such characters, and passes this information on so that the work | |
3224 | doesn't have to be repeated. | |
3225 | ||
3226 | (One might think that the calling routine could pass in the position of the | |
3227 | first such variant, so it wouldn't have to be found again. But that is not the | |
3228 | case, because typically when the caller is likely to use this flag, it won't be | |
3229 | calling this routine unless it finds something that won't fit into a byte. | |
3230 | Otherwise it tries to not upgrade and just use bytes. But some things that | |
3231 | do fit into a byte are variants in utf8, and the caller may not have been | |
3232 | keeping track of these.) | |
3233 | ||
3234 | If the routine itself changes the string, it adds a trailing NUL. Such a NUL | |
3235 | isn't guaranteed due to having other routines do the work in some input cases, | |
3236 | or if the input is already flagged as being in utf8. | |
3237 | ||
3238 | The speed of this could perhaps be improved for many cases if someone wanted to | |
3239 | write a fast function that counts the number of variant characters in a string, | |
3240 | especially if it could return the position of the first one. | |
3241 | ||
8d6d96c1 HS |
3242 | */ |
3243 | ||
3244 | STRLEN | |
5aaab254 | 3245 | Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) |
8d6d96c1 | 3246 | { |
97aff369 | 3247 | dVAR; |
7918f24d | 3248 | |
b3ab6785 | 3249 | PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; |
7918f24d | 3250 | |
808c356f RGS |
3251 | if (sv == &PL_sv_undef) |
3252 | return 0; | |
892f9127 | 3253 | if (!SvPOK_nog(sv)) { |
e0e62c2a | 3254 | STRLEN len = 0; |
d52b7888 NC |
3255 | if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { |
3256 | (void) sv_2pv_flags(sv,&len, flags); | |
b3ab6785 KW |
3257 | if (SvUTF8(sv)) { |
3258 | if (extra) SvGROW(sv, SvCUR(sv) + extra); | |
d52b7888 | 3259 | return len; |
b3ab6785 | 3260 | } |
d52b7888 | 3261 | } else { |
33fb6f35 | 3262 | (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); |
d52b7888 | 3263 | } |
e0e62c2a | 3264 | } |
4411f3b6 | 3265 | |
f5cee72b | 3266 | if (SvUTF8(sv)) { |
b3ab6785 | 3267 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
5fec3b1d | 3268 | return SvCUR(sv); |
f5cee72b | 3269 | } |
5fec3b1d | 3270 | |
765f542d | 3271 | if (SvIsCOW(sv)) { |
c56ed9f6 | 3272 | S_sv_uncow(aTHX_ sv, 0); |
db42d148 NIS |
3273 | } |
3274 | ||
b3ab6785 | 3275 | if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { |
799ef3cb | 3276 | sv_recode_to_utf8(sv, PL_encoding); |
b3ab6785 KW |
3277 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
3278 | return SvCUR(sv); | |
3279 | } | |
3280 | ||
4e93345f KW |
3281 | if (SvCUR(sv) == 0) { |
3282 | if (extra) SvGROW(sv, extra); | |
3283 | } else { /* Assume Latin-1/EBCDIC */ | |
c4e7c712 | 3284 | /* This function could be much more efficient if we |
2bbc8d55 | 3285 | * had a FLAG in SVs to signal if there are any variant |
c4e7c712 | 3286 | * chars in the PV. Given that there isn't such a flag |
b3ab6785 KW |
3287 | * make the loop as fast as possible (although there are certainly ways |
3288 | * to speed this up, eg. through vectorization) */ | |
3289 | U8 * s = (U8 *) SvPVX_const(sv); | |
3290 | U8 * e = (U8 *) SvEND(sv); | |
3291 | U8 *t = s; | |
3292 | STRLEN two_byte_count = 0; | |
c4e7c712 | 3293 | |
b3ab6785 KW |
3294 | if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; |
3295 | ||
3296 | /* See if really will need to convert to utf8. We mustn't rely on our | |
3297 | * incoming SV being well formed and having a trailing '\0', as certain | |
3298 | * code in pp_formline can send us partially built SVs. */ | |
3299 | ||
c4e7c712 | 3300 | while (t < e) { |
53c1dcc0 | 3301 | const U8 ch = *t++; |
6f2d5cbc | 3302 | if (NATIVE_BYTE_IS_INVARIANT(ch)) continue; |
b3ab6785 KW |
3303 | |
3304 | t--; /* t already incremented; re-point to first variant */ | |
3305 | two_byte_count = 1; | |
3306 | goto must_be_utf8; | |
c4e7c712 | 3307 | } |
b3ab6785 KW |
3308 | |
3309 | /* utf8 conversion not needed because all are invariants. Mark as | |
3310 | * UTF-8 even if no variant - saves scanning loop */ | |
c4e7c712 | 3311 | SvUTF8_on(sv); |
7f0bfbea | 3312 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
b3ab6785 KW |
3313 | return SvCUR(sv); |
3314 | ||
3315 | must_be_utf8: | |
3316 | ||
3317 | /* Here, the string should be converted to utf8, either because of an | |
3318 | * input flag (two_byte_count = 0), or because a character that | |
3319 | * requires 2 bytes was found (two_byte_count = 1). t points either to | |
3320 | * the beginning of the string (if we didn't examine anything), or to | |
3321 | * the first variant. In either case, everything from s to t - 1 will | |
3322 | * occupy only 1 byte each on output. | |
3323 | * | |
3324 | * There are two main ways to convert. One is to create a new string | |
3325 | * and go through the input starting from the beginning, appending each | |
3326 | * converted value onto the new string as we go along. It's probably | |
3327 | * best to allocate enough space in the string for the worst possible | |
3328 | * case rather than possibly running out of space and having to | |
3329 | * reallocate and then copy what we've done so far. Since everything | |
3330 | * from s to t - 1 is invariant, the destination can be initialized | |
3331 | * with these using a fast memory copy | |
3332 | * | |
3333 | * The other way is to figure out exactly how big the string should be | |
3334 | * by parsing the entire input. Then you don't have to make it big | |
3335 | * enough to handle the worst possible case, and more importantly, if | |
3336 | * the string you already have is large enough, you don't have to | |
3337 | * allocate a new string, you can copy the last character in the input | |
3338 | * string to the final position(s) that will be occupied by the | |
3339 | * converted string and go backwards, stopping at t, since everything | |
3340 | * before that is invariant. | |
3341 | * | |
3342 | * There are advantages and disadvantages to each method. | |
3343 | * | |
3344 | * In the first method, we can allocate a new string, do the memory | |
3345 | * copy from the s to t - 1, and then proceed through the rest of the | |
3346 | * string byte-by-byte. | |
3347 | * | |
3348 | * In the second method, we proceed through the rest of the input | |
3349 | * string just calculating how big the converted string will be. Then | |
3350 | * there are two cases: | |
3351 | * 1) if the string has enough extra space to handle the converted | |
3352 | * value. We go backwards through the string, converting until we | |
3353 | * get to the position we are at now, and then stop. If this | |
3354 | * position is far enough along in the string, this method is | |
3355 | * faster than the other method. If the memory copy were the same | |
3356 | * speed as the byte-by-byte loop, that position would be about | |
3357 | * half-way, as at the half-way mark, parsing to the end and back | |
3358 | * is one complete string's parse, the same amount as starting | |
3359 | * over and going all the way through. Actually, it would be | |
3360 | * somewhat less than half-way, as it's faster to just count bytes | |
3361 | * than to also copy, and we don't have the overhead of allocating | |
3362 | * a new string, changing the scalar to use it, and freeing the | |
3363 | * existing one. But if the memory copy is fast, the break-even | |
3364 | * point is somewhere after half way. The counting loop could be | |
3365 | * sped up by vectorization, etc, to move the break-even point | |
3366 | * further towards the beginning. | |
3367 | * 2) if the string doesn't have enough space to handle the converted | |
3368 | * value. A new string will have to be allocated, and one might | |
3369 | * as well, given that, start from the beginning doing the first | |
3370 | * method. We've spent extra time parsing the string and in | |
3371 | * exchange all we've gotten is that we know precisely how big to | |
3372 | * make the new one. Perl is more optimized for time than space, | |
3373 | * so this case is a loser. | |
3374 | * So what I've decided to do is not use the 2nd method unless it is | |
3375 | * guaranteed that a new string won't have to be allocated, assuming | |
3376 | * the worst case. I also decided not to put any more conditions on it | |
3377 | * than this, for now. It seems likely that, since the worst case is | |
3378 | * twice as big as the unknown portion of the string (plus 1), we won't | |
3379 | * be guaranteed enough space, causing us to go to the first method, | |
3380 | * unless the string is short, or the first variant character is near | |
3381 | * the end of it. In either of these cases, it seems best to use the | |
3382 | * 2nd method. The only circumstance I can think of where this would | |
3383 | * be really slower is if the string had once had much more data in it | |
3384 | * than it does now, but there is still a substantial amount in it */ | |
3385 | ||
3386 | { | |
3387 | STRLEN invariant_head = t - s; | |
3388 | STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; | |
3389 | if (SvLEN(sv) < size) { | |
3390 | ||
3391 | /* Here, have decided to allocate a new string */ | |
3392 | ||
3393 | U8 *dst; | |
3394 | U8 *d; | |
3395 | ||
3396 | Newx(dst, size, U8); | |
3397 | ||
3398 | /* If no known invariants at the beginning of the input string, | |
3399 | * set so starts from there. Otherwise, can use memory copy to | |
3400 | * get up to where we are now, and then start from here */ | |
3401 | ||
3402 | if (invariant_head <= 0) { | |
3403 | d = dst; | |
3404 | } else { | |
3405 | Copy(s, dst, invariant_head, char); | |
3406 | d = dst + invariant_head; | |
3407 | } | |
3408 | ||
3409 | while (t < e) { | |
55d09dc8 KW |
3410 | append_utf8_from_native_byte(*t, &d); |
3411 | t++; | |
b3ab6785 KW |
3412 | } |
3413 | *d = '\0'; | |
3414 | SvPV_free(sv); /* No longer using pre-existing string */ | |
3415 | SvPV_set(sv, (char*)dst); | |
3416 | SvCUR_set(sv, d - dst); | |
3417 | SvLEN_set(sv, size); | |
3418 | } else { | |
3419 | ||
3420 | /* Here, have decided to get the exact size of the string. | |
3421 | * Currently this happens only when we know that there is | |
3422 | * guaranteed enough space to fit the converted string, so | |
3423 | * don't have to worry about growing. If two_byte_count is 0, | |
3424 | * then t points to the first byte of the string which hasn't | |
3425 | * been examined yet. Otherwise two_byte_count is 1, and t | |
3426 | * points to the first byte in the string that will expand to | |
3427 | * two. Depending on this, start examining at t or 1 after t. | |
3428 | * */ | |
3429 | ||
3430 | U8 *d = t + two_byte_count; | |
3431 | ||
3432 | ||
3433 | /* Count up the remaining bytes that expand to two */ | |
3434 | ||
3435 | while (d < e) { | |
3436 | const U8 chr = *d++; | |
6f2d5cbc | 3437 | if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++; |
b3ab6785 KW |
3438 | } |
3439 | ||
3440 | /* The string will expand by just the number of bytes that | |
3441 | * occupy two positions. But we are one afterwards because of | |
3442 | * the increment just above. This is the place to put the | |
3443 | * trailing NUL, and to set the length before we decrement */ | |
3444 | ||
3445 | d += two_byte_count; | |
3446 | SvCUR_set(sv, d - s); | |
3447 | *d-- = '\0'; | |
3448 | ||
3449 | ||
3450 | /* Having decremented d, it points to the position to put the | |
3451 | * very last byte of the expanded string. Go backwards through | |
3452 | * the string, copying and expanding as we go, stopping when we | |
3453 | * get to the part that is invariant the rest of the way down */ | |
3454 | ||
3455 | e--; | |
3456 | while (e >= t) { | |
6f2d5cbc | 3457 | if (NATIVE_BYTE_IS_INVARIANT(*e)) { |
9ff651ce | 3458 | *d-- = *e; |
b3ab6785 | 3459 | } else { |
9ff651ce KW |
3460 | *d-- = UTF8_EIGHT_BIT_LO(*e); |
3461 | *d-- = UTF8_EIGHT_BIT_HI(*e); | |
b3ab6785 | 3462 | } |
9ff651ce | 3463 | e--; |
b3ab6785 KW |
3464 | } |
3465 | } | |
75da9d4c DM |
3466 | |
3467 | if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { | |
3468 | /* Update pos. We do it at the end rather than during | |
3469 | * the upgrade, to avoid slowing down the common case | |
25fdce4a FC |
3470 | * (upgrade without pos). |
3471 | * pos can be stored as either bytes or characters. Since | |
3472 | * this was previously a byte string we can just turn off | |
3473 | * the bytes flag. */ | |
75da9d4c DM |
3474 | MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); |
3475 | if (mg) { | |
25fdce4a | 3476 | mg->mg_flags &= ~MGf_BYTES; |
75da9d4c DM |
3477 | } |
3478 | if ((mg = mg_find(sv, PERL_MAGIC_utf8))) | |
3479 | magic_setutf8(sv,mg); /* clear UTF8 cache */ | |
3480 | } | |
b3ab6785 | 3481 | } |
560a288e | 3482 | } |
b3ab6785 KW |
3483 | |
3484 | /* Mark as UTF-8 even if no variant - saves scanning loop */ | |
3485 | SvUTF8_on(sv); | |
4411f3b6 | 3486 | return SvCUR(sv); |
560a288e GS |
3487 | } |
3488 | ||
c461cf8f JH |
3489 | /* |
3490 | =for apidoc sv_utf8_downgrade | |
3491 | ||
78ea37eb | 3492 | Attempts to convert the PV of an SV from characters to bytes. |
2bbc8d55 SP |
3493 | If the PV contains a character that cannot fit |
3494 | in a byte, this conversion will fail; | |
78ea37eb | 3495 | in this case, either returns false or, if C<fail_ok> is not |
c461cf8f JH |
3496 | true, croaks. |
3497 | ||
0efd0472 | 3498 | This is not a general purpose Unicode to byte encoding interface: |
13a6c0e0 JH |
3499 | use the Encode extension for that. |
3500 | ||
c461cf8f JH |
3501 | =cut |
3502 | */ | |
3503 | ||
560a288e | 3504 | bool |
5aaab254 | 3505 | Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) |
560a288e | 3506 | { |
97aff369 | 3507 | dVAR; |
7918f24d NC |
3508 | |
3509 | PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; | |
3510 | ||
78ea37eb | 3511 | if (SvPOKp(sv) && SvUTF8(sv)) { |
fa301091 | 3512 | if (SvCUR(sv)) { |
03cfe0ae | 3513 | U8 *s; |
652088fc | 3514 | STRLEN len; |
75da9d4c | 3515 | int mg_flags = SV_GMAGIC; |
fa301091 | 3516 | |
765f542d | 3517 | if (SvIsCOW(sv)) { |
c56ed9f6 | 3518 | S_sv_uncow(aTHX_ sv, 0); |
765f542d | 3519 | } |
75da9d4c DM |
3520 | if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
3521 | /* update pos */ | |
3522 | MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); | |
25fdce4a FC |
3523 | if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { |
3524 | mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, | |
3525 | SV_GMAGIC|SV_CONST_RETURN); | |
75da9d4c | 3526 | mg_flags = 0; /* sv_pos_b2u does get magic */ |
75da9d4c DM |
3527 | } |
3528 | if ((mg = mg_find(sv, PERL_MAGIC_utf8))) | |
3529 | magic_setutf8(sv,mg); /* clear UTF8 cache */ | |
3530 | ||
3531 | } | |
3532 | s = (U8 *) SvPV_flags(sv, len, mg_flags); | |
3533 | ||
03cfe0ae | 3534 | if (!utf8_to_bytes(s, &len)) { |
fa301091 JH |
3535 | if (fail_ok) |
3536 | return FALSE; | |
3537 | else { | |
3538 | if (PL_op) | |
3539 | Perl_croak(aTHX_ "Wide character in %s", | |
53e06cf0 | 3540 | OP_DESC(PL_op)); |
fa301091 JH |
3541 | else |
3542 | Perl_croak(aTHX_ "Wide character"); | |
3543 | } | |
4b3603a4 | 3544 | } |
b162af07 | 3545 | SvCUR_set(sv, len); |
67e989fb | 3546 | } |
560a288e | 3547 | } |
ffebcc3e | 3548 | SvUTF8_off(sv); |
560a288e GS |
3549 | return TRUE; |
3550 | } | |
3551 | ||
c461cf8f JH |
3552 | /* |
3553 | =for apidoc sv_utf8_encode | |
3554 | ||
78ea37eb TS |
3555 | Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8> |
3556 | flag off so that it looks like octets again. | |
c461cf8f JH |
3557 | |
3558 | =cut | |
3559 | */ | |
3560 | ||
560a288e | 3561 | void |
5aaab254 | 3562 | Perl_sv_utf8_encode(pTHX_ SV *const sv) |
560a288e | 3563 | { |
7918f24d NC |
3564 | PERL_ARGS_ASSERT_SV_UTF8_ENCODE; |
3565 | ||
4c94c214 | 3566 | if (SvREADONLY(sv)) { |
654c723f | 3567 | sv_force_normal_flags(sv, 0); |
4c94c214 | 3568 | } |
a5f5288a | 3569 | (void) sv_utf8_upgrade(sv); |
560a288e GS |
3570 | SvUTF8_off(sv); |
3571 | } | |
3572 | ||
4411f3b6 NIS |
3573 | /* |
3574 | =for apidoc sv_utf8_decode | |
3575 | ||
78ea37eb TS |
3576 | If the PV of the SV is an octet sequence in UTF-8 |
3577 | and contains a multiple-byte character, the C<SvUTF8> flag is turned on | |
fde67290 | 3578 | so that it looks like a character. If the PV contains only single-byte |
694cf0d2 | 3579 | characters, the C<SvUTF8> flag stays off. |
78ea37eb | 3580 | Scans PV for validity and returns false if the PV is invalid UTF-8. |
4411f3b6 NIS |
3581 | |
3582 | =cut | |
3583 | */ | |
3584 | ||
560a288e | 3585 | bool |
5aaab254 | 3586 | Perl_sv_utf8_decode(pTHX_ SV *const sv) |
560a288e | 3587 | { |
7918f24d NC |
3588 | PERL_ARGS_ASSERT_SV_UTF8_DECODE; |
3589 | ||
78ea37eb | 3590 | if (SvPOKp(sv)) { |
75da9d4c | 3591 | const U8 *start, *c; |
93524f2b | 3592 | const U8 *e; |
9cbac4c7 | 3593 | |
645c22ef DM |
3594 | /* The octets may have got themselves encoded - get them back as |
3595 | * bytes | |
3596 | */ | |
3597 | if (!sv_utf8_downgrade(sv, TRUE)) | |
560a288e GS |
3598 | return FALSE; |
3599 | ||
3600 | /* it is actually just a matter of turning the utf8 flag on, but | |
3601 | * we want to make sure everything inside is valid utf8 first. | |
3602 | */ | |
75da9d4c | 3603 | c = start = (const U8 *) SvPVX_const(sv); |
f9cf141a | 3604 | if (!is_utf8_string(c, SvCUR(sv))) |
67e989fb | 3605 | return FALSE; |
93524f2b | 3606 | e = (const U8 *) SvEND(sv); |