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