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