Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* sv.c |
79072805 | 2 | * |
9607fc9c | 3 | * Copyright (c) 1991-1997, Larry Wall |
79072805 LW |
4 | * |
5 | * You may distribute under the terms of either the GNU General Public | |
6 | * License or the Artistic License, as specified in the README file. | |
7 | * | |
a0d0e21e LW |
8 | */ |
9 | ||
10 | /* | |
11 | * "I wonder what the Entish is for 'yes' and 'no'," he thought. | |
79072805 LW |
12 | */ |
13 | ||
14 | #include "EXTERN.h" | |
15 | #include "perl.h" | |
79072805 | 16 | |
c07a80fd | 17 | #ifdef OVR_DBL_DIG |
18 | /* Use an overridden DBL_DIG */ | |
19 | # ifdef DBL_DIG | |
20 | # undef DBL_DIG | |
21 | # endif | |
22 | # define DBL_DIG OVR_DBL_DIG | |
23 | #else | |
a0d0e21e LW |
24 | /* The following is all to get DBL_DIG, in order to pick a nice |
25 | default value for printing floating point numbers in Gconvert. | |
26 | (see config.h) | |
27 | */ | |
28 | #ifdef I_LIMITS | |
29 | #include <limits.h> | |
30 | #endif | |
31 | #ifdef I_FLOAT | |
32 | #include <float.h> | |
33 | #endif | |
34 | #ifndef HAS_DBL_DIG | |
35 | #define DBL_DIG 15 /* A guess that works lots of places */ | |
36 | #endif | |
c07a80fd | 37 | #endif |
38 | ||
1edc1566 | 39 | #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__) |
c07a80fd | 40 | # define FAST_SV_GETS |
41 | #endif | |
a0d0e21e | 42 | |
36477c24 | 43 | static IV asIV _((SV* sv)); |
44 | static UV asUV _((SV* sv)); | |
a0d0e21e LW |
45 | static SV *more_sv _((void)); |
46 | static XPVIV *more_xiv _((void)); | |
47 | static XPVNV *more_xnv _((void)); | |
48 | static XPV *more_xpv _((void)); | |
49 | static XRV *more_xrv _((void)); | |
a0d0e21e LW |
50 | static XPVIV *new_xiv _((void)); |
51 | static XPVNV *new_xnv _((void)); | |
52 | static XPV *new_xpv _((void)); | |
53 | static XRV *new_xrv _((void)); | |
54 | static void del_xiv _((XPVIV* p)); | |
55 | static void del_xnv _((XPVNV* p)); | |
56 | static void del_xpv _((XPV* p)); | |
57 | static void del_xrv _((XRV* p)); | |
58 | static void sv_mortalgrow _((void)); | |
a0d0e21e | 59 | static void sv_unglob _((SV* sv)); |
0f15f207 | 60 | static void sv_check_thinkfirst _((SV *sv)); |
a0d0e21e | 61 | |
4561caa4 CS |
62 | typedef void (*SVFUNC) _((SV*)); |
63 | ||
a0d0e21e | 64 | #ifdef PURIFY |
79072805 | 65 | |
4561caa4 CS |
66 | #define new_SV(p) \ |
67 | do { \ | |
fba3b22e | 68 | MUTEX_LOCK(&sv_mutex); \ |
4561caa4 CS |
69 | (p) = (SV*)safemalloc(sizeof(SV)); \ |
70 | reg_add(p); \ | |
fba3b22e | 71 | MUTEX_UNLOCK(&sv_mutex); \ |
4561caa4 CS |
72 | } while (0) |
73 | ||
74 | #define del_SV(p) \ | |
75 | do { \ | |
fba3b22e | 76 | MUTEX_LOCK(&sv_mutex); \ |
4561caa4 CS |
77 | reg_remove(p); \ |
78 | free((char*)(p)); \ | |
fba3b22e | 79 | MUTEX_UNLOCK(&sv_mutex); \ |
4561caa4 CS |
80 | } while (0) |
81 | ||
82 | static SV **registry; | |
83 | static I32 regsize; | |
84 | ||
85 | #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) | |
86 | ||
87 | #define REG_REPLACE(sv,a,b) \ | |
88 | do { \ | |
89 | void* p = sv->sv_any; \ | |
90 | I32 h = REGHASH(sv, regsize); \ | |
91 | I32 i = h; \ | |
92 | while (registry[i] != (a)) { \ | |
93 | if (++i >= regsize) \ | |
94 | i = 0; \ | |
95 | if (i == h) \ | |
96 | die("SV registry bug"); \ | |
97 | } \ | |
98 | registry[i] = (b); \ | |
99 | } while (0) | |
100 | ||
101 | #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) | |
102 | #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) | |
103 | ||
104 | static void | |
105 | reg_add(sv) | |
106 | SV* sv; | |
107 | { | |
108 | if (sv_count >= (regsize >> 1)) | |
109 | { | |
110 | SV **oldreg = registry; | |
111 | I32 oldsize = regsize; | |
112 | ||
113 | regsize = regsize ? ((regsize << 2) + 1) : 2037; | |
114 | registry = (SV**)safemalloc(regsize * sizeof(SV*)); | |
115 | memzero(registry, regsize * sizeof(SV*)); | |
116 | ||
117 | if (oldreg) { | |
118 | I32 i; | |
119 | ||
120 | for (i = 0; i < oldsize; ++i) { | |
121 | SV* oldsv = oldreg[i]; | |
122 | if (oldsv) | |
123 | REG_ADD(oldsv); | |
124 | } | |
125 | Safefree(oldreg); | |
126 | } | |
127 | } | |
128 | ||
129 | REG_ADD(sv); | |
130 | ++sv_count; | |
131 | } | |
132 | ||
133 | static void | |
134 | reg_remove(sv) | |
135 | SV* sv; | |
136 | { | |
137 | REG_REMOVE(sv); | |
138 | --sv_count; | |
139 | } | |
140 | ||
141 | static void | |
142 | visit(f) | |
143 | SVFUNC f; | |
144 | { | |
145 | I32 i; | |
146 | ||
147 | for (i = 0; i < regsize; ++i) { | |
148 | SV* sv = registry[i]; | |
149 | if (sv) | |
150 | (*f)(sv); | |
151 | } | |
152 | } | |
a0d0e21e | 153 | |
4633a7c4 LW |
154 | void |
155 | sv_add_arena(ptr, size, flags) | |
156 | char* ptr; | |
157 | U32 size; | |
158 | U32 flags; | |
159 | { | |
160 | if (!(flags & SVf_FAKE)) | |
161 | free(ptr); | |
162 | } | |
163 | ||
4561caa4 CS |
164 | #else /* ! PURIFY */ |
165 | ||
166 | /* | |
167 | * "A time to plant, and a time to uproot what was planted..." | |
168 | */ | |
169 | ||
170 | #define plant_SV(p) \ | |
171 | do { \ | |
172 | SvANY(p) = (void *)sv_root; \ | |
173 | SvFLAGS(p) = SVTYPEMASK; \ | |
174 | sv_root = (p); \ | |
175 | --sv_count; \ | |
176 | } while (0) | |
a0d0e21e | 177 | |
fba3b22e | 178 | /* sv_mutex must be held while calling uproot_SV() */ |
fc36a67e | 179 | #define uproot_SV(p) \ |
4561caa4 CS |
180 | do { \ |
181 | (p) = sv_root; \ | |
182 | sv_root = (SV*)SvANY(p); \ | |
a0d0e21e | 183 | ++sv_count; \ |
4561caa4 | 184 | } while (0) |
463ee0b2 | 185 | |
fba3b22e MB |
186 | #define new_SV(p) do { \ |
187 | MUTEX_LOCK(&sv_mutex); \ | |
188 | if (sv_root) \ | |
189 | uproot_SV(p); \ | |
190 | else \ | |
191 | (p) = more_sv(); \ | |
192 | MUTEX_UNLOCK(&sv_mutex); \ | |
193 | } while (0) | |
463ee0b2 | 194 | |
a0d0e21e | 195 | #ifdef DEBUGGING |
4561caa4 | 196 | |
fba3b22e MB |
197 | #define del_SV(p) do { \ |
198 | MUTEX_LOCK(&sv_mutex); \ | |
199 | if (debug & 32768) \ | |
200 | del_sv(p); \ | |
201 | else \ | |
202 | plant_SV(p); \ | |
203 | MUTEX_UNLOCK(&sv_mutex); \ | |
204 | } while (0) | |
a0d0e21e | 205 | |
463ee0b2 LW |
206 | static void |
207 | del_sv(p) | |
208 | SV* p; | |
209 | { | |
a0d0e21e | 210 | if (debug & 32768) { |
4633a7c4 | 211 | SV* sva; |
a0d0e21e LW |
212 | SV* sv; |
213 | SV* svend; | |
214 | int ok = 0; | |
4633a7c4 LW |
215 | for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { |
216 | sv = sva + 1; | |
217 | svend = &sva[SvREFCNT(sva)]; | |
a0d0e21e LW |
218 | if (p >= sv && p < svend) |
219 | ok = 1; | |
220 | } | |
221 | if (!ok) { | |
222 | warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p); | |
223 | return; | |
224 | } | |
225 | } | |
4561caa4 | 226 | plant_SV(p); |
463ee0b2 | 227 | } |
a0d0e21e | 228 | |
4561caa4 CS |
229 | #else /* ! DEBUGGING */ |
230 | ||
231 | #define del_SV(p) plant_SV(p) | |
232 | ||
233 | #endif /* DEBUGGING */ | |
463ee0b2 | 234 | |
4633a7c4 LW |
235 | void |
236 | sv_add_arena(ptr, size, flags) | |
237 | char* ptr; | |
238 | U32 size; | |
239 | U32 flags; | |
463ee0b2 | 240 | { |
4633a7c4 | 241 | SV* sva = (SV*)ptr; |
463ee0b2 LW |
242 | register SV* sv; |
243 | register SV* svend; | |
4633a7c4 LW |
244 | Zero(sva, size, char); |
245 | ||
246 | /* The first SV in an arena isn't an SV. */ | |
247 | SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */ | |
248 | SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ | |
249 | SvFLAGS(sva) = flags; /* FAKE if not to be freed */ | |
250 | ||
251 | sv_arenaroot = sva; | |
252 | sv_root = sva + 1; | |
253 | ||
254 | svend = &sva[SvREFCNT(sva) - 1]; | |
255 | sv = sva + 1; | |
463ee0b2 | 256 | while (sv < svend) { |
a0d0e21e | 257 | SvANY(sv) = (void *)(SV*)(sv + 1); |
8990e307 | 258 | SvFLAGS(sv) = SVTYPEMASK; |
463ee0b2 LW |
259 | sv++; |
260 | } | |
261 | SvANY(sv) = 0; | |
4633a7c4 LW |
262 | SvFLAGS(sv) = SVTYPEMASK; |
263 | } | |
264 | ||
fba3b22e | 265 | /* sv_mutex must be held while calling more_sv() */ |
4633a7c4 LW |
266 | static SV* |
267 | more_sv() | |
268 | { | |
4561caa4 CS |
269 | register SV* sv; |
270 | ||
c07a80fd | 271 | if (nice_chunk) { |
272 | sv_add_arena(nice_chunk, nice_chunk_size, 0); | |
273 | nice_chunk = Nullch; | |
274 | } | |
1edc1566 | 275 | else { |
276 | char *chunk; /* must use New here to match call to */ | |
277 | New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */ | |
278 | sv_add_arena(chunk, 1008, 0); | |
279 | } | |
4561caa4 CS |
280 | uproot_SV(sv); |
281 | return sv; | |
463ee0b2 LW |
282 | } |
283 | ||
4561caa4 CS |
284 | static void |
285 | visit(f) | |
286 | SVFUNC f; | |
8990e307 | 287 | { |
4633a7c4 | 288 | SV* sva; |
8990e307 LW |
289 | SV* sv; |
290 | register SV* svend; | |
291 | ||
4561caa4 | 292 | for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { |
4633a7c4 | 293 | svend = &sva[SvREFCNT(sva)]; |
4561caa4 CS |
294 | for (sv = sva + 1; sv < svend; ++sv) { |
295 | if (SvTYPE(sv) != SVTYPEMASK) | |
296 | (*f)(sv); | |
8990e307 LW |
297 | } |
298 | } | |
299 | } | |
300 | ||
4561caa4 CS |
301 | #endif /* PURIFY */ |
302 | ||
303 | static void | |
304 | do_report_used(sv) | |
305 | SV* sv; | |
306 | { | |
307 | if (SvTYPE(sv) != SVTYPEMASK) { | |
d1bf51dd | 308 | /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ |
4561caa4 CS |
309 | PerlIO_printf(PerlIO_stderr(), "****\n"); |
310 | sv_dump(sv); | |
311 | } | |
312 | } | |
313 | ||
8990e307 | 314 | void |
4561caa4 CS |
315 | sv_report_used() |
316 | { | |
317 | visit(do_report_used); | |
318 | } | |
319 | ||
320 | static void | |
321 | do_clean_objs(sv) | |
322 | SV* sv; | |
8990e307 | 323 | { |
a0d0e21e | 324 | SV* rv; |
8990e307 | 325 | |
4561caa4 | 326 | if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { |
d1bf51dd | 327 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) |
4561caa4 CS |
328 | SvROK_off(sv); |
329 | SvRV(sv) = 0; | |
330 | SvREFCNT_dec(rv); | |
a5f75d66 | 331 | } |
4561caa4 CS |
332 | |
333 | /* XXX Might want to check arrays, etc. */ | |
334 | } | |
335 | ||
336 | #ifndef DISABLE_DESTRUCTOR_KLUDGE | |
337 | static void | |
338 | do_clean_named_objs(sv) | |
339 | SV* sv; | |
340 | { | |
341 | if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) | |
342 | do_clean_objs(GvSV(sv)); | |
343 | } | |
a5f75d66 | 344 | #endif |
4561caa4 | 345 | |
477f5d66 CS |
346 | static bool in_clean_objs = FALSE; |
347 | ||
4561caa4 CS |
348 | void |
349 | sv_clean_objs() | |
350 | { | |
477f5d66 | 351 | in_clean_objs = TRUE; |
4561caa4 CS |
352 | #ifndef DISABLE_DESTRUCTOR_KLUDGE |
353 | visit(do_clean_named_objs); | |
354 | #endif | |
355 | visit(do_clean_objs); | |
477f5d66 | 356 | in_clean_objs = FALSE; |
4561caa4 CS |
357 | } |
358 | ||
359 | static void | |
360 | do_clean_all(sv) | |
361 | SV* sv; | |
362 | { | |
d1bf51dd | 363 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) |
4561caa4 CS |
364 | SvFLAGS(sv) |= SVf_BREAK; |
365 | SvREFCNT_dec(sv); | |
8990e307 LW |
366 | } |
367 | ||
477f5d66 | 368 | static bool in_clean_all = FALSE; |
1edc1566 | 369 | |
8990e307 | 370 | void |
8990e307 LW |
371 | sv_clean_all() |
372 | { | |
477f5d66 | 373 | in_clean_all = TRUE; |
4561caa4 | 374 | visit(do_clean_all); |
477f5d66 | 375 | in_clean_all = FALSE; |
8990e307 | 376 | } |
463ee0b2 | 377 | |
4633a7c4 LW |
378 | void |
379 | sv_free_arenas() | |
380 | { | |
381 | SV* sva; | |
382 | SV* svanext; | |
383 | ||
384 | /* Free arenas here, but be careful about fake ones. (We assume | |
385 | contiguity of the fake ones with the corresponding real ones.) */ | |
386 | ||
387 | for (sva = sv_arenaroot; sva; sva = svanext) { | |
388 | svanext = (SV*) SvANY(sva); | |
389 | while (svanext && SvFAKE(svanext)) | |
390 | svanext = (SV*) SvANY(svanext); | |
391 | ||
392 | if (!SvFAKE(sva)) | |
1edc1566 | 393 | Safefree((void *)sva); |
4633a7c4 | 394 | } |
5f05dabc | 395 | |
396 | sv_arenaroot = 0; | |
397 | sv_root = 0; | |
4633a7c4 LW |
398 | } |
399 | ||
463ee0b2 LW |
400 | static XPVIV* |
401 | new_xiv() | |
402 | { | |
a0d0e21e | 403 | IV** xiv; |
463ee0b2 LW |
404 | if (xiv_root) { |
405 | xiv = xiv_root; | |
85e6fe83 LW |
406 | /* |
407 | * See comment in more_xiv() -- RAM. | |
408 | */ | |
a0d0e21e | 409 | xiv_root = (IV**)*xiv; |
463ee0b2 LW |
410 | return (XPVIV*)((char*)xiv - sizeof(XPV)); |
411 | } | |
412 | return more_xiv(); | |
413 | } | |
414 | ||
415 | static void | |
416 | del_xiv(p) | |
417 | XPVIV* p; | |
418 | { | |
a0d0e21e LW |
419 | IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); |
420 | *xiv = (IV *)xiv_root; | |
463ee0b2 LW |
421 | xiv_root = xiv; |
422 | } | |
423 | ||
424 | static XPVIV* | |
425 | more_xiv() | |
426 | { | |
a0d0e21e LW |
427 | register IV** xiv; |
428 | register IV** xivend; | |
429 | XPV* ptr = (XPV*)safemalloc(1008); | |
430 | ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ | |
431 | xiv_arenaroot = ptr; /* to keep Purify happy */ | |
432 | ||
433 | xiv = (IV**) ptr; | |
434 | xivend = &xiv[1008 / sizeof(IV *) - 1]; | |
435 | xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */ | |
463ee0b2 LW |
436 | xiv_root = xiv; |
437 | while (xiv < xivend) { | |
a0d0e21e | 438 | *xiv = (IV *)(xiv + 1); |
463ee0b2 LW |
439 | xiv++; |
440 | } | |
85e6fe83 | 441 | *xiv = 0; |
463ee0b2 LW |
442 | return new_xiv(); |
443 | } | |
444 | ||
463ee0b2 LW |
445 | static XPVNV* |
446 | new_xnv() | |
447 | { | |
448 | double* xnv; | |
449 | if (xnv_root) { | |
450 | xnv = xnv_root; | |
451 | xnv_root = *(double**)xnv; | |
452 | return (XPVNV*)((char*)xnv - sizeof(XPVIV)); | |
453 | } | |
454 | return more_xnv(); | |
455 | } | |
456 | ||
457 | static void | |
458 | del_xnv(p) | |
459 | XPVNV* p; | |
460 | { | |
461 | double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); | |
462 | *(double**)xnv = xnv_root; | |
463 | xnv_root = xnv; | |
464 | } | |
465 | ||
466 | static XPVNV* | |
467 | more_xnv() | |
468 | { | |
463ee0b2 LW |
469 | register double* xnv; |
470 | register double* xnvend; | |
8990e307 | 471 | xnv = (double*)safemalloc(1008); |
463ee0b2 LW |
472 | xnvend = &xnv[1008 / sizeof(double) - 1]; |
473 | xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ | |
474 | xnv_root = xnv; | |
475 | while (xnv < xnvend) { | |
476 | *(double**)xnv = (double*)(xnv + 1); | |
477 | xnv++; | |
478 | } | |
479 | *(double**)xnv = 0; | |
480 | return new_xnv(); | |
481 | } | |
482 | ||
ed6116ce LW |
483 | static XRV* |
484 | new_xrv() | |
485 | { | |
486 | XRV* xrv; | |
487 | if (xrv_root) { | |
488 | xrv = xrv_root; | |
489 | xrv_root = (XRV*)xrv->xrv_rv; | |
490 | return xrv; | |
491 | } | |
492 | return more_xrv(); | |
493 | } | |
494 | ||
495 | static void | |
496 | del_xrv(p) | |
497 | XRV* p; | |
498 | { | |
499 | p->xrv_rv = (SV*)xrv_root; | |
500 | xrv_root = p; | |
501 | } | |
502 | ||
503 | static XRV* | |
504 | more_xrv() | |
505 | { | |
ed6116ce LW |
506 | register XRV* xrv; |
507 | register XRV* xrvend; | |
8990e307 | 508 | xrv_root = (XRV*)safemalloc(1008); |
ed6116ce LW |
509 | xrv = xrv_root; |
510 | xrvend = &xrv[1008 / sizeof(XRV) - 1]; | |
511 | while (xrv < xrvend) { | |
512 | xrv->xrv_rv = (SV*)(xrv + 1); | |
513 | xrv++; | |
514 | } | |
515 | xrv->xrv_rv = 0; | |
516 | return new_xrv(); | |
517 | } | |
518 | ||
463ee0b2 LW |
519 | static XPV* |
520 | new_xpv() | |
521 | { | |
522 | XPV* xpv; | |
523 | if (xpv_root) { | |
524 | xpv = xpv_root; | |
525 | xpv_root = (XPV*)xpv->xpv_pv; | |
526 | return xpv; | |
527 | } | |
528 | return more_xpv(); | |
529 | } | |
530 | ||
531 | static void | |
532 | del_xpv(p) | |
533 | XPV* p; | |
534 | { | |
535 | p->xpv_pv = (char*)xpv_root; | |
536 | xpv_root = p; | |
537 | } | |
538 | ||
539 | static XPV* | |
540 | more_xpv() | |
541 | { | |
463ee0b2 LW |
542 | register XPV* xpv; |
543 | register XPV* xpvend; | |
8990e307 | 544 | xpv_root = (XPV*)safemalloc(1008); |
463ee0b2 LW |
545 | xpv = xpv_root; |
546 | xpvend = &xpv[1008 / sizeof(XPV) - 1]; | |
547 | while (xpv < xpvend) { | |
548 | xpv->xpv_pv = (char*)(xpv + 1); | |
549 | xpv++; | |
550 | } | |
551 | xpv->xpv_pv = 0; | |
552 | return new_xpv(); | |
553 | } | |
554 | ||
555 | #ifdef PURIFY | |
8990e307 | 556 | #define new_XIV() (void*)safemalloc(sizeof(XPVIV)) |
463ee0b2 LW |
557 | #define del_XIV(p) free((char*)p) |
558 | #else | |
85e6fe83 | 559 | #define new_XIV() (void*)new_xiv() |
463ee0b2 LW |
560 | #define del_XIV(p) del_xiv(p) |
561 | #endif | |
562 | ||
563 | #ifdef PURIFY | |
8990e307 | 564 | #define new_XNV() (void*)safemalloc(sizeof(XPVNV)) |
463ee0b2 LW |
565 | #define del_XNV(p) free((char*)p) |
566 | #else | |
85e6fe83 | 567 | #define new_XNV() (void*)new_xnv() |
463ee0b2 LW |
568 | #define del_XNV(p) del_xnv(p) |
569 | #endif | |
570 | ||
571 | #ifdef PURIFY | |
8990e307 | 572 | #define new_XRV() (void*)safemalloc(sizeof(XRV)) |
ed6116ce LW |
573 | #define del_XRV(p) free((char*)p) |
574 | #else | |
85e6fe83 | 575 | #define new_XRV() (void*)new_xrv() |
ed6116ce LW |
576 | #define del_XRV(p) del_xrv(p) |
577 | #endif | |
578 | ||
579 | #ifdef PURIFY | |
8990e307 | 580 | #define new_XPV() (void*)safemalloc(sizeof(XPV)) |
463ee0b2 LW |
581 | #define del_XPV(p) free((char*)p) |
582 | #else | |
85e6fe83 | 583 | #define new_XPV() (void*)new_xpv() |
463ee0b2 LW |
584 | #define del_XPV(p) del_xpv(p) |
585 | #endif | |
586 | ||
8990e307 | 587 | #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) |
463ee0b2 LW |
588 | #define del_XPVIV(p) free((char*)p) |
589 | ||
8990e307 | 590 | #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) |
463ee0b2 LW |
591 | #define del_XPVNV(p) free((char*)p) |
592 | ||
8990e307 | 593 | #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) |
463ee0b2 LW |
594 | #define del_XPVMG(p) free((char*)p) |
595 | ||
8990e307 | 596 | #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) |
463ee0b2 LW |
597 | #define del_XPVLV(p) free((char*)p) |
598 | ||
8990e307 | 599 | #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) |
463ee0b2 LW |
600 | #define del_XPVAV(p) free((char*)p) |
601 | ||
8990e307 | 602 | #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) |
463ee0b2 LW |
603 | #define del_XPVHV(p) free((char*)p) |
604 | ||
8990e307 | 605 | #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) |
463ee0b2 LW |
606 | #define del_XPVCV(p) free((char*)p) |
607 | ||
8990e307 | 608 | #define new_XPVGV() (void*)safemalloc(sizeof(XPVGV)) |
463ee0b2 LW |
609 | #define del_XPVGV(p) free((char*)p) |
610 | ||
8990e307 | 611 | #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) |
463ee0b2 LW |
612 | #define del_XPVBM(p) free((char*)p) |
613 | ||
8990e307 | 614 | #define new_XPVFM() (void*)safemalloc(sizeof(XPVFM)) |
463ee0b2 LW |
615 | #define del_XPVFM(p) free((char*)p) |
616 | ||
8990e307 LW |
617 | #define new_XPVIO() (void*)safemalloc(sizeof(XPVIO)) |
618 | #define del_XPVIO(p) free((char*)p) | |
619 | ||
79072805 LW |
620 | bool |
621 | sv_upgrade(sv, mt) | |
622 | register SV* sv; | |
623 | U32 mt; | |
624 | { | |
625 | char* pv; | |
626 | U32 cur; | |
627 | U32 len; | |
a0d0e21e | 628 | IV iv; |
79072805 LW |
629 | double nv; |
630 | MAGIC* magic; | |
631 | HV* stash; | |
632 | ||
633 | if (SvTYPE(sv) == mt) | |
634 | return TRUE; | |
635 | ||
a5f75d66 AD |
636 | if (mt < SVt_PVIV) |
637 | (void)SvOOK_off(sv); | |
638 | ||
79072805 LW |
639 | switch (SvTYPE(sv)) { |
640 | case SVt_NULL: | |
641 | pv = 0; | |
642 | cur = 0; | |
643 | len = 0; | |
644 | iv = 0; | |
645 | nv = 0.0; | |
646 | magic = 0; | |
647 | stash = 0; | |
648 | break; | |
79072805 LW |
649 | case SVt_IV: |
650 | pv = 0; | |
651 | cur = 0; | |
652 | len = 0; | |
463ee0b2 LW |
653 | iv = SvIVX(sv); |
654 | nv = (double)SvIVX(sv); | |
79072805 LW |
655 | del_XIV(SvANY(sv)); |
656 | magic = 0; | |
657 | stash = 0; | |
ed6116ce | 658 | if (mt == SVt_NV) |
463ee0b2 | 659 | mt = SVt_PVNV; |
ed6116ce LW |
660 | else if (mt < SVt_PVIV) |
661 | mt = SVt_PVIV; | |
79072805 LW |
662 | break; |
663 | case SVt_NV: | |
664 | pv = 0; | |
665 | cur = 0; | |
666 | len = 0; | |
463ee0b2 | 667 | nv = SvNVX(sv); |
ed6116ce | 668 | iv = I_32(nv); |
79072805 LW |
669 | magic = 0; |
670 | stash = 0; | |
671 | del_XNV(SvANY(sv)); | |
672 | SvANY(sv) = 0; | |
ed6116ce | 673 | if (mt < SVt_PVNV) |
79072805 LW |
674 | mt = SVt_PVNV; |
675 | break; | |
ed6116ce LW |
676 | case SVt_RV: |
677 | pv = (char*)SvRV(sv); | |
678 | cur = 0; | |
679 | len = 0; | |
a0d0e21e | 680 | iv = (IV)pv; |
ed6116ce LW |
681 | nv = (double)(unsigned long)pv; |
682 | del_XRV(SvANY(sv)); | |
683 | magic = 0; | |
684 | stash = 0; | |
685 | break; | |
79072805 | 686 | case SVt_PV: |
463ee0b2 | 687 | pv = SvPVX(sv); |
79072805 LW |
688 | cur = SvCUR(sv); |
689 | len = SvLEN(sv); | |
690 | iv = 0; | |
691 | nv = 0.0; | |
692 | magic = 0; | |
693 | stash = 0; | |
694 | del_XPV(SvANY(sv)); | |
748a9306 LW |
695 | if (mt <= SVt_IV) |
696 | mt = SVt_PVIV; | |
697 | else if (mt == SVt_NV) | |
698 | mt = SVt_PVNV; | |
79072805 LW |
699 | break; |
700 | case SVt_PVIV: | |
463ee0b2 | 701 | pv = SvPVX(sv); |
79072805 LW |
702 | cur = SvCUR(sv); |
703 | len = SvLEN(sv); | |
463ee0b2 | 704 | iv = SvIVX(sv); |
79072805 LW |
705 | nv = 0.0; |
706 | magic = 0; | |
707 | stash = 0; | |
708 | del_XPVIV(SvANY(sv)); | |
709 | break; | |
710 | case SVt_PVNV: | |
463ee0b2 | 711 | pv = SvPVX(sv); |
79072805 LW |
712 | cur = SvCUR(sv); |
713 | len = SvLEN(sv); | |
463ee0b2 LW |
714 | iv = SvIVX(sv); |
715 | nv = SvNVX(sv); | |
79072805 LW |
716 | magic = 0; |
717 | stash = 0; | |
718 | del_XPVNV(SvANY(sv)); | |
719 | break; | |
720 | case SVt_PVMG: | |
463ee0b2 | 721 | pv = SvPVX(sv); |
79072805 LW |
722 | cur = SvCUR(sv); |
723 | len = SvLEN(sv); | |
463ee0b2 LW |
724 | iv = SvIVX(sv); |
725 | nv = SvNVX(sv); | |
79072805 LW |
726 | magic = SvMAGIC(sv); |
727 | stash = SvSTASH(sv); | |
728 | del_XPVMG(SvANY(sv)); | |
729 | break; | |
730 | default: | |
463ee0b2 | 731 | croak("Can't upgrade that kind of scalar"); |
79072805 LW |
732 | } |
733 | ||
734 | switch (mt) { | |
735 | case SVt_NULL: | |
463ee0b2 | 736 | croak("Can't upgrade to undef"); |
79072805 LW |
737 | case SVt_IV: |
738 | SvANY(sv) = new_XIV(); | |
463ee0b2 | 739 | SvIVX(sv) = iv; |
79072805 LW |
740 | break; |
741 | case SVt_NV: | |
742 | SvANY(sv) = new_XNV(); | |
463ee0b2 | 743 | SvNVX(sv) = nv; |
79072805 | 744 | break; |
ed6116ce LW |
745 | case SVt_RV: |
746 | SvANY(sv) = new_XRV(); | |
747 | SvRV(sv) = (SV*)pv; | |
ed6116ce | 748 | break; |
79072805 LW |
749 | case SVt_PV: |
750 | SvANY(sv) = new_XPV(); | |
463ee0b2 | 751 | SvPVX(sv) = pv; |
79072805 LW |
752 | SvCUR(sv) = cur; |
753 | SvLEN(sv) = len; | |
754 | break; | |
755 | case SVt_PVIV: | |
756 | SvANY(sv) = new_XPVIV(); | |
463ee0b2 | 757 | SvPVX(sv) = pv; |
79072805 LW |
758 | SvCUR(sv) = cur; |
759 | SvLEN(sv) = len; | |
463ee0b2 | 760 | SvIVX(sv) = iv; |
79072805 | 761 | if (SvNIOK(sv)) |
a0d0e21e | 762 | (void)SvIOK_on(sv); |
79072805 LW |
763 | SvNOK_off(sv); |
764 | break; | |
765 | case SVt_PVNV: | |
766 | SvANY(sv) = new_XPVNV(); | |
463ee0b2 | 767 | SvPVX(sv) = pv; |
79072805 LW |
768 | SvCUR(sv) = cur; |
769 | SvLEN(sv) = len; | |
463ee0b2 LW |
770 | SvIVX(sv) = iv; |
771 | SvNVX(sv) = nv; | |
79072805 LW |
772 | break; |
773 | case SVt_PVMG: | |
774 | SvANY(sv) = new_XPVMG(); | |
463ee0b2 | 775 | SvPVX(sv) = pv; |
79072805 LW |
776 | SvCUR(sv) = cur; |
777 | SvLEN(sv) = len; | |
463ee0b2 LW |
778 | SvIVX(sv) = iv; |
779 | SvNVX(sv) = nv; | |
79072805 LW |
780 | SvMAGIC(sv) = magic; |
781 | SvSTASH(sv) = stash; | |
782 | break; | |
783 | case SVt_PVLV: | |
784 | SvANY(sv) = new_XPVLV(); | |
463ee0b2 | 785 | SvPVX(sv) = pv; |
79072805 LW |
786 | SvCUR(sv) = cur; |
787 | SvLEN(sv) = len; | |
463ee0b2 LW |
788 | SvIVX(sv) = iv; |
789 | SvNVX(sv) = nv; | |
79072805 LW |
790 | SvMAGIC(sv) = magic; |
791 | SvSTASH(sv) = stash; | |
792 | LvTARGOFF(sv) = 0; | |
793 | LvTARGLEN(sv) = 0; | |
794 | LvTARG(sv) = 0; | |
795 | LvTYPE(sv) = 0; | |
796 | break; | |
797 | case SVt_PVAV: | |
798 | SvANY(sv) = new_XPVAV(); | |
463ee0b2 LW |
799 | if (pv) |
800 | Safefree(pv); | |
2304df62 | 801 | SvPVX(sv) = 0; |
d1bf51dd CS |
802 | AvMAX(sv) = -1; |
803 | AvFILL(sv) = -1; | |
463ee0b2 LW |
804 | SvIVX(sv) = 0; |
805 | SvNVX(sv) = 0.0; | |
806 | SvMAGIC(sv) = magic; | |
807 | SvSTASH(sv) = stash; | |
808 | AvALLOC(sv) = 0; | |
79072805 LW |
809 | AvARYLEN(sv) = 0; |
810 | AvFLAGS(sv) = 0; | |
811 | break; | |
812 | case SVt_PVHV: | |
813 | SvANY(sv) = new_XPVHV(); | |
463ee0b2 LW |
814 | if (pv) |
815 | Safefree(pv); | |
816 | SvPVX(sv) = 0; | |
817 | HvFILL(sv) = 0; | |
818 | HvMAX(sv) = 0; | |
819 | HvKEYS(sv) = 0; | |
820 | SvNVX(sv) = 0.0; | |
79072805 LW |
821 | SvMAGIC(sv) = magic; |
822 | SvSTASH(sv) = stash; | |
79072805 LW |
823 | HvRITER(sv) = 0; |
824 | HvEITER(sv) = 0; | |
825 | HvPMROOT(sv) = 0; | |
826 | HvNAME(sv) = 0; | |
79072805 LW |
827 | break; |
828 | case SVt_PVCV: | |
829 | SvANY(sv) = new_XPVCV(); | |
748a9306 | 830 | Zero(SvANY(sv), 1, XPVCV); |
463ee0b2 | 831 | SvPVX(sv) = pv; |
79072805 LW |
832 | SvCUR(sv) = cur; |
833 | SvLEN(sv) = len; | |
463ee0b2 LW |
834 | SvIVX(sv) = iv; |
835 | SvNVX(sv) = nv; | |
79072805 LW |
836 | SvMAGIC(sv) = magic; |
837 | SvSTASH(sv) = stash; | |
79072805 LW |
838 | break; |
839 | case SVt_PVGV: | |
840 | SvANY(sv) = new_XPVGV(); | |
463ee0b2 | 841 | SvPVX(sv) = pv; |
79072805 LW |
842 | SvCUR(sv) = cur; |
843 | SvLEN(sv) = len; | |
463ee0b2 LW |
844 | SvIVX(sv) = iv; |
845 | SvNVX(sv) = nv; | |
79072805 LW |
846 | SvMAGIC(sv) = magic; |
847 | SvSTASH(sv) = stash; | |
93a17b20 | 848 | GvGP(sv) = 0; |
79072805 LW |
849 | GvNAME(sv) = 0; |
850 | GvNAMELEN(sv) = 0; | |
851 | GvSTASH(sv) = 0; | |
a5f75d66 | 852 | GvFLAGS(sv) = 0; |
79072805 LW |
853 | break; |
854 | case SVt_PVBM: | |
855 | SvANY(sv) = new_XPVBM(); | |
463ee0b2 | 856 | SvPVX(sv) = pv; |
79072805 LW |
857 | SvCUR(sv) = cur; |
858 | SvLEN(sv) = len; | |
463ee0b2 LW |
859 | SvIVX(sv) = iv; |
860 | SvNVX(sv) = nv; | |
79072805 LW |
861 | SvMAGIC(sv) = magic; |
862 | SvSTASH(sv) = stash; | |
863 | BmRARE(sv) = 0; | |
864 | BmUSEFUL(sv) = 0; | |
865 | BmPREVIOUS(sv) = 0; | |
866 | break; | |
867 | case SVt_PVFM: | |
868 | SvANY(sv) = new_XPVFM(); | |
748a9306 | 869 | Zero(SvANY(sv), 1, XPVFM); |
463ee0b2 | 870 | SvPVX(sv) = pv; |
79072805 LW |
871 | SvCUR(sv) = cur; |
872 | SvLEN(sv) = len; | |
463ee0b2 LW |
873 | SvIVX(sv) = iv; |
874 | SvNVX(sv) = nv; | |
79072805 LW |
875 | SvMAGIC(sv) = magic; |
876 | SvSTASH(sv) = stash; | |
79072805 | 877 | break; |
8990e307 LW |
878 | case SVt_PVIO: |
879 | SvANY(sv) = new_XPVIO(); | |
748a9306 | 880 | Zero(SvANY(sv), 1, XPVIO); |
8990e307 LW |
881 | SvPVX(sv) = pv; |
882 | SvCUR(sv) = cur; | |
883 | SvLEN(sv) = len; | |
884 | SvIVX(sv) = iv; | |
885 | SvNVX(sv) = nv; | |
886 | SvMAGIC(sv) = magic; | |
887 | SvSTASH(sv) = stash; | |
85e6fe83 | 888 | IoPAGE_LEN(sv) = 60; |
8990e307 LW |
889 | break; |
890 | } | |
891 | SvFLAGS(sv) &= ~SVTYPEMASK; | |
892 | SvFLAGS(sv) |= mt; | |
79072805 LW |
893 | return TRUE; |
894 | } | |
895 | ||
a0d0e21e | 896 | #ifdef DEBUGGING |
79072805 LW |
897 | char * |
898 | sv_peek(sv) | |
899 | register SV *sv; | |
900 | { | |
46fc3d4c | 901 | SV *t = sv_newmortal(); |
902 | STRLEN prevlen; | |
a0d0e21e | 903 | int unref = 0; |
79072805 | 904 | |
2b98c477 | 905 | sv_setpvn(t, "", 0); |
79072805 LW |
906 | retry: |
907 | if (!sv) { | |
46fc3d4c | 908 | sv_catpv(t, "VOID"); |
a0d0e21e | 909 | goto finish; |
79072805 LW |
910 | } |
911 | else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { | |
46fc3d4c | 912 | sv_catpv(t, "WILD"); |
a0d0e21e LW |
913 | goto finish; |
914 | } | |
915 | else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) { | |
916 | if (sv == &sv_undef) { | |
46fc3d4c | 917 | sv_catpv(t, "SV_UNDEF"); |
a0d0e21e LW |
918 | if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| |
919 | SVs_GMG|SVs_SMG|SVs_RMG)) && | |
920 | SvREADONLY(sv)) | |
921 | goto finish; | |
922 | } | |
923 | else if (sv == &sv_no) { | |
46fc3d4c | 924 | sv_catpv(t, "SV_NO"); |
a0d0e21e LW |
925 | if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| |
926 | SVs_GMG|SVs_SMG|SVs_RMG)) && | |
927 | !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| | |
928 | SVp_POK|SVp_NOK)) && | |
929 | SvCUR(sv) == 0 && | |
930 | SvNVX(sv) == 0.0) | |
931 | goto finish; | |
932 | } | |
933 | else { | |
46fc3d4c | 934 | sv_catpv(t, "SV_YES"); |
a0d0e21e LW |
935 | if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| |
936 | SVs_GMG|SVs_SMG|SVs_RMG)) && | |
937 | !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| | |
938 | SVp_POK|SVp_NOK)) && | |
939 | SvCUR(sv) == 1 && | |
940 | SvPVX(sv) && *SvPVX(sv) == '1' && | |
941 | SvNVX(sv) == 1.0) | |
942 | goto finish; | |
943 | } | |
46fc3d4c | 944 | sv_catpv(t, ":"); |
79072805 | 945 | } |
a0d0e21e | 946 | else if (SvREFCNT(sv) == 0) { |
46fc3d4c | 947 | sv_catpv(t, "("); |
a0d0e21e | 948 | unref++; |
79072805 | 949 | } |
a0d0e21e | 950 | if (SvROK(sv)) { |
46fc3d4c | 951 | sv_catpv(t, "\\"); |
952 | if (SvCUR(t) + unref > 10) { | |
953 | SvCUR(t) = unref + 3; | |
954 | *SvEND(t) = '\0'; | |
955 | sv_catpv(t, "..."); | |
a0d0e21e | 956 | goto finish; |
79072805 | 957 | } |
a0d0e21e LW |
958 | sv = (SV*)SvRV(sv); |
959 | goto retry; | |
960 | } | |
961 | switch (SvTYPE(sv)) { | |
962 | default: | |
46fc3d4c | 963 | sv_catpv(t, "FREED"); |
a0d0e21e LW |
964 | goto finish; |
965 | ||
966 | case SVt_NULL: | |
46fc3d4c | 967 | sv_catpv(t, "UNDEF"); |
96827780 | 968 | goto finish; |
a0d0e21e | 969 | case SVt_IV: |
46fc3d4c | 970 | sv_catpv(t, "IV"); |
a0d0e21e LW |
971 | break; |
972 | case SVt_NV: | |
46fc3d4c | 973 | sv_catpv(t, "NV"); |
a0d0e21e LW |
974 | break; |
975 | case SVt_RV: | |
46fc3d4c | 976 | sv_catpv(t, "RV"); |
a0d0e21e LW |
977 | break; |
978 | case SVt_PV: | |
46fc3d4c | 979 | sv_catpv(t, "PV"); |
a0d0e21e LW |
980 | break; |
981 | case SVt_PVIV: | |
46fc3d4c | 982 | sv_catpv(t, "PVIV"); |
a0d0e21e LW |
983 | break; |
984 | case SVt_PVNV: | |
46fc3d4c | 985 | sv_catpv(t, "PVNV"); |
a0d0e21e LW |
986 | break; |
987 | case SVt_PVMG: | |
46fc3d4c | 988 | sv_catpv(t, "PVMG"); |
a0d0e21e LW |
989 | break; |
990 | case SVt_PVLV: | |
46fc3d4c | 991 | sv_catpv(t, "PVLV"); |
a0d0e21e LW |
992 | break; |
993 | case SVt_PVAV: | |
46fc3d4c | 994 | sv_catpv(t, "AV"); |
a0d0e21e LW |
995 | break; |
996 | case SVt_PVHV: | |
46fc3d4c | 997 | sv_catpv(t, "HV"); |
a0d0e21e LW |
998 | break; |
999 | case SVt_PVCV: | |
1000 | if (CvGV(sv)) | |
46fc3d4c | 1001 | sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv))); |
a0d0e21e | 1002 | else |
46fc3d4c | 1003 | sv_catpv(t, "CV()"); |
a0d0e21e LW |
1004 | goto finish; |
1005 | case SVt_PVGV: | |
46fc3d4c | 1006 | sv_catpv(t, "GV"); |
a0d0e21e LW |
1007 | break; |
1008 | case SVt_PVBM: | |
46fc3d4c | 1009 | sv_catpv(t, "BM"); |
a0d0e21e LW |
1010 | break; |
1011 | case SVt_PVFM: | |
46fc3d4c | 1012 | sv_catpv(t, "FM"); |
a0d0e21e LW |
1013 | break; |
1014 | case SVt_PVIO: | |
46fc3d4c | 1015 | sv_catpv(t, "IO"); |
a0d0e21e | 1016 | break; |
79072805 | 1017 | } |
79072805 | 1018 | |
a0d0e21e | 1019 | if (SvPOKp(sv)) { |
463ee0b2 | 1020 | if (!SvPVX(sv)) |
46fc3d4c | 1021 | sv_catpv(t, "(null)"); |
79072805 | 1022 | if (SvOOK(sv)) |
46fc3d4c | 1023 | sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv)); |
79072805 | 1024 | else |
46fc3d4c | 1025 | sv_catpvf(t, "(\"%.127s\")",SvPVX(sv)); |
79072805 | 1026 | } |
bbce6d69 | 1027 | else if (SvNOKp(sv)) { |
36477c24 | 1028 | SET_NUMERIC_STANDARD(); |
46fc3d4c | 1029 | sv_catpvf(t, "(%g)",SvNVX(sv)); |
bbce6d69 | 1030 | } |
a0d0e21e | 1031 | else if (SvIOKp(sv)) |
46fc3d4c | 1032 | sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); |
79072805 | 1033 | else |
46fc3d4c | 1034 | sv_catpv(t, "()"); |
a0d0e21e LW |
1035 | |
1036 | finish: | |
1037 | if (unref) { | |
a0d0e21e | 1038 | while (unref--) |
46fc3d4c | 1039 | sv_catpv(t, ")"); |
a0d0e21e | 1040 | } |
46fc3d4c | 1041 | return SvPV(t, na); |
79072805 | 1042 | } |
a0d0e21e | 1043 | #endif |
79072805 LW |
1044 | |
1045 | int | |
1046 | sv_backoff(sv) | |
1047 | register SV *sv; | |
1048 | { | |
1049 | assert(SvOOK(sv)); | |
463ee0b2 LW |
1050 | if (SvIVX(sv)) { |
1051 | char *s = SvPVX(sv); | |
1052 | SvLEN(sv) += SvIVX(sv); | |
1053 | SvPVX(sv) -= SvIVX(sv); | |
79072805 | 1054 | SvIV_set(sv, 0); |
463ee0b2 | 1055 | Move(s, SvPVX(sv), SvCUR(sv)+1, char); |
79072805 LW |
1056 | } |
1057 | SvFLAGS(sv) &= ~SVf_OOK; | |
a0d0e21e | 1058 | return 0; |
79072805 LW |
1059 | } |
1060 | ||
1061 | char * | |
1062 | sv_grow(sv,newlen) | |
1063 | register SV *sv; | |
1064 | #ifndef DOSISH | |
1065 | register I32 newlen; | |
1066 | #else | |
1067 | unsigned long newlen; | |
1068 | #endif | |
1069 | { | |
1070 | register char *s; | |
1071 | ||
55497cff | 1072 | #ifdef HAS_64K_LIMIT |
79072805 | 1073 | if (newlen >= 0x10000) { |
d1bf51dd | 1074 | PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); |
79072805 LW |
1075 | my_exit(1); |
1076 | } | |
55497cff | 1077 | #endif /* HAS_64K_LIMIT */ |
a0d0e21e LW |
1078 | if (SvROK(sv)) |
1079 | sv_unref(sv); | |
79072805 LW |
1080 | if (SvTYPE(sv) < SVt_PV) { |
1081 | sv_upgrade(sv, SVt_PV); | |
463ee0b2 | 1082 | s = SvPVX(sv); |
79072805 LW |
1083 | } |
1084 | else if (SvOOK(sv)) { /* pv is offset? */ | |
1085 | sv_backoff(sv); | |
463ee0b2 | 1086 | s = SvPVX(sv); |
79072805 LW |
1087 | if (newlen > SvLEN(sv)) |
1088 | newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ | |
1089 | } | |
1090 | else | |
463ee0b2 | 1091 | s = SvPVX(sv); |
79072805 | 1092 | if (newlen > SvLEN(sv)) { /* need more room? */ |
85e6fe83 | 1093 | if (SvLEN(sv) && s) |
79072805 LW |
1094 | Renew(s,newlen,char); |
1095 | else | |
1096 | New(703,s,newlen,char); | |
1097 | SvPV_set(sv, s); | |
1098 | SvLEN_set(sv, newlen); | |
1099 | } | |
1100 | return s; | |
1101 | } | |
1102 | ||
1103 | void | |
1104 | sv_setiv(sv,i) | |
1105 | register SV *sv; | |
a0d0e21e | 1106 | IV i; |
79072805 | 1107 | { |
0f15f207 | 1108 | sv_check_thinkfirst(sv); |
463ee0b2 LW |
1109 | switch (SvTYPE(sv)) { |
1110 | case SVt_NULL: | |
79072805 | 1111 | sv_upgrade(sv, SVt_IV); |
463ee0b2 LW |
1112 | break; |
1113 | case SVt_NV: | |
1114 | sv_upgrade(sv, SVt_PVNV); | |
1115 | break; | |
ed6116ce | 1116 | case SVt_RV: |
463ee0b2 | 1117 | case SVt_PV: |
79072805 | 1118 | sv_upgrade(sv, SVt_PVIV); |
463ee0b2 | 1119 | break; |
a0d0e21e LW |
1120 | |
1121 | case SVt_PVGV: | |
1122 | if (SvFAKE(sv)) { | |
1123 | sv_unglob(sv); | |
1124 | break; | |
1125 | } | |
1126 | /* FALL THROUGH */ | |
1127 | case SVt_PVAV: | |
1128 | case SVt_PVHV: | |
1129 | case SVt_PVCV: | |
1130 | case SVt_PVFM: | |
1131 | case SVt_PVIO: | |
11343788 MB |
1132 | { |
1133 | dTHR; | |
1134 | croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), | |
5dc0d613 | 1135 | op_desc[op->op_type]); |
11343788 | 1136 | } |
463ee0b2 | 1137 | } |
a0d0e21e | 1138 | (void)SvIOK_only(sv); /* validate number */ |
a5f75d66 | 1139 | SvIVX(sv) = i; |
463ee0b2 | 1140 | SvTAINT(sv); |
79072805 LW |
1141 | } |
1142 | ||
1143 | void | |
55497cff | 1144 | sv_setuv(sv,u) |
1145 | register SV *sv; | |
1146 | UV u; | |
1147 | { | |
1148 | if (u <= IV_MAX) | |
1149 | sv_setiv(sv, u); | |
1150 | else | |
1151 | sv_setnv(sv, (double)u); | |
1152 | } | |
1153 | ||
1154 | void | |
79072805 LW |
1155 | sv_setnv(sv,num) |
1156 | register SV *sv; | |
1157 | double num; | |
1158 | { | |
0f15f207 | 1159 | sv_check_thinkfirst(sv); |
a0d0e21e LW |
1160 | switch (SvTYPE(sv)) { |
1161 | case SVt_NULL: | |
1162 | case SVt_IV: | |
79072805 | 1163 | sv_upgrade(sv, SVt_NV); |
a0d0e21e LW |
1164 | break; |
1165 | case SVt_NV: | |
1166 | case SVt_RV: | |
1167 | case SVt_PV: | |
1168 | case SVt_PVIV: | |
79072805 | 1169 | sv_upgrade(sv, SVt_PVNV); |
a0d0e21e LW |
1170 | /* FALL THROUGH */ |
1171 | case SVt_PVNV: | |
1172 | case SVt_PVMG: | |
1173 | case SVt_PVBM: | |
1174 | case SVt_PVLV: | |
1175 | if (SvOOK(sv)) | |
1176 | (void)SvOOK_off(sv); | |
1177 | break; | |
1178 | case SVt_PVGV: | |
1179 | if (SvFAKE(sv)) { | |
1180 | sv_unglob(sv); | |
1181 | break; | |
1182 | } | |
1183 | /* FALL THROUGH */ | |
1184 | case SVt_PVAV: | |
1185 | case SVt_PVHV: | |
1186 | case SVt_PVCV: | |
1187 | case SVt_PVFM: | |
1188 | case SVt_PVIO: | |
11343788 MB |
1189 | { |
1190 | dTHR; | |
1191 | croak("Can't coerce %s to number in %s", sv_reftype(sv,0), | |
1192 | op_name[op->op_type]); | |
1193 | } | |
79072805 | 1194 | } |
463ee0b2 | 1195 | SvNVX(sv) = num; |
a0d0e21e | 1196 | (void)SvNOK_only(sv); /* validate number */ |
463ee0b2 | 1197 | SvTAINT(sv); |
79072805 LW |
1198 | } |
1199 | ||
a0d0e21e LW |
1200 | static void |
1201 | not_a_number(sv) | |
1202 | SV *sv; | |
1203 | { | |
11343788 | 1204 | dTHR; |
a0d0e21e LW |
1205 | char tmpbuf[64]; |
1206 | char *d = tmpbuf; | |
1207 | char *s; | |
dc28f22b GA |
1208 | char *limit = tmpbuf + sizeof(tmpbuf) - 8; |
1209 | /* each *s can expand to 4 chars + "...\0", | |
1210 | i.e. need room for 8 chars */ | |
a0d0e21e | 1211 | |
dc28f22b | 1212 | for (s = SvPVX(sv); *s && d < limit; s++) { |
bbce6d69 | 1213 | int ch = *s & 0xFF; |
1214 | if (ch & 128 && !isPRINT_LC(ch)) { | |
a0d0e21e LW |
1215 | *d++ = 'M'; |
1216 | *d++ = '-'; | |
1217 | ch &= 127; | |
1218 | } | |
bbce6d69 | 1219 | if (ch == '\n') { |
1220 | *d++ = '\\'; | |
1221 | *d++ = 'n'; | |
1222 | } | |
1223 | else if (ch == '\r') { | |
1224 | *d++ = '\\'; | |
1225 | *d++ = 'r'; | |
1226 | } | |
1227 | else if (ch == '\f') { | |
1228 | *d++ = '\\'; | |
1229 | *d++ = 'f'; | |
1230 | } | |
1231 | else if (ch == '\\') { | |
1232 | *d++ = '\\'; | |
1233 | *d++ = '\\'; | |
1234 | } | |
1235 | else if (isPRINT_LC(ch)) | |
a0d0e21e LW |
1236 | *d++ = ch; |
1237 | else { | |
1238 | *d++ = '^'; | |
bbce6d69 | 1239 | *d++ = toCTRL(ch); |
a0d0e21e LW |
1240 | } |
1241 | } | |
1242 | if (*s) { | |
1243 | *d++ = '.'; | |
1244 | *d++ = '.'; | |
1245 | *d++ = '.'; | |
1246 | } | |
1247 | *d = '\0'; | |
1248 | ||
1249 | if (op) | |
c07a80fd | 1250 | warn("Argument \"%s\" isn't numeric in %s", tmpbuf, |
a0d0e21e LW |
1251 | op_name[op->op_type]); |
1252 | else | |
1253 | warn("Argument \"%s\" isn't numeric", tmpbuf); | |
1254 | } | |
1255 | ||
1256 | IV | |
79072805 LW |
1257 | sv_2iv(sv) |
1258 | register SV *sv; | |
1259 | { | |
1260 | if (!sv) | |
1261 | return 0; | |
8990e307 | 1262 | if (SvGMAGICAL(sv)) { |
463ee0b2 LW |
1263 | mg_get(sv); |
1264 | if (SvIOKp(sv)) | |
1265 | return SvIVX(sv); | |
748a9306 LW |
1266 | if (SvNOKp(sv)) { |
1267 | if (SvNVX(sv) < 0.0) | |
1268 | return I_V(SvNVX(sv)); | |
1269 | else | |
5d94fbed | 1270 | return (IV) U_V(SvNVX(sv)); |
748a9306 | 1271 | } |
36477c24 | 1272 | if (SvPOKp(sv) && SvLEN(sv)) |
1273 | return asIV(sv); | |
3fe9a6f1 | 1274 | if (!SvROK(sv)) { |
e858de61 | 1275 | dTHR; /* just for localizing */ |
3fe9a6f1 | 1276 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
1277 | warn(warn_uninit); | |
36477c24 | 1278 | return 0; |
3fe9a6f1 | 1279 | } |
463ee0b2 | 1280 | } |
ed6116ce | 1281 | if (SvTHINKFIRST(sv)) { |
a0d0e21e LW |
1282 | if (SvROK(sv)) { |
1283 | #ifdef OVERLOAD | |
1284 | SV* tmpstr; | |
1285 | if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) | |
1286 | return SvIV(tmpstr); | |
1287 | #endif /* OVERLOAD */ | |
1288 | return (IV)SvRV(sv); | |
1289 | } | |
ed6116ce | 1290 | if (SvREADONLY(sv)) { |
748a9306 LW |
1291 | if (SvNOKp(sv)) { |
1292 | if (SvNVX(sv) < 0.0) | |
1293 | return I_V(SvNVX(sv)); | |
1294 | else | |
5d94fbed | 1295 | return (IV) U_V(SvNVX(sv)); |
748a9306 | 1296 | } |
36477c24 | 1297 | if (SvPOKp(sv) && SvLEN(sv)) |
1298 | return asIV(sv); | |
ed6116ce | 1299 | if (dowarn) |
8990e307 | 1300 | warn(warn_uninit); |
ed6116ce LW |
1301 | return 0; |
1302 | } | |
79072805 | 1303 | } |
463ee0b2 | 1304 | switch (SvTYPE(sv)) { |
463ee0b2 | 1305 | case SVt_NULL: |
79072805 | 1306 | sv_upgrade(sv, SVt_IV); |
8ebc5c01 | 1307 | break; |
463ee0b2 | 1308 | case SVt_PV: |
79072805 | 1309 | sv_upgrade(sv, SVt_PVIV); |
463ee0b2 LW |
1310 | break; |
1311 | case SVt_NV: | |
1312 | sv_upgrade(sv, SVt_PVNV); | |
1313 | break; | |
1314 | } | |
748a9306 | 1315 | if (SvNOKp(sv)) { |
a5f75d66 | 1316 | (void)SvIOK_on(sv); |
748a9306 LW |
1317 | if (SvNVX(sv) < 0.0) |
1318 | SvIVX(sv) = I_V(SvNVX(sv)); | |
1319 | else | |
ff68c719 | 1320 | SvUVX(sv) = U_V(SvNVX(sv)); |
748a9306 LW |
1321 | } |
1322 | else if (SvPOKp(sv) && SvLEN(sv)) { | |
a5f75d66 | 1323 | (void)SvIOK_on(sv); |
36477c24 | 1324 | SvIVX(sv) = asIV(sv); |
93a17b20 | 1325 | } |
79072805 | 1326 | else { |
11343788 | 1327 | dTHR; |
91bba347 | 1328 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
8990e307 | 1329 | warn(warn_uninit); |
a0d0e21e | 1330 | return 0; |
79072805 | 1331 | } |
760ac839 | 1332 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", |
a0d0e21e | 1333 | (unsigned long)sv,(long)SvIVX(sv))); |
463ee0b2 | 1334 | return SvIVX(sv); |
79072805 LW |
1335 | } |
1336 | ||
ff68c719 | 1337 | UV |
1338 | sv_2uv(sv) | |
1339 | register SV *sv; | |
1340 | { | |
1341 | if (!sv) | |
1342 | return 0; | |
1343 | if (SvGMAGICAL(sv)) { | |
1344 | mg_get(sv); | |
1345 | if (SvIOKp(sv)) | |
1346 | return SvUVX(sv); | |
1347 | if (SvNOKp(sv)) | |
1348 | return U_V(SvNVX(sv)); | |
36477c24 | 1349 | if (SvPOKp(sv) && SvLEN(sv)) |
1350 | return asUV(sv); | |
3fe9a6f1 | 1351 | if (!SvROK(sv)) { |
e858de61 | 1352 | dTHR; /* just for localizing */ |
3fe9a6f1 | 1353 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
1354 | warn(warn_uninit); | |
36477c24 | 1355 | return 0; |
3fe9a6f1 | 1356 | } |
ff68c719 | 1357 | } |
1358 | if (SvTHINKFIRST(sv)) { | |
1359 | if (SvROK(sv)) { | |
1360 | #ifdef OVERLOAD | |
1361 | SV* tmpstr; | |
1362 | if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) | |
1363 | return SvUV(tmpstr); | |
1364 | #endif /* OVERLOAD */ | |
1365 | return (UV)SvRV(sv); | |
1366 | } | |
1367 | if (SvREADONLY(sv)) { | |
1368 | if (SvNOKp(sv)) { | |
1369 | return U_V(SvNVX(sv)); | |
1370 | } | |
36477c24 | 1371 | if (SvPOKp(sv) && SvLEN(sv)) |
1372 | return asUV(sv); | |
ff68c719 | 1373 | if (dowarn) |
1374 | warn(warn_uninit); | |
1375 | return 0; | |
1376 | } | |
1377 | } | |
1378 | switch (SvTYPE(sv)) { | |
1379 | case SVt_NULL: | |
1380 | sv_upgrade(sv, SVt_IV); | |
8ebc5c01 | 1381 | break; |
ff68c719 | 1382 | case SVt_PV: |
1383 | sv_upgrade(sv, SVt_PVIV); | |
1384 | break; | |
1385 | case SVt_NV: | |
1386 | sv_upgrade(sv, SVt_PVNV); | |
1387 | break; | |
1388 | } | |
1389 | if (SvNOKp(sv)) { | |
1390 | (void)SvIOK_on(sv); | |
1391 | SvUVX(sv) = U_V(SvNVX(sv)); | |
1392 | } | |
1393 | else if (SvPOKp(sv) && SvLEN(sv)) { | |
ff68c719 | 1394 | (void)SvIOK_on(sv); |
36477c24 | 1395 | SvUVX(sv) = asUV(sv); |
ff68c719 | 1396 | } |
1397 | else { | |
e858de61 | 1398 | dTHR; /* just for localizing */ |
ff68c719 | 1399 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
1400 | warn(warn_uninit); | |
1401 | return 0; | |
1402 | } | |
1403 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", | |
1404 | (unsigned long)sv,SvUVX(sv))); | |
1405 | return SvUVX(sv); | |
1406 | } | |
1407 | ||
79072805 LW |
1408 | double |
1409 | sv_2nv(sv) | |
1410 | register SV *sv; | |
1411 | { | |
1412 | if (!sv) | |
1413 | return 0.0; | |
8990e307 | 1414 | if (SvGMAGICAL(sv)) { |
463ee0b2 LW |
1415 | mg_get(sv); |
1416 | if (SvNOKp(sv)) | |
1417 | return SvNVX(sv); | |
a0d0e21e | 1418 | if (SvPOKp(sv) && SvLEN(sv)) { |
748a9306 | 1419 | if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) |
a0d0e21e | 1420 | not_a_number(sv); |
36477c24 | 1421 | SET_NUMERIC_STANDARD(); |
463ee0b2 | 1422 | return atof(SvPVX(sv)); |
a0d0e21e | 1423 | } |
463ee0b2 LW |
1424 | if (SvIOKp(sv)) |
1425 | return (double)SvIVX(sv); | |
16d20bd9 | 1426 | if (!SvROK(sv)) { |
e858de61 | 1427 | dTHR; /* just for localizing */ |
3fe9a6f1 | 1428 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
1429 | warn(warn_uninit); | |
16d20bd9 AD |
1430 | return 0; |
1431 | } | |
463ee0b2 | 1432 | } |
ed6116ce | 1433 | if (SvTHINKFIRST(sv)) { |
a0d0e21e LW |
1434 | if (SvROK(sv)) { |
1435 | #ifdef OVERLOAD | |
1436 | SV* tmpstr; | |
1437 | if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) | |
1438 | return SvNV(tmpstr); | |
1439 | #endif /* OVERLOAD */ | |
1440 | return (double)(unsigned long)SvRV(sv); | |
1441 | } | |
ed6116ce | 1442 | if (SvREADONLY(sv)) { |
748a9306 LW |
1443 | if (SvPOKp(sv) && SvLEN(sv)) { |
1444 | if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) | |
a0d0e21e | 1445 | not_a_number(sv); |
36477c24 | 1446 | SET_NUMERIC_STANDARD(); |
ed6116ce | 1447 | return atof(SvPVX(sv)); |
a0d0e21e | 1448 | } |
748a9306 | 1449 | if (SvIOKp(sv)) |
8990e307 | 1450 | return (double)SvIVX(sv); |
ed6116ce | 1451 | if (dowarn) |
8990e307 | 1452 | warn(warn_uninit); |
ed6116ce LW |
1453 | return 0.0; |
1454 | } | |
79072805 LW |
1455 | } |
1456 | if (SvTYPE(sv) < SVt_NV) { | |
463ee0b2 LW |
1457 | if (SvTYPE(sv) == SVt_IV) |
1458 | sv_upgrade(sv, SVt_PVNV); | |
1459 | else | |
1460 | sv_upgrade(sv, SVt_NV); | |
36477c24 | 1461 | DEBUG_c(SET_NUMERIC_STANDARD()); |
bbce6d69 | 1462 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
1463 | "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); | |
79072805 LW |
1464 | } |
1465 | else if (SvTYPE(sv) < SVt_PVNV) | |
1466 | sv_upgrade(sv, SVt_PVNV); | |
748a9306 LW |
1467 | if (SvIOKp(sv) && |
1468 | (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) | |
93a17b20 | 1469 | { |
463ee0b2 | 1470 | SvNVX(sv) = (double)SvIVX(sv); |
93a17b20 | 1471 | } |
748a9306 LW |
1472 | else if (SvPOKp(sv) && SvLEN(sv)) { |
1473 | if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) | |
a0d0e21e | 1474 | not_a_number(sv); |
36477c24 | 1475 | SET_NUMERIC_STANDARD(); |
463ee0b2 | 1476 | SvNVX(sv) = atof(SvPVX(sv)); |
93a17b20 | 1477 | } |
79072805 | 1478 | else { |
11343788 | 1479 | dTHR; |
91bba347 | 1480 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
8990e307 | 1481 | warn(warn_uninit); |
a0d0e21e | 1482 | return 0.0; |
79072805 LW |
1483 | } |
1484 | SvNOK_on(sv); | |
36477c24 | 1485 | DEBUG_c(SET_NUMERIC_STANDARD()); |
bbce6d69 | 1486 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
1487 | "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); | |
463ee0b2 | 1488 | return SvNVX(sv); |
79072805 LW |
1489 | } |
1490 | ||
36477c24 | 1491 | static IV |
1492 | asIV(sv) | |
1493 | SV *sv; | |
1494 | { | |
1495 | I32 numtype = looks_like_number(sv); | |
1496 | double d; | |
1497 | ||
1498 | if (numtype == 1) | |
1499 | return atol(SvPVX(sv)); | |
1500 | if (!numtype && dowarn) | |
1501 | not_a_number(sv); | |
1502 | SET_NUMERIC_STANDARD(); | |
1503 | d = atof(SvPVX(sv)); | |
1504 | if (d < 0.0) | |
1505 | return I_V(d); | |
1506 | else | |
1507 | return (IV) U_V(d); | |
1508 | } | |
1509 | ||
1510 | static UV | |
1511 | asUV(sv) | |
1512 | SV *sv; | |
1513 | { | |
1514 | I32 numtype = looks_like_number(sv); | |
1515 | ||
84902520 | 1516 | #ifdef HAS_STRTOUL |
36477c24 | 1517 | if (numtype == 1) |
84902520 TB |
1518 | return strtoul(SvPVX(sv), Null(char**), 10); |
1519 | #endif | |
36477c24 | 1520 | if (!numtype && dowarn) |
1521 | not_a_number(sv); | |
1522 | SET_NUMERIC_STANDARD(); | |
1523 | return U_V(atof(SvPVX(sv))); | |
1524 | } | |
1525 | ||
1526 | I32 | |
1527 | looks_like_number(sv) | |
1528 | SV *sv; | |
1529 | { | |
1530 | register char *s; | |
1531 | register char *send; | |
1532 | register char *sbegin; | |
ff0cee69 | 1533 | I32 numtype; |
36477c24 | 1534 | STRLEN len; |
1535 | ||
1536 | if (SvPOK(sv)) { | |
1537 | sbegin = SvPVX(sv); | |
1538 | len = SvCUR(sv); | |
1539 | } | |
1540 | else if (SvPOKp(sv)) | |
1541 | sbegin = SvPV(sv, len); | |
1542 | else | |
1543 | return 1; | |
1544 | send = sbegin + len; | |
1545 | ||
1546 | s = sbegin; | |
1547 | while (isSPACE(*s)) | |
1548 | s++; | |
36477c24 | 1549 | if (*s == '+' || *s == '-') |
1550 | s++; | |
ff0cee69 | 1551 | |
1552 | /* next must be digit or '.' */ | |
1553 | if (isDIGIT(*s)) { | |
1554 | do { | |
1555 | s++; | |
1556 | } while (isDIGIT(*s)); | |
1557 | if (*s == '.') { | |
1558 | s++; | |
1559 | while (isDIGIT(*s)) /* optional digits after "." */ | |
1560 | s++; | |
1561 | } | |
36477c24 | 1562 | } |
ff0cee69 | 1563 | else if (*s == '.') { |
1564 | s++; | |
1565 | /* no digits before '.' means we need digits after it */ | |
1566 | if (isDIGIT(*s)) { | |
1567 | do { | |
1568 | s++; | |
1569 | } while (isDIGIT(*s)); | |
1570 | } | |
1571 | else | |
1572 | return 0; | |
1573 | } | |
1574 | else | |
1575 | return 0; | |
1576 | ||
1577 | /* | |
1578 | * we return 1 if the number can be converted to _integer_ with atol() | |
1579 | * and 2 if you need (int)atof(). | |
1580 | */ | |
1581 | numtype = 1; | |
1582 | ||
1583 | /* we can have an optional exponent part */ | |
36477c24 | 1584 | if (*s == 'e' || *s == 'E') { |
1585 | numtype = 2; | |
1586 | s++; | |
1587 | if (*s == '+' || *s == '-') | |
1588 | s++; | |
ff0cee69 | 1589 | if (isDIGIT(*s)) { |
1590 | do { | |
1591 | s++; | |
1592 | } while (isDIGIT(*s)); | |
1593 | } | |
1594 | else | |
1595 | return 0; | |
36477c24 | 1596 | } |
1597 | while (isSPACE(*s)) | |
1598 | s++; | |
1599 | if (s >= send) | |
1600 | return numtype; | |
1601 | if (len == 10 && memEQ(sbegin, "0 but true", 10)) | |
1602 | return 1; | |
1603 | return 0; | |
1604 | } | |
1605 | ||
79072805 | 1606 | char * |
463ee0b2 | 1607 | sv_2pv(sv, lp) |
79072805 | 1608 | register SV *sv; |
463ee0b2 | 1609 | STRLEN *lp; |
79072805 LW |
1610 | { |
1611 | register char *s; | |
1612 | int olderrno; | |
46fc3d4c | 1613 | SV *tsv; |
96827780 | 1614 | char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ |
79072805 | 1615 | |
463ee0b2 LW |
1616 | if (!sv) { |
1617 | *lp = 0; | |
1618 | return ""; | |
1619 | } | |
8990e307 | 1620 | if (SvGMAGICAL(sv)) { |
463ee0b2 LW |
1621 | mg_get(sv); |
1622 | if (SvPOKp(sv)) { | |
1623 | *lp = SvCUR(sv); | |
1624 | return SvPVX(sv); | |
1625 | } | |
1626 | if (SvIOKp(sv)) { | |
96827780 | 1627 | (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); |
46fc3d4c | 1628 | tsv = Nullsv; |
a0d0e21e | 1629 | goto tokensave; |
463ee0b2 LW |
1630 | } |
1631 | if (SvNOKp(sv)) { | |
36477c24 | 1632 | SET_NUMERIC_STANDARD(); |
96827780 | 1633 | Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); |
46fc3d4c | 1634 | tsv = Nullsv; |
a0d0e21e | 1635 | goto tokensave; |
463ee0b2 | 1636 | } |
16d20bd9 | 1637 | if (!SvROK(sv)) { |
e858de61 | 1638 | dTHR; /* just for localizing */ |
3fe9a6f1 | 1639 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
1640 | warn(warn_uninit); | |
16d20bd9 AD |
1641 | *lp = 0; |
1642 | return ""; | |
1643 | } | |
463ee0b2 | 1644 | } |
ed6116ce LW |
1645 | if (SvTHINKFIRST(sv)) { |
1646 | if (SvROK(sv)) { | |
a0d0e21e LW |
1647 | #ifdef OVERLOAD |
1648 | SV* tmpstr; | |
1649 | if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) | |
1650 | return SvPV(tmpstr,*lp); | |
1651 | #endif /* OVERLOAD */ | |
ed6116ce LW |
1652 | sv = (SV*)SvRV(sv); |
1653 | if (!sv) | |
1654 | s = "NULLREF"; | |
1655 | else { | |
1656 | switch (SvTYPE(sv)) { | |
1657 | case SVt_NULL: | |
1658 | case SVt_IV: | |
1659 | case SVt_NV: | |
1660 | case SVt_RV: | |
1661 | case SVt_PV: | |
1662 | case SVt_PVIV: | |
1663 | case SVt_PVNV: | |
1664 | case SVt_PVBM: | |
1665 | case SVt_PVMG: s = "SCALAR"; break; | |
1666 | case SVt_PVLV: s = "LVALUE"; break; | |
1667 | case SVt_PVAV: s = "ARRAY"; break; | |
1668 | case SVt_PVHV: s = "HASH"; break; | |
1669 | case SVt_PVCV: s = "CODE"; break; | |
1670 | case SVt_PVGV: s = "GLOB"; break; | |
1671 | case SVt_PVFM: s = "FORMATLINE"; break; | |
36477c24 | 1672 | case SVt_PVIO: s = "IO"; break; |
ed6116ce LW |
1673 | default: s = "UNKNOWN"; break; |
1674 | } | |
46fc3d4c | 1675 | tsv = NEWSV(0,0); |
ed6116ce | 1676 | if (SvOBJECT(sv)) |
46fc3d4c | 1677 | sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); |
ed6116ce | 1678 | else |
46fc3d4c | 1679 | sv_setpv(tsv, s); |
1680 | sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); | |
a0d0e21e | 1681 | goto tokensaveref; |
463ee0b2 | 1682 | } |
ed6116ce LW |
1683 | *lp = strlen(s); |
1684 | return s; | |
79072805 | 1685 | } |
ed6116ce | 1686 | if (SvREADONLY(sv)) { |
748a9306 | 1687 | if (SvNOKp(sv)) { |
36477c24 | 1688 | SET_NUMERIC_STANDARD(); |
96827780 | 1689 | Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); |
46fc3d4c | 1690 | tsv = Nullsv; |
a0d0e21e | 1691 | goto tokensave; |
ed6116ce | 1692 | } |
8bb9dbe4 | 1693 | if (SvIOKp(sv)) { |
96827780 | 1694 | (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); |
46fc3d4c | 1695 | tsv = Nullsv; |
8bb9dbe4 LW |
1696 | goto tokensave; |
1697 | } | |
ed6116ce | 1698 | if (dowarn) |
8990e307 | 1699 | warn(warn_uninit); |
ed6116ce LW |
1700 | *lp = 0; |
1701 | return ""; | |
79072805 | 1702 | } |
79072805 LW |
1703 | } |
1704 | if (!SvUPGRADE(sv, SVt_PV)) | |
1705 | return 0; | |
748a9306 | 1706 | if (SvNOKp(sv)) { |
79072805 LW |
1707 | if (SvTYPE(sv) < SVt_PVNV) |
1708 | sv_upgrade(sv, SVt_PVNV); | |
1709 | SvGROW(sv, 28); | |
463ee0b2 | 1710 | s = SvPVX(sv); |
79072805 | 1711 | olderrno = errno; /* some Xenix systems wipe out errno here */ |
79072805 | 1712 | #ifdef apollo |
463ee0b2 | 1713 | if (SvNVX(sv) == 0.0) |
79072805 LW |
1714 | (void)strcpy(s,"0"); |
1715 | else | |
1716 | #endif /*apollo*/ | |
bbce6d69 | 1717 | { |
36477c24 | 1718 | SET_NUMERIC_STANDARD(); |
a0d0e21e | 1719 | Gconvert(SvNVX(sv), DBL_DIG, 0, s); |
bbce6d69 | 1720 | } |
79072805 | 1721 | errno = olderrno; |
a0d0e21e LW |
1722 | #ifdef FIXNEGATIVEZERO |
1723 | if (*s == '-' && s[1] == '0' && !s[2]) | |
1724 | strcpy(s,"0"); | |
1725 | #endif | |
79072805 LW |
1726 | while (*s) s++; |
1727 | #ifdef hcx | |
1728 | if (s[-1] == '.') | |
46fc3d4c | 1729 | *--s = '\0'; |
79072805 LW |
1730 | #endif |
1731 | } | |
748a9306 | 1732 | else if (SvIOKp(sv)) { |
64f14228 | 1733 | U32 oldIOK = SvIOK(sv); |
79072805 LW |
1734 | if (SvTYPE(sv) < SVt_PVIV) |
1735 | sv_upgrade(sv, SVt_PVIV); | |
79072805 | 1736 | olderrno = errno; /* some Xenix systems wipe out errno here */ |
84902520 | 1737 | sv_setpviv(sv, SvIVX(sv)); |
79072805 | 1738 | errno = olderrno; |
46fc3d4c | 1739 | s = SvEND(sv); |
64f14228 GA |
1740 | if (oldIOK) |
1741 | SvIOK_on(sv); | |
1742 | else | |
1743 | SvIOKp_on(sv); | |
79072805 LW |
1744 | } |
1745 | else { | |
11343788 | 1746 | dTHR; |
91bba347 | 1747 | if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) |
8990e307 | 1748 | warn(warn_uninit); |
a0d0e21e LW |
1749 | *lp = 0; |
1750 | return ""; | |
79072805 | 1751 | } |
463ee0b2 LW |
1752 | *lp = s - SvPVX(sv); |
1753 | SvCUR_set(sv, *lp); | |
79072805 | 1754 | SvPOK_on(sv); |
760ac839 | 1755 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); |
463ee0b2 | 1756 | return SvPVX(sv); |
a0d0e21e LW |
1757 | |
1758 | tokensave: | |
1759 | if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ | |
1760 | /* Sneaky stuff here */ | |
1761 | ||
1762 | tokensaveref: | |
46fc3d4c | 1763 | if (!tsv) |
96827780 | 1764 | tsv = newSVpv(tmpbuf, 0); |
46fc3d4c | 1765 | sv_2mortal(tsv); |
1766 | *lp = SvCUR(tsv); | |
1767 | return SvPVX(tsv); | |
a0d0e21e LW |
1768 | } |
1769 | else { | |
1770 | STRLEN len; | |
46fc3d4c | 1771 | char *t; |
1772 | ||
1773 | if (tsv) { | |
1774 | sv_2mortal(tsv); | |
1775 | t = SvPVX(tsv); | |
1776 | len = SvCUR(tsv); | |
1777 | } | |
1778 | else { | |
96827780 MB |
1779 | t = tmpbuf; |
1780 | len = strlen(tmpbuf); | |
46fc3d4c | 1781 | } |
a0d0e21e | 1782 | #ifdef FIXNEGATIVEZERO |
46fc3d4c | 1783 | if (len == 2 && t[0] == '-' && t[1] == '0') { |
1784 | t = "0"; | |
1785 | len = 1; | |
1786 | } | |
a0d0e21e LW |
1787 | #endif |
1788 | (void)SvUPGRADE(sv, SVt_PV); | |
46fc3d4c | 1789 | *lp = len; |
a0d0e21e LW |
1790 | s = SvGROW(sv, len + 1); |
1791 | SvCUR_set(sv, len); | |
46fc3d4c | 1792 | (void)strcpy(s, t); |
6bf554b4 | 1793 | SvPOKp_on(sv); |
a0d0e21e LW |
1794 | return s; |
1795 | } | |
463ee0b2 LW |
1796 | } |
1797 | ||
1798 | /* This function is only called on magical items */ | |
1799 | bool | |
1800 | sv_2bool(sv) | |
1801 | register SV *sv; | |
1802 | { | |
8990e307 | 1803 | if (SvGMAGICAL(sv)) |
463ee0b2 LW |
1804 | mg_get(sv); |
1805 | ||
a0d0e21e LW |
1806 | if (!SvOK(sv)) |
1807 | return 0; | |
1808 | if (SvROK(sv)) { | |
1809 | #ifdef OVERLOAD | |
1810 | { | |
11343788 | 1811 | dTHR; |
a0d0e21e LW |
1812 | SV* tmpsv; |
1813 | if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) | |
1814 | return SvTRUE(tmpsv); | |
1815 | } | |
1816 | #endif /* OVERLOAD */ | |
1817 | return SvRV(sv) != 0; | |
1818 | } | |
463ee0b2 | 1819 | if (SvPOKp(sv)) { |
11343788 MB |
1820 | register XPV* Xpvtmp; |
1821 | if ((Xpvtmp = (XPV*)SvANY(sv)) && | |
1822 | (*Xpvtmp->xpv_pv > '0' || | |
1823 | Xpvtmp->xpv_cur > 1 || | |
1824 | (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0'))) | |
463ee0b2 LW |
1825 | return 1; |
1826 | else | |
1827 | return 0; | |
1828 | } | |
1829 | else { | |
1830 | if (SvIOKp(sv)) | |
1831 | return SvIVX(sv) != 0; | |
1832 | else { | |
1833 | if (SvNOKp(sv)) | |
1834 | return SvNVX(sv) != 0.0; | |
1835 | else | |
1836 | return FALSE; | |
1837 | } | |
1838 | } | |
79072805 LW |
1839 | } |
1840 | ||
1841 | /* Note: sv_setsv() should not be called with a source string that needs | |
463ee0b2 | 1842 | * to be reused, since it may destroy the source string if it is marked |
79072805 LW |
1843 | * as temporary. |
1844 | */ | |
1845 | ||
1846 | void | |
1847 | sv_setsv(dstr,sstr) | |
1848 | SV *dstr; | |
1849 | register SV *sstr; | |
1850 | { | |
11343788 | 1851 | dTHR; |
8990e307 LW |
1852 | register U32 sflags; |
1853 | register int dtype; | |
1854 | register int stype; | |
463ee0b2 | 1855 | |
79072805 LW |
1856 | if (sstr == dstr) |
1857 | return; | |
0f15f207 | 1858 | sv_check_thinkfirst(dstr); |
79072805 LW |
1859 | if (!sstr) |
1860 | sstr = &sv_undef; | |
8990e307 LW |
1861 | stype = SvTYPE(sstr); |
1862 | dtype = SvTYPE(dstr); | |
79072805 | 1863 | |
8e07c86e AD |
1864 | if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) { |
1865 | sv_unglob(dstr); /* so fake GLOB won't perpetuate */ | |
4633a7c4 LW |
1866 | sv_setpvn(dstr, "", 0); |
1867 | (void)SvPOK_only(dstr); | |
8e07c86e AD |
1868 | dtype = SvTYPE(dstr); |
1869 | } | |
1870 | ||
a0d0e21e LW |
1871 | #ifdef OVERLOAD |
1872 | SvAMAGIC_off(dstr); | |
1873 | #endif /* OVERLOAD */ | |
463ee0b2 | 1874 | /* There's a lot of redundancy below but we're going for speed here */ |
79072805 | 1875 | |
8990e307 | 1876 | switch (stype) { |
79072805 | 1877 | case SVt_NULL: |
a0d0e21e | 1878 | (void)SvOK_off(dstr); |
79072805 | 1879 | return; |
463ee0b2 | 1880 | case SVt_IV: |
ff68c719 | 1881 | if (dtype != SVt_IV && dtype < SVt_PVIV) { |
8990e307 LW |
1882 | if (dtype < SVt_IV) |
1883 | sv_upgrade(dstr, SVt_IV); | |
8990e307 LW |
1884 | else if (dtype == SVt_NV) |
1885 | sv_upgrade(dstr, SVt_PVNV); | |
ff68c719 | 1886 | else |
a0d0e21e | 1887 | sv_upgrade(dstr, SVt_PVIV); |
8990e307 | 1888 | } |
463ee0b2 LW |
1889 | break; |
1890 | case SVt_NV: | |
ff68c719 | 1891 | if (dtype != SVt_NV && dtype < SVt_PVNV) { |
8990e307 LW |
1892 | if (dtype < SVt_NV) |
1893 | sv_upgrade(dstr, SVt_NV); | |
ff68c719 | 1894 | else |
a0d0e21e | 1895 | sv_upgrade(dstr, SVt_PVNV); |
8990e307 | 1896 | } |
463ee0b2 | 1897 | break; |
ed6116ce | 1898 | case SVt_RV: |
8990e307 | 1899 | if (dtype < SVt_RV) |
ed6116ce | 1900 | sv_upgrade(dstr, SVt_RV); |
c07a80fd | 1901 | else if (dtype == SVt_PVGV && |
1902 | SvTYPE(SvRV(sstr)) == SVt_PVGV) { | |
1903 | sstr = SvRV(sstr); | |
a5f75d66 AD |
1904 | if (sstr == dstr) { |
1905 | if (curcop->cop_stash != GvSTASH(dstr)) | |
1906 | GvIMPORTED_on(dstr); | |
1907 | GvMULTI_on(dstr); | |
1908 | return; | |
1909 | } | |
c07a80fd | 1910 | goto glob_assign; |
1911 | } | |
ed6116ce | 1912 | break; |
463ee0b2 | 1913 | case SVt_PV: |
fc36a67e | 1914 | case SVt_PVFM: |
8990e307 | 1915 | if (dtype < SVt_PV) |
463ee0b2 | 1916 | sv_upgrade(dstr, SVt_PV); |
463ee0b2 LW |
1917 | break; |
1918 | case SVt_PVIV: | |
8990e307 | 1919 | if (dtype < SVt_PVIV) |
463ee0b2 | 1920 | sv_upgrade(dstr, SVt_PVIV); |
463ee0b2 LW |
1921 | break; |
1922 | case SVt_PVNV: | |
8990e307 | 1923 | if (dtype < SVt_PVNV) |
463ee0b2 | 1924 | sv_upgrade(dstr, SVt_PVNV); |
463ee0b2 | 1925 | break; |
4633a7c4 LW |
1926 | |
1927 | case SVt_PVLV: | |
4561caa4 | 1928 | sv_upgrade(dstr, SVt_PVLV); |
4633a7c4 LW |
1929 | break; |
1930 | ||
1931 | case SVt_PVAV: | |
1932 | case SVt_PVHV: | |
1933 | case SVt_PVCV: | |
4633a7c4 LW |
1934 | case SVt_PVIO: |
1935 | if (op) | |
1936 | croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), | |
1937 | op_name[op->op_type]); | |
1938 | else | |
1939 | croak("Bizarre copy of %s", sv_reftype(sstr, 0)); | |
1940 | break; | |
1941 | ||
79072805 | 1942 | case SVt_PVGV: |
8990e307 | 1943 | if (dtype <= SVt_PVGV) { |
c07a80fd | 1944 | glob_assign: |
a5f75d66 | 1945 | if (dtype != SVt_PVGV) { |
a0d0e21e LW |
1946 | char *name = GvNAME(sstr); |
1947 | STRLEN len = GvNAMELEN(sstr); | |
463ee0b2 | 1948 | sv_upgrade(dstr, SVt_PVGV); |
a0d0e21e LW |
1949 | sv_magic(dstr, dstr, '*', name, len); |
1950 | GvSTASH(dstr) = GvSTASH(sstr); | |
1951 | GvNAME(dstr) = savepvn(name, len); | |
1952 | GvNAMELEN(dstr) = len; | |
1953 | SvFAKE_on(dstr); /* can coerce to non-glob */ | |
1954 | } | |
7bac28a0 | 1955 | /* ahem, death to those who redefine active sort subs */ |
1956 | else if (curstack == sortstack | |
1957 | && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) | |
1958 | croak("Can't redefine active sort subroutine %s", | |
1959 | GvNAME(dstr)); | |
a0d0e21e | 1960 | (void)SvOK_off(dstr); |
a5f75d66 | 1961 | GvINTRO_off(dstr); /* one-shot flag */ |
1edc1566 | 1962 | gp_free((GV*)dstr); |
79072805 | 1963 | GvGP(dstr) = gp_ref(GvGP(sstr)); |
8990e307 | 1964 | SvTAINT(dstr); |
a5f75d66 AD |
1965 | if (curcop->cop_stash != GvSTASH(dstr)) |
1966 | GvIMPORTED_on(dstr); | |
1967 | GvMULTI_on(dstr); | |
79072805 LW |
1968 | return; |
1969 | } | |
1970 | /* FALL THROUGH */ | |
1971 | ||
1972 | default: | |
973f89ab CS |
1973 | if (SvGMAGICAL(sstr)) { |
1974 | mg_get(sstr); | |
1975 | if (SvTYPE(sstr) != stype) { | |
1976 | stype = SvTYPE(sstr); | |
1977 | if (stype == SVt_PVGV && dtype <= SVt_PVGV) | |
1978 | goto glob_assign; | |
1979 | } | |
1980 | } | |
8990e307 LW |
1981 | if (dtype < stype) |
1982 | sv_upgrade(dstr, stype); | |
79072805 LW |
1983 | } |
1984 | ||
8990e307 LW |
1985 | sflags = SvFLAGS(sstr); |
1986 | ||
1987 | if (sflags & SVf_ROK) { | |
1988 | if (dtype >= SVt_PV) { | |
1989 | if (dtype == SVt_PVGV) { | |
11343788 | 1990 | dTHR; |
8990e307 LW |
1991 | SV *sref = SvREFCNT_inc(SvRV(sstr)); |
1992 | SV *dref = 0; | |
a5f75d66 | 1993 | int intro = GvINTRO(dstr); |
a0d0e21e LW |
1994 | |
1995 | if (intro) { | |
1996 | GP *gp; | |
1997 | GvGP(dstr)->gp_refcnt--; | |
a5f75d66 | 1998 | GvINTRO_off(dstr); /* one-shot flag */ |
a0d0e21e | 1999 | Newz(602,gp, 1, GP); |
44a8e56a | 2000 | GvGP(dstr) = gp_ref(gp); |
a0d0e21e LW |
2001 | GvSV(dstr) = NEWSV(72,0); |
2002 | GvLINE(dstr) = curcop->cop_line; | |
1edc1566 | 2003 | GvEGV(dstr) = (GV*)dstr; |
a0d0e21e | 2004 | } |
a5f75d66 | 2005 | GvMULTI_on(dstr); |
8990e307 LW |
2006 | switch (SvTYPE(sref)) { |
2007 | case SVt_PVAV: | |
a0d0e21e LW |
2008 | if (intro) |
2009 | SAVESPTR(GvAV(dstr)); | |
2010 | else | |
2011 | dref = (SV*)GvAV(dstr); | |
8990e307 | 2012 | GvAV(dstr) = (AV*)sref; |
a5f75d66 AD |
2013 | if (curcop->cop_stash != GvSTASH(dstr)) |
2014 | GvIMPORTED_AV_on(dstr); | |
8990e307 LW |
2015 | break; |
2016 | case SVt_PVHV: | |
a0d0e21e LW |
2017 | if (intro) |
2018 | SAVESPTR(GvHV(dstr)); | |
2019 | else | |
2020 | dref = (SV*)GvHV(dstr); | |
8990e307 | 2021 | GvHV(dstr) = (HV*)sref; |
a5f75d66 AD |
2022 | if (curcop->cop_stash != GvSTASH(dstr)) |
2023 | GvIMPORTED_HV_on(dstr); | |
8990e307 LW |
2024 | break; |
2025 | case SVt_PVCV: | |
8ebc5c01 | 2026 | if (intro) { |
2027 | if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { | |
2028 | SvREFCNT_dec(GvCV(dstr)); | |
2029 | GvCV(dstr) = Nullcv; | |
68dc0745 | 2030 | GvCVGEN(dstr) = 0; /* Switch off cacheness. */ |
2031 | sub_generation++; | |
8ebc5c01 | 2032 | } |
a0d0e21e | 2033 | SAVESPTR(GvCV(dstr)); |
8ebc5c01 | 2034 | } |
68dc0745 | 2035 | else |
2036 | dref = (SV*)GvCV(dstr); | |
2037 | if (GvCV(dstr) != (CV*)sref) { | |
748a9306 | 2038 | CV* cv = GvCV(dstr); |
4633a7c4 | 2039 | if (cv) { |
68dc0745 | 2040 | if (!GvCVGEN((GV*)dstr) && |
2041 | (CvROOT(cv) || CvXSUB(cv))) | |
2042 | { | |
7bac28a0 | 2043 | /* ahem, death to those who redefine |
2044 | * active sort subs */ | |
2045 | if (curstack == sortstack && | |
2046 | sortcop == CvSTART(cv)) | |
2047 | croak( | |
2048 | "Can't redefine active sort subroutine %s", | |
2049 | GvENAME((GV*)dstr)); | |
9607fc9c | 2050 | if (cv_const_sv(cv)) |
2051 | warn("Constant subroutine %s redefined", | |
2052 | GvENAME((GV*)dstr)); | |
2053 | else if (dowarn) | |
2054 | warn("Subroutine %s redefined", | |
2055 | GvENAME((GV*)dstr)); | |
2056 | } | |
3fe9a6f1 | 2057 | cv_ckproto(cv, (GV*)dstr, |
2058 | SvPOK(sref) ? SvPVX(sref) : Nullch); | |
4633a7c4 | 2059 | } |
a5f75d66 | 2060 | GvCV(dstr) = (CV*)sref; |
7a4c00b4 | 2061 | GvCVGEN(dstr) = 0; /* Switch off cacheness. */ |
a5f75d66 | 2062 | GvASSUMECV_on(dstr); |
8ebc5c01 | 2063 | sub_generation++; |
a5f75d66 AD |
2064 | } |
2065 | if (curcop->cop_stash != GvSTASH(dstr)) | |
2066 | GvIMPORTED_CV_on(dstr); | |
8990e307 | 2067 | break; |
91bba347 LW |
2068 | case SVt_PVIO: |
2069 | if (intro) | |
2070 | SAVESPTR(GvIOp(dstr)); | |
2071 | else | |
2072 | dref = (SV*)GvIOp(dstr); | |
2073 | GvIOp(dstr) = (IO*)sref; | |
2074 | break; | |
8990e307 | 2075 | default: |
a0d0e21e LW |
2076 | if (intro) |
2077 | SAVESPTR(GvSV(dstr)); | |
2078 | else | |
2079 | dref = (SV*)GvSV(dstr); | |
8990e307 | 2080 | GvSV(dstr) = sref; |
a5f75d66 AD |
2081 | if (curcop->cop_stash != GvSTASH(dstr)) |
2082 | GvIMPORTED_SV_on(dstr); | |
8990e307 LW |
2083 | break; |
2084 | } | |
2085 | if (dref) | |
2086 | SvREFCNT_dec(dref); | |
a0d0e21e LW |
2087 | if (intro) |
2088 | SAVEFREESV(sref); | |
8990e307 LW |
2089 | SvTAINT(dstr); |
2090 | return; | |
2091 | } | |
a0d0e21e | 2092 | if (SvPVX(dstr)) { |
760ac839 | 2093 | (void)SvOOK_off(dstr); /* backoff */ |
8990e307 | 2094 | Safefree(SvPVX(dstr)); |
a0d0e21e LW |
2095 | SvLEN(dstr)=SvCUR(dstr)=0; |
2096 | } | |
8990e307 | 2097 | } |
a0d0e21e | 2098 | (void)SvOK_off(dstr); |
8990e307 | 2099 | SvRV(dstr) = SvREFCNT_inc(SvRV(sstr)); |
ed6116ce | 2100 | SvROK_on(dstr); |
8990e307 | 2101 | if (sflags & SVp_NOK) { |
ed6116ce LW |
2102 | SvNOK_on(dstr); |
2103 | SvNVX(dstr) = SvNVX(sstr); | |
2104 | } | |
8990e307 | 2105 | if (sflags & SVp_IOK) { |
a0d0e21e | 2106 | (void)SvIOK_on(dstr); |
ed6116ce LW |
2107 | SvIVX(dstr) = SvIVX(sstr); |
2108 | } | |
a0d0e21e LW |
2109 | #ifdef OVERLOAD |
2110 | if (SvAMAGIC(sstr)) { | |
2111 | SvAMAGIC_on(dstr); | |
2112 | } | |
2113 | #endif /* OVERLOAD */ | |
ed6116ce | 2114 | } |
8990e307 | 2115 | else if (sflags & SVp_POK) { |
79072805 LW |
2116 | |
2117 | /* | |
2118 | * Check to see if we can just swipe the string. If so, it's a | |
2119 | * possible small lose on short strings, but a big win on long ones. | |
463ee0b2 LW |
2120 | * It might even be a win on short strings if SvPVX(dstr) |
2121 | * has to be allocated and SvPVX(sstr) has to be freed. | |
79072805 LW |
2122 | */ |
2123 | ||
ff68c719 | 2124 | if (SvTEMP(sstr) && /* slated for free anyway? */ |
a5f75d66 AD |
2125 | !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ |
2126 | { | |
adbc6bb1 | 2127 | if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ |
a5f75d66 AD |
2128 | if (SvOOK(dstr)) { |
2129 | SvFLAGS(dstr) &= ~SVf_OOK; | |
2130 | Safefree(SvPVX(dstr) - SvIVX(dstr)); | |
2131 | } | |
2132 | else | |
2133 | Safefree(SvPVX(dstr)); | |
79072805 | 2134 | } |
a5f75d66 | 2135 | (void)SvPOK_only(dstr); |
463ee0b2 | 2136 | SvPV_set(dstr, SvPVX(sstr)); |
79072805 LW |
2137 | SvLEN_set(dstr, SvLEN(sstr)); |
2138 | SvCUR_set(dstr, SvCUR(sstr)); | |
79072805 | 2139 | SvTEMP_off(dstr); |
a5f75d66 | 2140 | (void)SvOK_off(sstr); |
79072805 LW |
2141 | SvPV_set(sstr, Nullch); |
2142 | SvLEN_set(sstr, 0); | |
a5f75d66 AD |
2143 | SvCUR_set(sstr, 0); |
2144 | SvTEMP_off(sstr); | |
79072805 LW |
2145 | } |
2146 | else { /* have to copy actual string */ | |
8990e307 LW |
2147 | STRLEN len = SvCUR(sstr); |
2148 | ||
2149 | SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ | |
2150 | Move(SvPVX(sstr),SvPVX(dstr),len,char); | |
2151 | SvCUR_set(dstr, len); | |
2152 | *SvEND(dstr) = '\0'; | |
a0d0e21e | 2153 | (void)SvPOK_only(dstr); |
79072805 LW |
2154 | } |
2155 | /*SUPPRESS 560*/ | |
8990e307 | 2156 | if (sflags & SVp_NOK) { |
79072805 | 2157 | SvNOK_on(dstr); |
463ee0b2 | 2158 | SvNVX(dstr) = SvNVX(sstr); |
79072805 | 2159 | } |
8990e307 | 2160 | if (sflags & SVp_IOK) { |
a0d0e21e | 2161 | (void)SvIOK_on(dstr); |
463ee0b2 | 2162 | SvIVX(dstr) = SvIVX(sstr); |
79072805 LW |
2163 | } |
2164 | } | |
8990e307 | 2165 | else if (sflags & SVp_NOK) { |
463ee0b2 | 2166 | SvNVX(dstr) = SvNVX(sstr); |
a0d0e21e | 2167 | (void)SvNOK_only(dstr); |
79072805 | 2168 | if (SvIOK(sstr)) { |
a0d0e21e | 2169 | (void)SvIOK_on(dstr); |
463ee0b2 | 2170 | SvIVX(dstr) = SvIVX(sstr); |
79072805 LW |
2171 | } |
2172 | } | |
8990e307 | 2173 | else if (sflags & SVp_IOK) { |
a0d0e21e | 2174 | (void)SvIOK_only(dstr); |
463ee0b2 | 2175 | SvIVX(dstr) = SvIVX(sstr); |
79072805 LW |
2176 | } |
2177 | else { | |
a0d0e21e LW |
2178 | (void)SvOK_off(dstr); |
2179 | } | |
463ee0b2 | 2180 | SvTAINT(dstr); |
79072805 LW |
2181 | } |
2182 | ||
2183 | void | |
2184 | sv_setpvn(sv,ptr,len) | |
2185 | register SV *sv; | |
71be2cbc | 2186 | register const char *ptr; |
79072805 LW |
2187 | register STRLEN len; |
2188 | { | |
4561caa4 CS |
2189 | assert(len >= 0); /* STRLEN is probably unsigned, so this may |
2190 | elicit a warning, but it won't hurt. */ | |
0f15f207 | 2191 | sv_check_thinkfirst(sv); |
463ee0b2 | 2192 | if (!ptr) { |
a0d0e21e | 2193 | (void)SvOK_off(sv); |
463ee0b2 LW |
2194 | return; |
2195 | } | |
c07a80fd | 2196 | if (SvTYPE(sv) >= SVt_PV) { |
2197 | if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) | |
2198 | sv_unglob(sv); | |
2199 | } | |
2200 | else if (!sv_upgrade(sv, SVt_PV)) | |
79072805 LW |
2201 | return; |
2202 | SvGROW(sv, len + 1); | |
a0d0e21e | 2203 | Move(ptr,SvPVX(sv),len,char); |
79072805 LW |
2204 | SvCUR_set(sv, len); |
2205 | *SvEND(sv) = '\0'; | |
a0d0e21e | 2206 | (void)SvPOK_only(sv); /* validate pointer */ |
463ee0b2 | 2207 | SvTAINT(sv); |
79072805 LW |
2208 | } |
2209 | ||
2210 | void | |
2211 | sv_setpv(sv,ptr) | |
2212 | register SV *sv; | |
71be2cbc | 2213 | register const char *ptr; |
79072805 LW |
2214 | { |
2215 | register STRLEN len; | |
2216 | ||
0f15f207 | 2217 | sv_check_thinkfirst(sv); |
463ee0b2 | 2218 | if (!ptr) { |
a0d0e21e | 2219 | (void)SvOK_off(sv); |
463ee0b2 LW |
2220 | return; |
2221 | } | |
79072805 | 2222 | len = strlen(ptr); |
c07a80fd | 2223 | if (SvTYPE(sv) >= SVt_PV) { |
2224 | if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) | |
2225 | sv_unglob(sv); | |
2226 | } | |
2227 | else if (!sv_upgrade(sv, SVt_PV)) | |
79072805 LW |
2228 | return; |
2229 | SvGROW(sv, len + 1); | |
463ee0b2 | 2230 | Move(ptr,SvPVX(sv),len+1,char); |
79072805 | 2231 | SvCUR_set(sv, len); |
a0d0e21e | 2232 | (void)SvPOK_only(sv); /* validate pointer */ |
463ee0b2 LW |
2233 | SvTAINT(sv); |
2234 | } | |
2235 | ||
2236 | void | |
2237 | sv_usepvn(sv,ptr,len) | |
2238 | register SV *sv; | |
2239 | register char *ptr; | |
2240 | register STRLEN len; | |
2241 | { | |
0f15f207 | 2242 | sv_check_thinkfirst(sv); |
463ee0b2 LW |
2243 | if (!SvUPGRADE(sv, SVt_PV)) |
2244 | return; | |
2245 | if (!ptr) { | |
a0d0e21e | 2246 | (void)SvOK_off(sv); |
463ee0b2 LW |
2247 | return; |
2248 | } | |
2249 | if (SvPVX(sv)) | |
2250 | Safefree(SvPVX(sv)); | |
2251 | Renew(ptr, len+1, char); | |
2252 | SvPVX(sv) = ptr; | |
2253 | SvCUR_set(sv, len); | |
2254 | SvLEN_set(sv, len+1); | |
2255 | *SvEND(sv) = '\0'; | |
a0d0e21e | 2256 | (void)SvPOK_only(sv); /* validate pointer */ |
463ee0b2 | 2257 | SvTAINT(sv); |
79072805 LW |
2258 | } |
2259 | ||
0f15f207 MB |
2260 | static void |
2261 | sv_check_thinkfirst(sv) | |
2262 | register SV *sv; | |
2263 | { | |
2264 | if (SvTHINKFIRST(sv)) { | |
2265 | if (SvREADONLY(sv)) { | |
2266 | dTHR; | |
2267 | if (curcop != &compiling) | |
2268 | croak(no_modify); | |
2269 | } | |
2270 | if (SvROK(sv)) | |
2271 | sv_unref(sv); | |
2272 | } | |
2273 | } | |
2274 | ||
79072805 LW |
2275 | void |
2276 | sv_chop(sv,ptr) /* like set but assuming ptr is in sv */ | |
2277 | register SV *sv; | |
2278 | register char *ptr; | |
2279 | { | |
2280 | register STRLEN delta; | |
2281 | ||
a0d0e21e | 2282 | if (!ptr || !SvPOKp(sv)) |
79072805 | 2283 | return; |
0f15f207 | 2284 | sv_check_thinkfirst(sv); |
79072805 LW |
2285 | if (SvTYPE(sv) < SVt_PVIV) |
2286 | sv_upgrade(sv,SVt_PVIV); | |
2287 | ||
2288 | if (!SvOOK(sv)) { | |
463ee0b2 | 2289 | SvIVX(sv) = 0; |
79072805 LW |
2290 | SvFLAGS(sv) |= SVf_OOK; |
2291 | } | |
8990e307 | 2292 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK); |
463ee0b2 | 2293 | delta = ptr - SvPVX(sv); |
79072805 LW |
2294 | SvLEN(sv) -= delta; |
2295 | SvCUR(sv) -= delta; | |
463ee0b2 LW |
2296 | SvPVX(sv) += delta; |
2297 | SvIVX(sv) += delta; | |
79072805 LW |
2298 | } |
2299 | ||
2300 | void | |
2301 | sv_catpvn(sv,ptr,len) | |
2302 | register SV *sv; | |
2303 | register char *ptr; | |
2304 | register STRLEN len; | |
2305 | { | |
463ee0b2 | 2306 | STRLEN tlen; |
748a9306 | 2307 | char *junk; |
a0d0e21e | 2308 | |
748a9306 | 2309 | junk = SvPV_force(sv, tlen); |
463ee0b2 | 2310 | SvGROW(sv, tlen + len + 1); |
4633a7c4 LW |
2311 | if (ptr == junk) |
2312 | ptr = SvPVX(sv); | |
463ee0b2 | 2313 | Move(ptr,SvPVX(sv)+tlen,len,char); |
79072805 LW |
2314 | SvCUR(sv) += len; |
2315 | *SvEND(sv) = '\0'; | |
a0d0e21e | 2316 | (void)SvPOK_only(sv); /* validate pointer */ |
463ee0b2 | 2317 | SvTAINT(sv); |
79072805 LW |
2318 | } |
2319 | ||
2320 | void | |
2321 | sv_catsv(dstr,sstr) | |
2322 | SV *dstr; | |
2323 | register SV *sstr; | |
2324 | { | |
2325 | char *s; | |
463ee0b2 | 2326 | STRLEN len; |
79072805 LW |
2327 | if (!sstr) |
2328 | return; | |
463ee0b2 LW |
2329 | if (s = SvPV(sstr, len)) |
2330 | sv_catpvn(dstr,s,len); | |
79072805 LW |
2331 | } |
2332 | ||
2333 | void | |
2334 | sv_catpv(sv,ptr) | |
2335 | register SV *sv; | |
2336 | register char *ptr; | |
2337 | { | |
2338 | register STRLEN len; | |
463ee0b2 | 2339 | STRLEN tlen; |
748a9306 | 2340 | char *junk; |
79072805 | 2341 | |
79072805 LW |
2342 | if (!ptr) |
2343 | return; | |
748a9306 | 2344 | junk = SvPV_force(sv, tlen); |
79072805 | 2345 | len = strlen(ptr); |
463ee0b2 | 2346 | SvGROW(sv, tlen + len + 1); |
4633a7c4 LW |
2347 | if (ptr == junk) |
2348 | ptr = SvPVX(sv); | |
463ee0b2 | 2349 | Move(ptr,SvPVX(sv)+tlen,len+1,char); |
79072805 | 2350 | SvCUR(sv) += len; |
a0d0e21e | 2351 | (void)SvPOK_only(sv); /* validate pointer */ |
463ee0b2 | 2352 | SvTAINT(sv); |
79072805 LW |
2353 | } |
2354 | ||
79072805 LW |
2355 | SV * |
2356 | #ifdef LEAKTEST | |
2357 | newSV(x,len) | |
2358 | I32 x; | |
2359 | #else | |
2360 | newSV(len) | |
2361 | #endif | |
2362 | STRLEN len; | |
2363 | { | |
2364 | register SV *sv; | |
2365 | ||
4561caa4 | 2366 | new_SV(sv); |
8990e307 LW |
2367 | SvANY(sv) = 0; |
2368 | SvREFCNT(sv) = 1; | |
2369 | SvFLAGS(sv) = 0; | |
79072805 LW |
2370 | if (len) { |
2371 | sv_upgrade(sv, SVt_PV); | |
2372 | SvGROW(sv, len + 1); | |
2373 | } | |
2374 | return sv; | |
2375 | } | |
2376 | ||
1edc1566 | 2377 | /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ |
2378 | ||
79072805 LW |
2379 | void |
2380 | sv_magic(sv, obj, how, name, namlen) | |
2381 | register SV *sv; | |
2382 | SV *obj; | |
a0d0e21e | 2383 | int how; |
79072805 | 2384 | char *name; |
463ee0b2 | 2385 | I32 namlen; |
79072805 LW |
2386 | { |
2387 | MAGIC* mg; | |
2388 | ||
0f15f207 MB |
2389 | if (SvREADONLY(sv)) { |
2390 | dTHR; | |
2391 | if (curcop != &compiling && !strchr("gBf", how)) | |
2392 | croak(no_modify); | |
2393 | } | |
4633a7c4 | 2394 | if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { |
748a9306 LW |
2395 | if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { |
2396 | if (how == 't') | |
2397 | mg->mg_len |= 1; | |
463ee0b2 | 2398 | return; |
748a9306 | 2399 | } |
463ee0b2 LW |
2400 | } |
2401 | else { | |
2402 | if (!SvUPGRADE(sv, SVt_PVMG)) | |
2403 | return; | |
463ee0b2 | 2404 | } |
79072805 LW |
2405 | Newz(702,mg, 1, MAGIC); |
2406 | mg->mg_moremagic = SvMAGIC(sv); | |
463ee0b2 | 2407 | |
79072805 | 2408 | SvMAGIC(sv) = mg; |
748a9306 | 2409 | if (!obj || obj == sv || how == '#') |
8990e307 | 2410 | mg->mg_obj = obj; |
85e6fe83 | 2411 | else { |
11343788 | 2412 | dTHR; |
8990e307 | 2413 | mg->mg_obj = SvREFCNT_inc(obj); |
85e6fe83 LW |
2414 | mg->mg_flags |= MGf_REFCOUNTED; |
2415 | } | |
79072805 | 2416 | mg->mg_type = how; |
463ee0b2 | 2417 | mg->mg_len = namlen; |
1edc1566 | 2418 | if (name) |
2419 | if (namlen >= 0) | |
2420 | mg->mg_ptr = savepvn(name, namlen); | |
e858de61 MB |
2421 | else if (namlen == HEf_SVKEY) { |
2422 | dTHR; /* just for SvREFCNT_inc */ | |
1edc1566 | 2423 | mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); |
e858de61 | 2424 | } |
1edc1566 | 2425 | |
79072805 LW |
2426 | switch (how) { |
2427 | case 0: | |
2428 | mg->mg_virtual = &vtbl_sv; | |
2429 | break; | |
a0d0e21e LW |
2430 | #ifdef OVERLOAD |
2431 | case 'A': | |
2432 | mg->mg_virtual = &vtbl_amagic; | |
2433 | break; | |
2434 | case 'a': | |
2435 | mg->mg_virtual = &vtbl_amagicelem; | |
2436 | break; | |
2437 | case 'c': | |
2438 | mg->mg_virtual = 0; | |
2439 | break; | |
2440 | #endif /* OVERLOAD */ | |
79072805 LW |
2441 | case 'B': |
2442 | mg->mg_virtual = &vtbl_bm; | |
2443 | break; | |
79072805 LW |
2444 | case 'E': |
2445 | mg->mg_virtual = &vtbl_env; | |
2446 | break; | |
55497cff | 2447 | case 'f': |
2448 | mg->mg_virtual = &vtbl_fm; | |
2449 | break; | |
79072805 LW |
2450 | case 'e': |
2451 | mg->mg_virtual = &vtbl_envelem; | |
2452 | break; | |
93a17b20 LW |
2453 | case 'g': |
2454 | mg->mg_virtual = &vtbl_mglob; | |
2455 | break; | |
463ee0b2 LW |
2456 | case 'I': |
2457 | mg->mg_virtual = &vtbl_isa; | |
2458 | break; | |
2459 | case 'i': | |
2460 | mg->mg_virtual = &vtbl_isaelem; | |
2461 | break; | |
16660edb | 2462 | case 'k': |
2463 | mg->mg_virtual = &vtbl_nkeys; | |
2464 | break; | |
79072805 | 2465 | case 'L': |
a0d0e21e | 2466 | SvRMAGICAL_on(sv); |
93a17b20 LW |
2467 | mg->mg_virtual = 0; |
2468 | break; | |
2469 | case 'l': | |
79072805 LW |
2470 | mg->mg_virtual = &vtbl_dbline; |
2471 | break; | |
f93b4edd MB |
2472 | #ifdef USE_THREADS |
2473 | case 'm': | |
2474 | mg->mg_virtual = &vtbl_mutex; | |
2475 | break; | |
2476 | #endif /* USE_THREADS */ | |
36477c24 | 2477 | #ifdef USE_LOCALE_COLLATE |
bbce6d69 | 2478 | case 'o': |
2479 | mg->mg_virtual = &vtbl_collxfrm; | |
2480 | break; | |
36477c24 | 2481 | #endif /* USE_LOCALE_COLLATE */ |
463ee0b2 LW |
2482 | case 'P': |
2483 | mg->mg_virtual = &vtbl_pack; | |
2484 | break; | |
2485 | case 'p': | |
a0d0e21e | 2486 | case 'q': |
463ee0b2 LW |
2487 | mg->mg_virtual = &vtbl_packelem; |
2488 | break; | |
79072805 LW |
2489 | case 'S': |
2490 | mg->mg_virtual = &vtbl_sig; | |
2491 | break; | |
2492 | case 's': | |
2493 | mg->mg_virtual = &vtbl_sigelem; | |
2494 | break; | |
463ee0b2 LW |
2495 | case 't': |
2496 | mg->mg_virtual = &vtbl_taint; | |
748a9306 | 2497 | mg->mg_len = 1; |
463ee0b2 | 2498 | break; |
79072805 LW |
2499 | case 'U': |
2500 | mg->mg_virtual = &vtbl_uvar; | |
2501 | break; | |
2502 | case 'v': | |
2503 | mg->mg_virtual = &vtbl_vec; | |
2504 | break; | |
2505 | case 'x': | |
2506 | mg->mg_virtual = &vtbl_substr; | |
2507 | break; | |
5f05dabc | 2508 | case 'y': |
68dc0745 | 2509 | mg->mg_virtual = &vtbl_defelem; |
5f05dabc | 2510 | break; |
79072805 LW |
2511 | case '*': |
2512 | mg->mg_virtual = &vtbl_glob; | |
2513 | break; | |
2514 | case '#': | |
2515 | mg->mg_virtual = &vtbl_arylen; | |
2516 | break; | |
a0d0e21e LW |
2517 | case '.': |
2518 | mg->mg_virtual = &vtbl_pos; | |
2519 | break; | |
4633a7c4 LW |
2520 | case '~': /* Reserved for use by extensions not perl internals. */ |
2521 | /* Useful for attaching extension internal data to perl vars. */ | |
2522 | /* Note that multiple extensions may clash if magical scalars */ | |
2523 | /* etc holding private data from one are passed to another. */ | |
2524 | SvRMAGICAL_on(sv); | |
a0d0e21e | 2525 | break; |
79072805 | 2526 | default: |
463ee0b2 LW |
2527 | croak("Don't know how to handle magic of type '%c'", how); |
2528 | } | |
8990e307 LW |
2529 | mg_magical(sv); |
2530 | if (SvGMAGICAL(sv)) | |
2531 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); | |
463ee0b2 LW |
2532 | } |
2533 | ||
2534 | int | |
2535 | sv_unmagic(sv, type) | |
2536 | SV* sv; | |
a0d0e21e | 2537 | int type; |
463ee0b2 LW |
2538 | { |
2539 | MAGIC* mg; | |
2540 | MAGIC** mgp; | |
91bba347 | 2541 | if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) |
463ee0b2 LW |
2542 | return 0; |
2543 | mgp = &SvMAGIC(sv); | |
2544 | for (mg = *mgp; mg; mg = *mgp) { | |
2545 | if (mg->mg_type == type) { | |
2546 | MGVTBL* vtbl = mg->mg_virtual; | |
2547 | *mgp = mg->mg_moremagic; | |
2548 | if (vtbl && vtbl->svt_free) | |
2549 | (*vtbl->svt_free)(sv, mg); | |
2550 | if (mg->mg_ptr && mg->mg_type != 'g') | |
1edc1566 | 2551 | if (mg->mg_len >= 0) |
2552 | Safefree(mg->mg_ptr); | |
2553 | else if (mg->mg_len == HEf_SVKEY) | |
2554 | SvREFCNT_dec((SV*)mg->mg_ptr); | |
a0d0e21e LW |
2555 | if (mg->mg_flags & MGf_REFCOUNTED) |
2556 | SvREFCNT_dec(mg->mg_obj); | |
463ee0b2 LW |
2557 | Safefree(mg); |
2558 | } | |
2559 | else | |
2560 | mgp = &mg->mg_moremagic; | |
79072805 | 2561 | } |
91bba347 | 2562 | if (!SvMAGIC(sv)) { |
463ee0b2 | 2563 | SvMAGICAL_off(sv); |
8990e307 | 2564 | SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; |
463ee0b2 LW |
2565 | } |
2566 | ||
2567 | return 0; | |
79072805 LW |
2568 | } |
2569 | ||
2570 | void | |
2571 | sv_insert(bigstr,offset,len,little,littlelen) | |
2572 | SV *bigstr; | |
2573 | STRLEN offset; | |
2574 | STRLEN len; | |
2575 | char *little; | |
2576 | STRLEN littlelen; | |
2577 | { | |
2578 | register char *big; | |
2579 | register char *mid; | |
2580 | register char *midend; | |
2581 | register char *bigend; | |
2582 | register I32 i; | |
2583 | ||
8990e307 LW |
2584 | if (!bigstr) |
2585 | croak("Can't modify non-existent substring"); | |
a0d0e21e | 2586 | SvPV_force(bigstr, na); |
79072805 LW |
2587 | |
2588 | i = littlelen - len; | |
2589 | if (i > 0) { /* string might grow */ | |
a0d0e21e | 2590 | big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); |
79072805 LW |
2591 | mid = big + offset + len; |
2592 | midend = bigend = big + SvCUR(bigstr); | |
2593 | bigend += i; | |
2594 | *bigend = '\0'; | |
2595 | while (midend > mid) /* shove everything down */ | |
2596 | *--bigend = *--midend; | |
2597 | Move(little,big+offset,littlelen,char); | |
2598 | SvCUR(bigstr) += i; | |
2599 | SvSETMAGIC(bigstr); | |
2600 | return; | |
2601 | } | |
2602 | else if (i == 0) { | |
463ee0b2 | 2603 | Move(little,SvPVX(bigstr)+offset,len,char); |
79072805 LW |
2604 | SvSETMAGIC(bigstr); |
2605 | return; | |
2606 | } | |
2607 | ||
463ee0b2 | 2608 | big = SvPVX(bigstr); |
79072805 LW |
2609 | mid = big + offset; |
2610 | midend = mid + len; | |
2611 | bigend = big + SvCUR(bigstr); | |
2612 | ||
2613 | if (midend > bigend) | |
463ee0b2 | 2614 | croak("panic: sv_insert"); |
79072805 LW |
2615 | |
2616 | if (mid - big > bigend - midend) { /* faster to shorten from end */ | |
2617 | if (littlelen) { | |
2618 | Move(little, mid, littlelen,char); | |
2619 | mid += littlelen; | |
2620 | } | |
2621 | i = bigend - midend; | |
2622 | if (i > 0) { | |
2623 | Move(midend, mid, i,char); | |
2624 | mid += i; | |
2625 | } | |
2626 | *mid = '\0'; | |
2627 | SvCUR_set(bigstr, mid - big); | |
2628 | } | |
2629 | /*SUPPRESS 560*/ | |
2630 | else if (i = mid - big) { /* faster from front */ | |
2631 | midend -= littlelen; | |
2632 | mid = midend; | |
2633 | sv_chop(bigstr,midend-i); | |
2634 | big += i; | |
2635 | while (i--) | |
2636 | *--midend = *--big; | |
2637 | if (littlelen) | |
2638 | Move(little, mid, littlelen,char); | |
2639 | } | |
2640 | else if (littlelen) { | |
2641 | midend -= littlelen; | |
2642 | sv_chop(bigstr,midend); | |
2643 | Move(little,midend,littlelen,char); | |
2644 | } | |
2645 | else { | |
2646 | sv_chop(bigstr,midend); | |
2647 | } | |
2648 | SvSETMAGIC(bigstr); | |
2649 | } | |
2650 | ||
2651 | /* make sv point to what nstr did */ | |
2652 | ||
2653 | void | |
2654 | sv_replace(sv,nsv) | |
2655 | register SV *sv; | |
2656 | register SV *nsv; | |
2657 | { | |
2658 | U32 refcnt = SvREFCNT(sv); | |
0f15f207 | 2659 | sv_check_thinkfirst(sv); |
79072805 LW |
2660 | if (SvREFCNT(nsv) != 1) |
2661 | warn("Reference miscount in sv_replace()"); | |
93a17b20 | 2662 | if (SvMAGICAL(sv)) { |
a0d0e21e LW |
2663 | if (SvMAGICAL(nsv)) |
2664 | mg_free(nsv); | |
2665 | else | |
2666 | sv_upgrade(nsv, SVt_PVMG); | |
93a17b20 | 2667 | SvMAGIC(nsv) = SvMAGIC(sv); |
a0d0e21e | 2668 | SvFLAGS(nsv) |= SvMAGICAL(sv); |
93a17b20 LW |
2669 | SvMAGICAL_off(sv); |
2670 | SvMAGIC(sv) = 0; | |
2671 | } | |
79072805 LW |
2672 | SvREFCNT(sv) = 0; |
2673 | sv_clear(sv); | |
477f5d66 | 2674 | assert(!SvREFCNT(sv)); |
79072805 LW |
2675 | StructCopy(nsv,sv,SV); |
2676 | SvREFCNT(sv) = refcnt; | |
1edc1566 | 2677 | SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ |
463ee0b2 | 2678 | del_SV(nsv); |
79072805 LW |
2679 | } |
2680 | ||
2681 | void | |
2682 | sv_clear(sv) | |
2683 | register SV *sv; | |
2684 | { | |
2685 | assert(sv); | |
2686 | assert(SvREFCNT(sv) == 0); | |
2687 | ||
ed6116ce | 2688 | if (SvOBJECT(sv)) { |
e858de61 | 2689 | dTHR; |
a0d0e21e | 2690 | if (defstash) { /* Still have a symbol table? */ |
5dc0d613 | 2691 | dTHR; |
8ebc5c01 | 2692 | dSP; |
2693 | GV* destructor; | |
a0d0e21e LW |
2694 | |
2695 | ENTER; | |
2696 | SAVEFREESV(SvSTASH(sv)); | |
8ebc5c01 | 2697 | |
2698 | destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); | |
2699 | if (destructor) { | |
a0d0e21e LW |
2700 | SV ref; |
2701 | ||
2702 | Zero(&ref, 1, SV); | |
2703 | sv_upgrade(&ref, SVt_RV); | |
a0d0e21e LW |
2704 | SvRV(&ref) = SvREFCNT_inc(sv); |
2705 | SvROK_on(&ref); | |
d368068e IZ |
2706 | SvREFCNT(&ref) = 1; /* Fake, but otherwise |
2707 | creating+destructing a ref | |
2708 | leads to disaster. */ | |
a0d0e21e LW |
2709 | |
2710 | EXTEND(SP, 2); | |
2711 | PUSHMARK(SP); | |
2712 | PUSHs(&ref); | |
2713 | PUTBACK; | |
8ebc5c01 | 2714 | perl_call_sv((SV*)GvCV(destructor), |
2715 | G_DISCARD|G_EVAL|G_KEEPERR); | |
748a9306 | 2716 | del_XRV(SvANY(&ref)); |
1edc1566 | 2717 | SvREFCNT(sv)--; |
a0d0e21e | 2718 | } |
8ebc5c01 | 2719 | |
a0d0e21e LW |
2720 | LEAVE; |
2721 | } | |
4633a7c4 LW |
2722 | else |
2723 | SvREFCNT_dec(SvSTASH(sv)); | |
a0d0e21e LW |
2724 | if (SvOBJECT(sv)) { |
2725 | SvOBJECT_off(sv); /* Curse the object. */ | |
2726 | if (SvTYPE(sv) != SVt_PVIO) | |
2727 | --sv_objcount; /* XXX Might want something more general */ | |
2728 | } | |
1edc1566 | 2729 | if (SvREFCNT(sv)) { |
477f5d66 CS |
2730 | if (in_clean_objs) |
2731 | croak("DESTROY created new reference to dead object"); | |
2732 | /* DESTROY gave object new lease on life */ | |
2733 | return; | |
1edc1566 | 2734 | } |
463ee0b2 | 2735 | } |
c07a80fd | 2736 | if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) |
a0d0e21e | 2737 | mg_free(sv); |
79072805 | 2738 | switch (SvTYPE(sv)) { |
8990e307 | 2739 | case SVt_PVIO: |
5f05dabc | 2740 | if (IoIFP(sv) != PerlIO_stdin() && |
2741 | IoIFP(sv) != PerlIO_stdout() && | |
2742 | IoIFP(sv) != PerlIO_stderr()) | |
2743 | io_close((IO*)sv); | |
8990e307 LW |
2744 | Safefree(IoTOP_NAME(sv)); |
2745 | Safefree(IoFMT_NAME(sv)); | |
2746 | Safefree(IoBOTTOM_NAME(sv)); | |
a0d0e21e | 2747 | /* FALL THROUGH */ |
79072805 | 2748 | case SVt_PVBM: |
a0d0e21e | 2749 | goto freescalar; |
79072805 | 2750 | case SVt_PVCV: |
748a9306 | 2751 | case SVt_PVFM: |
85e6fe83 | 2752 | cv_undef((CV*)sv); |
a0d0e21e | 2753 | goto freescalar; |
79072805 | 2754 | case SVt_PVHV: |
85e6fe83 | 2755 | hv_undef((HV*)sv); |
a0d0e21e | 2756 | break; |
79072805 | 2757 | case SVt_PVAV: |
85e6fe83 | 2758 | av_undef((AV*)sv); |
a0d0e21e LW |
2759 | break; |
2760 | case SVt_PVGV: | |
1edc1566 | 2761 | gp_free((GV*)sv); |
a0d0e21e LW |
2762 | Safefree(GvNAME(sv)); |
2763 | /* FALL THROUGH */ | |
79072805 | 2764 | case SVt_PVLV: |
79072805 | 2765 | case SVt_PVMG: |
79072805 LW |
2766 | case SVt_PVNV: |
2767 | case SVt_PVIV: | |
a0d0e21e LW |
2768 | freescalar: |
2769 | (void)SvOOK_off(sv); | |
79072805 LW |
2770 | /* FALL THROUGH */ |
2771 | case SVt_PV: | |
a0d0e21e | 2772 | case SVt_RV: |
8990e307 LW |
2773 | if (SvROK(sv)) |
2774 | SvREFCNT_dec(SvRV(sv)); | |
1edc1566 | 2775 | else if (SvPVX(sv) && SvLEN(sv)) |
463ee0b2 | 2776 | Safefree(SvPVX(sv)); |
79072805 | 2777 | break; |
a0d0e21e | 2778 | /* |
79072805 | 2779 | case SVt_NV: |
79072805 | 2780 | case SVt_IV: |
79072805 LW |
2781 | case SVt_NULL: |
2782 | break; | |
a0d0e21e | 2783 | */ |
79072805 LW |
2784 | } |
2785 | ||
2786 | switch (SvTYPE(sv)) { | |
2787 | case SVt_NULL: | |
2788 | break; | |
79072805 LW |
2789 | case SVt_IV: |
2790 | del_XIV(SvANY(sv)); | |
2791 | break; | |
2792 | case SVt_NV: | |
2793 | del_XNV(SvANY(sv)); | |
2794 | break; | |
ed6116ce LW |
2795 | case SVt_RV: |
2796 | del_XRV(SvANY(sv)); | |
2797 | break; | |
79072805 LW |
2798 | case SVt_PV: |
2799 | del_XPV(SvANY(sv)); | |
2800 | break; | |
2801 | case SVt_PVIV: | |
2802 | del_XPVIV(SvANY(sv)); | |
2803 | break; | |
2804 | case SVt_PVNV: | |
2805 | del_XPVNV(SvANY(sv)); | |
2806 | break; | |
2807 | case SVt_PVMG: | |
2808 | del_XPVMG(SvANY(sv)); | |
2809 | break; | |
2810 | case SVt_PVLV: | |
2811 | del_XPVLV(SvANY(sv)); | |
2812 | break; | |
2813 | case SVt_PVAV: | |
2814 | del_XPVAV(SvANY(sv)); | |
2815 | break; | |
2816 | case SVt_PVHV: | |
2817 | del_XPVHV(SvANY(sv)); | |
2818 | break; | |
2819 | case SVt_PVCV: | |
2820 | del_XPVCV(SvANY(sv)); | |
2821 | break; | |
2822 | case SVt_PVGV: | |
2823 | del_XPVGV(SvANY(sv)); | |
2824 | break; | |
2825 | case SVt_PVBM: | |
2826 | del_XPVBM(SvANY(sv)); | |
2827 | break; | |
2828 | case SVt_PVFM: | |
2829 | del_XPVFM(SvANY(sv)); | |
2830 | break; | |
8990e307 LW |
2831 | case SVt_PVIO: |
2832 | del_XPVIO(SvANY(sv)); | |
2833 | break; | |
79072805 | 2834 | } |
a0d0e21e | 2835 | SvFLAGS(sv) &= SVf_BREAK; |
8990e307 | 2836 | SvFLAGS(sv) |= SVTYPEMASK; |
79072805 LW |
2837 | } |
2838 | ||
2839 | SV * | |
8990e307 | 2840 | sv_newref(sv) |
79072805 LW |
2841 | SV* sv; |
2842 | { | |
463ee0b2 LW |
2843 | if (sv) |
2844 | SvREFCNT(sv)++; | |
79072805 LW |
2845 | return sv; |
2846 | } | |
2847 | ||
2848 | void | |
2849 | sv_free(sv) | |
2850 | SV *sv; | |
2851 | { | |
2852 | if (!sv) | |
2853 | return; | |
a0d0e21e LW |
2854 | if (SvREADONLY(sv)) { |
2855 | if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) | |
2856 | return; | |
79072805 | 2857 | } |
a0d0e21e LW |
2858 | if (SvREFCNT(sv) == 0) { |
2859 | if (SvFLAGS(sv) & SVf_BREAK) | |
2860 | return; | |
1edc1566 | 2861 | if (in_clean_all) /* All is fair */ |
2862 | return; | |
79072805 LW |
2863 | warn("Attempt to free unreferenced scalar"); |
2864 | return; | |
2865 | } | |
8990e307 LW |
2866 | if (--SvREFCNT(sv) > 0) |
2867 | return; | |
463ee0b2 LW |
2868 | #ifdef DEBUGGING |
2869 | if (SvTEMP(sv)) { | |
0f15f207 | 2870 | warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); |
79072805 | 2871 | return; |
79072805 | 2872 | } |
463ee0b2 | 2873 | #endif |
79072805 | 2874 | sv_clear(sv); |
477f5d66 CS |
2875 | if (! SvREFCNT(sv)) |
2876 | del_SV(sv); | |
79072805 LW |
2877 | } |
2878 | ||
2879 | STRLEN | |
2880 | sv_len(sv) | |
2881 | register SV *sv; | |
2882 | { | |
748a9306 | 2883 | char *junk; |
463ee0b2 | 2884 | STRLEN len; |
79072805 LW |
2885 | |
2886 | if (!sv) | |
2887 | return 0; | |
2888 | ||
8990e307 LW |
2889 | if (SvGMAGICAL(sv)) |
2890 | len = mg_len(sv); | |
2891 | else | |
748a9306 | 2892 | junk = SvPV(sv, len); |
463ee0b2 | 2893 | return len; |
79072805 LW |
2894 | } |
2895 | ||
2896 | I32 | |
2897 | sv_eq(str1,str2) | |
2898 | register SV *str1; | |
2899 | register SV *str2; | |
2900 | { | |
2901 | char *pv1; | |
463ee0b2 | 2902 | STRLEN cur1; |
79072805 | 2903 | char *pv2; |
463ee0b2 | 2904 | STRLEN cur2; |
79072805 LW |
2905 | |
2906 | if (!str1) { | |
2907 | pv1 = ""; | |
2908 | cur1 = 0; | |
2909 | } | |
463ee0b2 LW |
2910 | else |
2911 | pv1 = SvPV(str1, cur1); | |
79072805 LW |
2912 | |
2913 | if (!str2) | |
2914 | return !cur1; | |
463ee0b2 LW |
2915 | else |
2916 | pv2 = SvPV(str2, cur2); | |
79072805 LW |
2917 | |
2918 | if (cur1 != cur2) | |
2919 | return 0; | |
2920 | ||
36477c24 | 2921 | return memEQ(pv1, pv2, cur1); |
79072805 LW |
2922 | } |
2923 | ||
2924 | I32 | |
bbce6d69 | 2925 | sv_cmp(str1, str2) |
79072805 LW |
2926 | register SV *str1; |
2927 | register SV *str2; | |
2928 | { | |
bbce6d69 | 2929 | STRLEN cur1 = 0; |
2930 | char *pv1 = str1 ? SvPV(str1, cur1) : NULL; | |
2931 | STRLEN cur2 = 0; | |
2932 | char *pv2 = str2 ? SvPV(str2, cur2) : NULL; | |
79072805 | 2933 | I32 retval; |
79072805 | 2934 | |
bbce6d69 | 2935 | if (!cur1) |
2936 | return cur2 ? -1 : 0; | |
16660edb | 2937 | |
bbce6d69 | 2938 | if (!cur2) |
2939 | return 1; | |
79072805 | 2940 | |
bbce6d69 | 2941 | retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); |
16660edb | 2942 | |
bbce6d69 | 2943 | if (retval) |
2944 | return retval < 0 ? -1 : 1; | |
16660edb | 2945 | |
bbce6d69 | 2946 | if (cur1 == cur2) |
2947 | return 0; | |
2948 | else | |
2949 | return cur1 < cur2 ? -1 : 1; | |
2950 | } | |
16660edb | 2951 | |
bbce6d69 | 2952 | I32 |
2953 | sv_cmp_locale(sv1, sv2) | |
2954 | register SV *sv1; | |
2955 | register SV *sv2; | |
2956 | { | |
36477c24 | 2957 | #ifdef USE_LOCALE_COLLATE |
16660edb | 2958 | |
bbce6d69 | 2959 | char *pv1, *pv2; |
2960 | STRLEN len1, len2; | |
2961 | I32 retval; | |
16660edb | 2962 | |
bbce6d69 | 2963 | if (collation_standard) |
2964 | goto raw_compare; | |
16660edb | 2965 | |
bbce6d69 | 2966 | len1 = 0; |
2967 | pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL; | |
2968 | len2 = 0; | |
2969 | pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL; | |
16660edb | 2970 | |
bbce6d69 | 2971 | if (!pv1 || !len1) { |
2972 | if (pv2 && len2) | |
2973 | return -1; | |
2974 | else | |
2975 | goto raw_compare; | |
2976 | } | |
2977 | else { | |
2978 | if (!pv2 || !len2) | |
2979 | return 1; | |
2980 | } | |
16660edb | 2981 | |
bbce6d69 | 2982 | retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); |
16660edb | 2983 | |
bbce6d69 | 2984 | if (retval) |
16660edb | 2985 | return retval < 0 ? -1 : 1; |
2986 | ||
bbce6d69 | 2987 | /* |
2988 | * When the result of collation is equality, that doesn't mean | |
2989 | * that there are no differences -- some locales exclude some | |
2990 | * characters from consideration. So to avoid false equalities, | |
2991 | * we use the raw string as a tiebreaker. | |
2992 | */ | |
16660edb | 2993 | |
bbce6d69 | 2994 | raw_compare: |
2995 | /* FALL THROUGH */ | |
16660edb | 2996 | |
36477c24 | 2997 | #endif /* USE_LOCALE_COLLATE */ |
16660edb | 2998 | |
bbce6d69 | 2999 | return sv_cmp(sv1, sv2); |
3000 | } | |
79072805 | 3001 | |
36477c24 | 3002 | #ifdef USE_LOCALE_COLLATE |
7a4c00b4 | 3003 | /* |
3004 | * Any scalar variable may carry an 'o' magic that contains the | |
3005 | * scalar data of the variable transformed to such a format that | |
3006 | * a normal memory comparison can be used to compare the data | |
3007 | * according to the locale settings. | |
3008 | */ | |
bbce6d69 | 3009 | char * |
3010 | sv_collxfrm(sv, nxp) | |
3011 | SV *sv; | |
3012 | STRLEN *nxp; | |
3013 | { | |
7a4c00b4 | 3014 | MAGIC *mg; |
16660edb | 3015 | |
7a4c00b4 | 3016 | mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL; |
3017 | if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { | |
bbce6d69 | 3018 | char *s, *xf; |
3019 | STRLEN len, xlen; | |
3020 | ||
7a4c00b4 | 3021 | if (mg) |
3022 | Safefree(mg->mg_ptr); | |
bbce6d69 | 3023 | s = SvPV(sv, len); |
3024 | if ((xf = mem_collxfrm(s, len, &xlen))) { | |
ff0cee69 | 3025 | if (SvREADONLY(sv)) { |
3026 | SAVEFREEPV(xf); | |
3027 | *nxp = xlen; | |
fb73857a | 3028 | return xf + sizeof(collation_ix); |
ff0cee69 | 3029 | } |
7a4c00b4 | 3030 | if (! mg) { |
3031 | sv_magic(sv, 0, 'o', 0, 0); | |
3032 | mg = mg_find(sv, 'o'); | |
3033 | assert(mg); | |
bbce6d69 | 3034 | } |
7a4c00b4 | 3035 | mg->mg_ptr = xf; |
3036 | mg->mg_len = xlen; | |
3037 | } | |
3038 | else { | |
ff0cee69 | 3039 | if (mg) { |
3040 | mg->mg_ptr = NULL; | |
3041 | mg->mg_len = -1; | |
3042 | } | |
bbce6d69 | 3043 | } |
3044 | } | |
7a4c00b4 | 3045 | if (mg && mg->mg_ptr) { |
bbce6d69 | 3046 | *nxp = mg->mg_len; |
3047 | return mg->mg_ptr + sizeof(collation_ix); | |
3048 | } | |
3049 | else { | |
3050 | *nxp = 0; | |
3051 | return NULL; | |
16660edb | 3052 | } |
79072805 LW |
3053 | } |
3054 | ||
36477c24 | 3055 | #endif /* USE_LOCALE_COLLATE */ |
bbce6d69 | 3056 | |
79072805 LW |
3057 | char * |
3058 | sv_gets(sv,fp,append) | |
3059 | register SV *sv; | |
760ac839 | 3060 | register PerlIO *fp; |
79072805 LW |
3061 | I32 append; |
3062 | { | |
c07a80fd | 3063 | char *rsptr; |
3064 | STRLEN rslen; | |
3065 | register STDCHAR rslast; | |
3066 | register STDCHAR *bp; | |
3067 | register I32 cnt; | |
3068 | I32 i; | |
3069 | ||
0f15f207 | 3070 | sv_check_thinkfirst(sv); |
79072805 | 3071 | if (!SvUPGRADE(sv, SVt_PV)) |
a0d0e21e | 3072 | return 0; |
ff68c719 | 3073 | SvSCREAM_off(sv); |
c07a80fd | 3074 | |
3075 | if (RsSNARF(rs)) { | |
3076 | rsptr = NULL; | |
3077 | rslen = 0; | |
3078 | } | |
3079 | else if (RsPARA(rs)) { | |
3080 | rsptr = "\n\n"; | |
3081 | rslen = 2; | |
3082 | } | |
3083 | else | |
3084 | rsptr = SvPV(rs, rslen); | |
3085 | rslast = rslen ? rsptr[rslen - 1] : '\0'; | |
3086 | ||
3087 | if (RsPARA(rs)) { /* have to do this both before and after */ | |
79072805 | 3088 | do { /* to make sure file boundaries work right */ |
760ac839 | 3089 | if (PerlIO_eof(fp)) |
a0d0e21e | 3090 | return 0; |
760ac839 | 3091 | i = PerlIO_getc(fp); |
79072805 | 3092 | if (i != '\n') { |
a0d0e21e LW |
3093 | if (i == -1) |
3094 | return 0; | |
760ac839 | 3095 | PerlIO_ungetc(fp,i); |
79072805 LW |
3096 | break; |
3097 | } | |
3098 | } while (i != EOF); | |
3099 | } | |
c07a80fd | 3100 | |
760ac839 LW |
3101 | /* See if we know enough about I/O mechanism to cheat it ! */ |
3102 | ||
3103 | /* This used to be #ifdef test - it is made run-time test for ease | |
3104 | of abstracting out stdio interface. One call should be cheap | |
3105 | enough here - and may even be a macro allowing compile | |
3106 | time optimization. | |
3107 | */ | |
3108 | ||
3109 | if (PerlIO_fast_gets(fp)) { | |
3110 | ||
3111 | /* | |
3112 | * We're going to steal some values from the stdio struct | |
3113 | * and put EVERYTHING in the innermost loop into registers. | |
3114 | */ | |
3115 | register STDCHAR *ptr; | |
3116 | STRLEN bpx; | |
3117 | I32 shortbuffered; | |
3118 | ||
16660edb | 3119 | #if defined(VMS) && defined(PERLIO_IS_STDIO) |
3120 | /* An ungetc()d char is handled separately from the regular | |
3121 | * buffer, so we getc() it back out and stuff it in the buffer. | |
3122 | */ | |
3123 | i = PerlIO_getc(fp); | |
3124 | if (i == EOF) return 0; | |
3125 | *(--((*fp)->_ptr)) = (unsigned char) i; | |
3126 | (*fp)->_cnt++; | |
3127 | #endif | |
c07a80fd | 3128 | |
c2960299 | 3129 | /* Here is some breathtakingly efficient cheating */ |
c07a80fd | 3130 | |
760ac839 | 3131 | cnt = PerlIO_get_cnt(fp); /* get count into register */ |
a0d0e21e | 3132 | (void)SvPOK_only(sv); /* validate pointer */ |
79072805 LW |
3133 | if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ |
3134 | if (cnt > 80 && SvLEN(sv) > append) { | |
3135 | shortbuffered = cnt - SvLEN(sv) + append + 1; | |
3136 | cnt -= shortbuffered; | |
3137 | } | |
3138 | else { | |
3139 | shortbuffered = 0; | |
bbce6d69 | 3140 | /* remember that cnt can be negative */ |
3141 | SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1))); | |
79072805 LW |
3142 | } |
3143 | } | |
3144 | else | |
3145 | shortbuffered = 0; | |
c07a80fd | 3146 | bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ |
760ac839 | 3147 | ptr = (STDCHAR*)PerlIO_get_ptr(fp); |
16660edb | 3148 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3149 | "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); |
16660edb | 3150 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3151 | "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", |
3152 | (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), | |
3153 | (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); | |
79072805 LW |
3154 | for (;;) { |
3155 | screamer: | |
93a17b20 | 3156 | if (cnt > 0) { |
c07a80fd | 3157 | if (rslen) { |
760ac839 LW |
3158 | while (cnt > 0) { /* this | eat */ |
3159 | cnt--; | |
c07a80fd | 3160 | if ((*bp++ = *ptr++) == rslast) /* really | dust */ |
3161 | goto thats_all_folks; /* screams | sed :-) */ | |
3162 | } | |
3163 | } | |
3164 | else { | |
36477c24 | 3165 | Copy(ptr, bp, cnt, char); /* this | eat */ |
c07a80fd | 3166 | bp += cnt; /* screams | dust */ |
3167 | ptr += cnt; /* louder | sed :-) */ | |
a5f75d66 | 3168 | cnt = 0; |
93a17b20 | 3169 | } |
79072805 LW |
3170 | } |
3171 | ||
748a9306 | 3172 | if (shortbuffered) { /* oh well, must extend */ |
79072805 LW |
3173 | cnt = shortbuffered; |
3174 | shortbuffered = 0; | |
c07a80fd | 3175 | bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ |
79072805 LW |
3176 | SvCUR_set(sv, bpx); |
3177 | SvGROW(sv, SvLEN(sv) + append + cnt + 2); | |
c07a80fd | 3178 | bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ |
79072805 LW |
3179 | continue; |
3180 | } | |
3181 | ||
16660edb | 3182 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3183 | "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); |
d1bf51dd | 3184 | PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ |
16660edb | 3185 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3186 | "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", |
3187 | (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), | |
3188 | (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); | |
16660edb | 3189 | /* This used to call 'filbuf' in stdio form, but as that behaves like |
774d564b | 3190 | getc when cnt <= 0 we use PerlIO_getc here to avoid introducing |
3191 | another abstraction. */ | |
760ac839 | 3192 | i = PerlIO_getc(fp); /* get more characters */ |
16660edb | 3193 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3194 | "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", |
3195 | (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), | |
3196 | (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); | |
760ac839 LW |
3197 | cnt = PerlIO_get_cnt(fp); |
3198 | ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ | |
16660edb | 3199 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3200 | "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); |
79072805 | 3201 | |
748a9306 LW |
3202 | if (i == EOF) /* all done for ever? */ |
3203 | goto thats_really_all_folks; | |
3204 | ||
c07a80fd | 3205 | bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ |
79072805 LW |
3206 | SvCUR_set(sv, bpx); |
3207 | SvGROW(sv, bpx + cnt + 2); | |
c07a80fd | 3208 | bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ |
3209 | ||
760ac839 | 3210 | *bp++ = i; /* store character from PerlIO_getc */ |
79072805 | 3211 | |
c07a80fd | 3212 | if (rslen && (STDCHAR)i == rslast) /* all done for now? */ |
79072805 | 3213 | goto thats_all_folks; |
79072805 LW |
3214 | } |
3215 | ||
3216 | thats_all_folks: | |
c07a80fd | 3217 | if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || |
36477c24 | 3218 | memNE((char*)bp - rslen, rsptr, rslen)) |
760ac839 | 3219 | goto screamer; /* go back to the fray */ |
79072805 LW |
3220 | thats_really_all_folks: |
3221 | if (shortbuffered) | |
3222 | cnt += shortbuffered; | |
16660edb | 3223 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3224 | "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); |
d1bf51dd | 3225 | PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ |
16660edb | 3226 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
68dc0745 | 3227 | "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", |
3228 | (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), | |
3229 | (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); | |
79072805 | 3230 | *bp = '\0'; |
760ac839 | 3231 | SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ |
16660edb | 3232 | DEBUG_P(PerlIO_printf(Perl_debug_log, |
fb73857a | 3233 | "Screamer: done, len=%ld, string=|%.*s|\n", |
3234 | (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); | |
760ac839 LW |
3235 | } |
3236 | else | |
79072805 | 3237 | { |
760ac839 | 3238 | /*The big, slow, and stupid way */ |
c07a80fd | 3239 | STDCHAR buf[8192]; |
79072805 | 3240 | |
760ac839 | 3241 | screamer2: |
c07a80fd | 3242 | if (rslen) { |
760ac839 LW |
3243 | register STDCHAR *bpe = buf + sizeof(buf); |
3244 | bp = buf; | |
3245 | while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) | |
3246 | ; /* keep reading */ | |
3247 | cnt = bp - buf; | |
c07a80fd | 3248 | } |
3249 | else { | |
760ac839 | 3250 | cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); |
16660edb | 3251 | /* Accomodate broken VAXC compiler, which applies U8 cast to |
3252 | * both args of ?: operator, causing EOF to change into 255 | |
3253 | */ | |
3254 | if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } | |
c07a80fd | 3255 | } |
79072805 LW |
3256 | |
3257 | if (append) | |
760ac839 | 3258 | sv_catpvn(sv, (char *) buf, cnt); |
79072805 | 3259 | else |
760ac839 | 3260 | sv_setpvn(sv, (char *) buf, cnt); |
c07a80fd | 3261 | |
3262 | if (i != EOF && /* joy */ | |
3263 | (!rslen || | |
3264 | SvCUR(sv) < rslen || | |
36477c24 | 3265 | memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) |
79072805 LW |
3266 | { |
3267 | append = -1; | |
63e4d877 CS |
3268 | /* |
3269 | * If we're reading from a TTY and we get a short read, | |
3270 | * indicating that the user hit his EOF character, we need | |
3271 | * to notice it now, because if we try to read from the TTY | |
3272 | * again, the EOF condition will disappear. | |
3273 | * | |
3274 | * The comparison of cnt to sizeof(buf) is an optimization | |
3275 | * that prevents unnecessary calls to feof(). | |
3276 | * | |
3277 | * - jik 9/25/96 | |
3278 | */ | |
3279 | if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) | |
3280 | goto screamer2; | |
79072805 LW |
3281 | } |
3282 | } | |
3283 | ||
c07a80fd | 3284 | if (RsPARA(rs)) { /* have to do this both before and after */ |
3285 | while (i != EOF) { /* to make sure file boundaries work right */ | |
760ac839 | 3286 | i = PerlIO_getc(fp); |
79072805 | 3287 | if (i != '\n') { |
760ac839 | 3288 | PerlIO_ungetc(fp,i); |
79072805 LW |
3289 | break; |
3290 | } | |
3291 | } | |
3292 | } | |
c07a80fd | 3293 | |
3294 | return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; | |
79072805 LW |
3295 | } |
3296 | ||
760ac839 | 3297 | |
79072805 LW |
3298 | void |
3299 | sv_inc(sv) | |
3300 | register SV *sv; | |
3301 | { | |
3302 | register char *d; | |
463ee0b2 | 3303 | int flags; |
79072805 LW |
3304 | |
3305 | if (!sv) | |
3306 | return; | |
ed6116ce | 3307 | if (SvTHINKFIRST(sv)) { |
0f15f207 MB |
3308 | if (SvREADONLY(sv)) { |
3309 | dTHR; | |
3310 | if (curcop != &compiling) | |
3311 | croak(no_modify); | |
3312 | } | |
a0d0e21e LW |
3313 | if (SvROK(sv)) { |
3314 | #ifdef OVERLOAD | |
3315 | if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; | |
3316 | #endif /* OVERLOAD */ | |
3317 | sv_unref(sv); | |
3318 | } | |
ed6116ce | 3319 | } |
8990e307 | 3320 | if (SvGMAGICAL(sv)) |
79072805 | 3321 | mg_get(sv); |
8990e307 | 3322 | flags = SvFLAGS(sv); |
8990e307 | 3323 | if (flags & SVp_NOK) { |
a0d0e21e | 3324 | (void)SvNOK_only(sv); |
55497cff | 3325 | SvNVX(sv) += 1.0; |
3326 | return; | |
3327 | } | |
3328 | if (flags & SVp_IOK) { | |
3329 | if (SvIVX(sv) == IV_MAX) | |
3330 | sv_setnv(sv, (double)IV_MAX + 1.0); | |
3331 | else { | |
3332 | (void)SvIOK_only(sv); | |
3333 | ++SvIVX(sv); | |
3334 | } | |
79072805 LW |
3335 | return; |
3336 | } | |
8990e307 | 3337 | if (!(flags & SVp_POK) || !*SvPVX(sv)) { |
4633a7c4 LW |
3338 | if ((flags & SVTYPEMASK) < SVt_PVNV) |
3339 | sv_upgrade(sv, SVt_NV); | |
463ee0b2 | 3340 | SvNVX(sv) = 1.0; |
a0d0e21e | 3341 | (void)SvNOK_only(sv); |
79072805 LW |
3342 | return; |
3343 | } | |
463ee0b2 | 3344 | d = SvPVX(sv); |
79072805 LW |
3345 | while (isALPHA(*d)) d++; |
3346 | while (isDIGIT(*d)) d++; | |
3347 | if (*d) { | |
36477c24 | 3348 | SET_NUMERIC_STANDARD(); |
bbce6d69 | 3349 | sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */ |
79072805 LW |
3350 | return; |
3351 | } | |
3352 | d--; | |
463ee0b2 | 3353 | while (d >= SvPVX(sv)) { |
79072805 LW |
3354 | if (isDIGIT(*d)) { |
3355 | if (++*d <= '9') | |
3356 | return; | |
3357 | *(d--) = '0'; | |
3358 | } | |
3359 | else { | |
3360 | ++*d; | |
3361 | if (isALPHA(*d)) | |
3362 | return; | |
3363 | *(d--) -= 'z' - 'a' + 1; | |
3364 | } | |
3365 | } | |
3366 | /* oh,oh, the number grew */ | |
3367 | SvGROW(sv, SvCUR(sv) + 2); | |
3368 | SvCUR(sv)++; | |
463ee0b2 | 3369 | for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--) |
79072805 LW |
3370 | *d = d[-1]; |
3371 | if (isDIGIT(d[1])) | |
3372 | *d = '1'; | |
3373 | else | |
3374 | *d = d[1]; | |
3375 | } | |
3376 | ||
3377 | void | |
3378 | sv_dec(sv) | |
3379 | register SV *sv; | |
3380 | { | |
463ee0b2 LW |
3381 | int flags; |
3382 | ||
79072805 LW |
3383 | if (!sv) |
3384 | return; | |
ed6116ce | 3385 | if (SvTHINKFIRST(sv)) { |
0f15f207 MB |
3386 | if (SvREADONLY(sv)) { |
3387 | dTHR; | |
3388 | if (curcop != &compiling) | |
3389 | croak(no_modify); | |
3390 | } | |
a0d0e21e LW |
3391 | if (SvROK(sv)) { |
3392 | #ifdef OVERLOAD | |
3393 | if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; | |
3394 | #endif /* OVERLOAD */ | |
3395 | sv_unref(sv); | |
3396 | } | |
ed6116ce | 3397 | } |
8990e307 | 3398 | if (SvGMAGICAL(sv)) |
79072805 | 3399 | mg_get(sv); |
8990e307 | 3400 | flags = SvFLAGS(sv); |
8990e307 | 3401 | if (flags & SVp_NOK) { |
463ee0b2 | 3402 | SvNVX(sv) -= 1.0; |
a0d0e21e | 3403 | (void)SvNOK_only(sv); |
79072805 LW |
3404 | return; |
3405 | } | |
55497cff | 3406 | if (flags & SVp_IOK) { |
3407 | if (SvIVX(sv) == IV_MIN) | |
3408 | sv_setnv(sv, (double)IV_MIN - 1.0); | |
3409 | else { | |
3410 | (void)SvIOK_only(sv); | |
3411 | --SvIVX(sv); | |
3412 | } | |
3413 | return; | |
3414 | } | |
8990e307 | 3415 | if (!(flags & SVp_POK)) { |
4633a7c4 LW |
3416 | if ((flags & SVTYPEMASK) < SVt_PVNV) |
3417 | sv_upgrade(sv, SVt_NV); | |
463ee0b2 | 3418 | SvNVX(sv) = -1.0; |
a0d0e21e | 3419 | (void)SvNOK_only(sv); |
79072805 LW |
3420 | return; |
3421 | } | |
36477c24 | 3422 | SET_NUMERIC_STANDARD(); |
bbce6d69 | 3423 | sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */ |
79072805 LW |
3424 | } |
3425 | ||
3426 | /* Make a string that will exist for the duration of the expression | |
3427 | * evaluation. Actually, it may have to last longer than that, but | |
3428 | * hopefully we won't free it until it has been assigned to a | |
3429 | * permanent location. */ | |
3430 | ||
8990e307 LW |
3431 | static void |
3432 | sv_mortalgrow() | |
3433 | { | |
11343788 | 3434 | dTHR; |
55497cff | 3435 | tmps_max += (tmps_max < 512) ? 128 : 512; |
8990e307 LW |
3436 | Renew(tmps_stack, tmps_max, SV*); |
3437 | } | |
3438 | ||
79072805 LW |
3439 | SV * |
3440 | sv_mortalcopy(oldstr) | |
3441 | SV *oldstr; | |
3442 | { | |
11343788 | 3443 | dTHR; |
463ee0b2 | 3444 | register SV *sv; |
79072805 | 3445 | |
4561caa4 | 3446 | new_SV(sv); |
8990e307 LW |
3447 | SvANY(sv) = 0; |
3448 | SvREFCNT(sv) = 1; | |
3449 | SvFLAGS(sv) = 0; | |
79072805 | 3450 | sv_setsv(sv,oldstr); |
8990e307 LW |
3451 | if (++tmps_ix >= tmps_max) |
3452 | sv_mortalgrow(); | |
3453 | tmps_stack[tmps_ix] = sv; | |
3454 | SvTEMP_on(sv); | |
3455 | return sv; | |
3456 | } | |
3457 | ||
3458 | SV * | |
3459 | sv_newmortal() | |
3460 | { | |
11343788 | 3461 | dTHR; |
8990e307 LW |
3462 | register SV *sv; |
3463 | ||
4561caa4 | 3464 | new_SV(sv); |
8990e307 LW |
3465 | SvANY(sv) = 0; |
3466 | SvREFCNT(sv) = 1; | |
3467 | SvFLAGS(sv) = SVs_TEMP; | |
3468 | if (++tmps_ix >= tmps_max) | |
3469 | sv_mortalgrow(); | |
79072805 | 3470 | tmps_stack[tmps_ix] = sv; |
79072805 LW |
3471 | return sv; |
3472 | } | |
3473 | ||
3474 | /* same thing without the copying */ | |
3475 | ||
3476 | SV * | |
3477 | sv_2mortal(sv) | |
3478 | register SV *sv; | |
3479 | { | |
11343788 | 3480 | dTHR; |
79072805 LW |
3481 | if (!sv) |
3482 | return sv; | |
a0d0e21e LW |
3483 | if (SvREADONLY(sv) && curcop != &compiling) |
3484 | croak(no_modify); | |
8990e307 LW |
3485 | if (++tmps_ix >= tmps_max) |
3486 | sv_mortalgrow(); | |
79072805 | 3487 | tmps_stack[tmps_ix] = sv; |
8990e307 | 3488 | SvTEMP_on(sv); |
79072805 LW |
3489 | return sv; |
3490 | } | |
3491 | ||
3492 | SV * | |
3493 | newSVpv(s,len) | |
3494 | char *s; | |
3495 | STRLEN len; | |
3496 | { | |
463ee0b2 | 3497 | register SV *sv; |
79072805 | 3498 | |
4561caa4 | 3499 | new_SV(sv); |
8990e307 LW |
3500 | SvANY(sv) = 0; |
3501 | SvREFCNT(sv) = 1; | |
3502 | SvFLAGS(sv) = 0; | |
79072805 LW |
3503 | if (!len) |
3504 | len = strlen(s); | |
3505 | sv_setpvn(sv,s,len); | |
3506 | return sv; | |
3507 | } | |
3508 | ||
46fc3d4c | 3509 | #ifdef I_STDARG |
3510 | SV * | |
3511 | newSVpvf(const char* pat, ...) | |
3512 | #else | |
3513 | /*VARARGS0*/ | |
3514 | SV * | |
fc36a67e | 3515 | newSVpvf(pat, va_alist) |
46fc3d4c | 3516 | const char *pat; |
3517 | va_dcl | |
3518 | #endif | |
3519 | { | |
3520 | register SV *sv; | |
3521 | va_list args; | |
3522 | ||
3523 | new_SV(sv); | |
3524 | SvANY(sv) = 0; | |
3525 | SvREFCNT(sv) = 1; | |
3526 | SvFLAGS(sv) = 0; | |
3527 | #ifdef I_STDARG | |
3528 | va_start(args, pat); | |
3529 | #else | |
3530 | va_start(args); | |
3531 | #endif | |
fc36a67e | 3532 | sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
46fc3d4c | 3533 | va_end(args); |
3534 | return sv; | |
3535 | } | |
3536 | ||
3537 | ||
79072805 LW |
3538 | SV * |
3539 | newSVnv(n) | |
3540 | double n; | |
3541 | { | |
463ee0b2 | 3542 | register SV *sv; |
79072805 | 3543 | |
4561caa4 | 3544 | new_SV(sv); |
8990e307 LW |
3545 | SvANY(sv) = 0; |
3546 | SvREFCNT(sv) = 1; | |
3547 | SvFLAGS(sv) = 0; | |
79072805 LW |
3548 | sv_setnv(sv,n); |
3549 | return sv; | |
3550 | } | |
3551 | ||
3552 | SV * | |
3553 | newSViv(i) | |
a0d0e21e | 3554 | IV i; |
79072805 | 3555 | { |
463ee0b2 | 3556 | register SV *sv; |
79072805 | 3557 | |
4561caa4 | 3558 | new_SV(sv); |
8990e307 LW |
3559 | SvANY(sv) = 0; |
3560 | SvREFCNT(sv) = 1; | |
3561 | SvFLAGS(sv) = 0; | |
79072805 LW |
3562 | sv_setiv(sv,i); |
3563 | return sv; | |
3564 | } | |
3565 | ||
2304df62 AD |
3566 | SV * |
3567 | newRV(ref) | |
3568 | SV *ref; | |
3569 | { | |
11343788 | 3570 | dTHR; |
2304df62 AD |
3571 | register SV *sv; |
3572 | ||
4561caa4 | 3573 | new_SV(sv); |
2304df62 AD |
3574 | SvANY(sv) = 0; |
3575 | SvREFCNT(sv) = 1; | |
3576 | SvFLAGS(sv) = 0; | |
3577 | sv_upgrade(sv, SVt_RV); | |
a0d0e21e | 3578 | SvTEMP_off(ref); |
2304df62 AD |
3579 | SvRV(sv) = SvREFCNT_inc(ref); |
3580 | SvROK_on(sv); | |
2304df62 AD |
3581 | return sv; |
3582 | } | |
3583 | ||
5f05dabc | 3584 | #ifdef CRIPPLED_CC |
3585 | SV * | |
3586 | newRV_noinc(ref) | |
3587 | SV *ref; | |
3588 | { | |
3589 | register SV *sv; | |
3590 | ||
3591 | sv = newRV(ref); | |
3592 | SvREFCNT_dec(ref); | |
3593 | return sv; | |
3594 | } | |
3595 | #endif /* CRIPPLED_CC */ | |
3596 | ||
79072805 LW |
3597 | /* make an exact duplicate of old */ |
3598 | ||
3599 | SV * | |
3600 | newSVsv(old) | |
3601 | register SV *old; | |
3602 | { | |
463ee0b2 | 3603 | register SV *sv; |
79072805 LW |
3604 | |
3605 | if (!old) | |
3606 | return Nullsv; | |
8990e307 | 3607 | if (SvTYPE(old) == SVTYPEMASK) { |
79072805 LW |
3608 | warn("semi-panic: attempt to dup freed string"); |
3609 | return Nullsv; | |
3610 | } | |
4561caa4 | 3611 | new_SV(sv); |
8990e307 LW |
3612 | SvANY(sv) = 0; |
3613 | SvREFCNT(sv) = 1; | |
3614 | SvFLAGS(sv) = 0; | |
ff68c719 | 3615 | if (SvTEMP(old)) { |
3616 | SvTEMP_off(old); | |
463ee0b2 | 3617 | sv_setsv(sv,old); |
ff68c719 | 3618 | SvTEMP_on(old); |
79072805 LW |
3619 | } |
3620 | else | |
463ee0b2 LW |
3621 | sv_setsv(sv,old); |
3622 | return sv; | |
79072805 LW |
3623 | } |
3624 | ||
3625 | void | |
3626 | sv_reset(s,stash) | |
3627 | register char *s; | |
3628 | HV *stash; | |
3629 | { | |
3630 | register HE *entry; | |
3631 | register GV *gv; | |
3632 | register SV *sv; | |
3633 | register I32 i; | |
3634 | register PMOP *pm; | |
3635 | register I32 max; | |
463ee0b2 | 3636 | char todo[256]; |
79072805 LW |
3637 | |
3638 | if (!*s) { /* reset ?? searches */ | |
3639 | for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { | |
3640 | pm->op_pmflags &= ~PMf_USED; | |
3641 | } | |
3642 | return; | |
3643 | } | |
3644 | ||
3645 | /* reset variables */ | |
3646 | ||
3647 | if (!HvARRAY(stash)) | |
3648 | return; | |
463ee0b2 LW |
3649 | |
3650 | Zero(todo, 256, char); | |
79072805 LW |
3651 | while (*s) { |
3652 | i = *s; | |
3653 | if (s[1] == '-') { | |
3654 | s += 2; | |
3655 | } | |
3656 | max = *s++; | |
3657 | for ( ; i <= max; i++) { | |
463ee0b2 LW |
3658 | todo[i] = 1; |
3659 | } | |
a0d0e21e | 3660 | for (i = 0; i <= (I32) HvMAX(stash); i++) { |
79072805 LW |
3661 | for (entry = HvARRAY(stash)[i]; |
3662 | entry; | |
1edc1566 | 3663 | entry = HeNEXT(entry)) { |
3664 | if (!todo[(U8)*HeKEY(entry)]) | |
463ee0b2 | 3665 | continue; |
1edc1566 | 3666 | gv = (GV*)HeVAL(entry); |
79072805 | 3667 | sv = GvSV(gv); |
a0d0e21e | 3668 | (void)SvOK_off(sv); |
79072805 LW |
3669 | if (SvTYPE(sv) >= SVt_PV) { |
3670 | SvCUR_set(sv, 0); | |
463ee0b2 LW |
3671 | if (SvPVX(sv) != Nullch) |
3672 | *SvPVX(sv) = '\0'; | |
44a8e56a | 3673 | SvTAINT(sv); |
79072805 LW |
3674 | } |
3675 | if (GvAV(gv)) { | |
3676 | av_clear(GvAV(gv)); | |
3677 | } | |
44a8e56a | 3678 | if (GvHV(gv) && !HvNAME(GvHV(gv))) { |
463ee0b2 | 3679 | hv_clear(GvHV(gv)); |
a0d0e21e | 3680 | #ifndef VMS /* VMS has no environ array */ |
79072805 LW |
3681 | if (gv == envgv) |
3682 | environ[0] = Nullch; | |
a0d0e21e | 3683 | #endif |
79072805 LW |
3684 | } |
3685 | } | |
3686 | } | |
3687 | } | |
3688 | } | |
3689 | ||
46fc3d4c | 3690 | IO* |
3691 | sv_2io(sv) | |
3692 | SV *sv; | |
3693 | { | |
3694 | IO* io; | |
3695 | GV* gv; | |
3696 | ||
3697 | switch (SvTYPE(sv)) { | |
3698 | case SVt_PVIO: | |
3699 | io = (IO*)sv; | |
3700 | break; | |
3701 | case SVt_PVGV: | |
3702 | gv = (GV*)sv; | |
3703 | io = GvIO(gv); | |
3704 | if (!io) | |
3705 | croak("Bad filehandle: %s", GvNAME(gv)); | |
3706 | break; | |
3707 | default: | |
3708 | if (!SvOK(sv)) | |
3709 | croak(no_usym, "filehandle"); | |
3710 | if (SvROK(sv)) | |
3711 | return sv_2io(SvRV(sv)); | |
3712 | gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); | |
3713 | if (gv) | |
3714 | io = GvIO(gv); | |
3715 | else | |
3716 | io = 0; | |
3717 | if (!io) | |
3718 | croak("Bad filehandle: %s", SvPV(sv,na)); | |
3719 | break; | |
3720 | } | |
3721 | return io; | |
3722 | } | |
3723 | ||
79072805 LW |
3724 | CV * |
3725 | sv_2cv(sv, st, gvp, lref) | |
3726 | SV *sv; | |
3727 | HV **st; | |
3728 | GV **gvp; | |
3729 | I32 lref; | |
3730 | { | |
3731 | GV *gv; | |
3732 | CV *cv; | |
3733 | ||
3734 | if (!sv) | |
93a17b20 | 3735 | return *gvp = Nullgv, Nullcv; |
79072805 | 3736 | switch (SvTYPE(sv)) { |
79072805 LW |
3737 | case SVt_PVCV: |
3738 | *st = CvSTASH(sv); | |
3739 | *gvp = Nullgv; | |
3740 | return (CV*)sv; | |
3741 | case SVt_PVHV: | |
3742 | case SVt_PVAV: | |
3743 | *gvp = Nullgv; | |
3744 | return Nullcv; | |
8990e307 LW |
3745 | case SVt_PVGV: |
3746 | gv = (GV*)sv; | |
a0d0e21e | 3747 | *gvp = gv; |
8990e307 LW |
3748 | *st = GvESTASH(gv); |
3749 | goto fix_gv; | |
3750 | ||
79072805 | 3751 | default: |
a0d0e21e LW |
3752 | if (SvGMAGICAL(sv)) |
3753 | mg_get(sv); | |
3754 | if (SvROK(sv)) { | |
3755 | cv = (CV*)SvRV(sv); | |
3756 | if (SvTYPE(cv) != SVt_PVCV) | |
3757 | croak("Not a subroutine reference"); | |
3758 | *gvp = Nullgv; | |
3759 | *st = CvSTASH(cv); | |
3760 | return cv; | |
3761 | } | |
79072805 LW |
3762 | if (isGV(sv)) |
3763 | gv = (GV*)sv; | |
3764 | else | |
85e6fe83 | 3765 | gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV); |
79072805 LW |
3766 | *gvp = gv; |
3767 | if (!gv) | |
3768 | return Nullcv; | |
3769 | *st = GvESTASH(gv); | |
8990e307 | 3770 | fix_gv: |
8ebc5c01 | 3771 | if (lref && !GvCVu(gv)) { |
4633a7c4 | 3772 | SV *tmpsv; |
748a9306 | 3773 | ENTER; |
4633a7c4 | 3774 | tmpsv = NEWSV(704,0); |
16660edb | 3775 | gv_efullname3(tmpsv, gv, Nullch); |
774d564b | 3776 | newSUB(start_subparse(FALSE, 0), |
4633a7c4 LW |
3777 | newSVOP(OP_CONST, 0, tmpsv), |
3778 | Nullop, | |
8990e307 | 3779 | Nullop); |
748a9306 | 3780 | LEAVE; |
8ebc5c01 | 3781 | if (!GvCVu(gv)) |
4633a7c4 | 3782 | croak("Unable to create sub named \"%s\"", SvPV(sv,na)); |
8990e307 | 3783 | } |
8ebc5c01 | 3784 | return GvCVu(gv); |
79072805 LW |
3785 | } |
3786 | } | |
3787 | ||
3788 | #ifndef SvTRUE | |
3789 | I32 | |
3790 | SvTRUE(sv) | |
3791 | register SV *sv; | |
3792 | { | |
8990e307 LW |
3793 | if (!sv) |
3794 | return 0; | |
3795 | if (SvGMAGICAL(sv)) | |
79072805 LW |
3796 | mg_get(sv); |
3797 | if (SvPOK(sv)) { | |
3798 | register XPV* Xpv; | |
3799 | if ((Xpv = (XPV*)SvANY(sv)) && | |
3800 | (*Xpv->xpv_pv > '0' || | |
3801 | Xpv->xpv_cur > 1 || | |
3802 | (Xpv->xpv_cur && *Xpv->xpv_pv != '0'))) | |
3803 | return 1; | |
3804 | else | |
3805 | return 0; | |
3806 | } | |
3807 | else { | |
3808 | if (SvIOK(sv)) | |
463ee0b2 | 3809 | return SvIVX(sv) != 0; |
79072805 LW |
3810 | else { |
3811 | if (SvNOK(sv)) | |
463ee0b2 | 3812 | return SvNVX(sv) != 0.0; |
79072805 | 3813 | else |
463ee0b2 | 3814 | return sv_2bool(sv); |
79072805 LW |
3815 | } |
3816 | } | |
3817 | } | |
ff68c719 | 3818 | #endif /* !SvTRUE */ |
79072805 | 3819 | |
85e6fe83 | 3820 | #ifndef SvIV |
ff68c719 | 3821 | IV |
3822 | SvIV(sv) | |
3823 | register SV *sv; | |
85e6fe83 | 3824 | { |
ff68c719 | 3825 | if (SvIOK(sv)) |
3826 | return SvIVX(sv); | |
3827 | return sv_2iv(sv); | |
85e6fe83 | 3828 | } |
ff68c719 | 3829 | #endif /* !SvIV */ |
85e6fe83 | 3830 | |
ff68c719 | 3831 | #ifndef SvUV |
3832 | UV | |
3833 | SvUV(sv) | |
3834 | register SV *sv; | |
3835 | { | |
3836 | if (SvIOK(sv)) | |
3837 | return SvUVX(sv); | |
3838 | return sv_2uv(sv); | |
3839 | } | |
3840 | #endif /* !SvUV */ | |
85e6fe83 | 3841 | |
463ee0b2 | 3842 | #ifndef SvNV |
ff68c719 | 3843 | double |