This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Delta delta.
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, 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 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
12 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805
LW
13 */
14
15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_MG_C
79072805
LW
17#include "perl.h"
18
5cd24f17 19#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS
20# ifndef NGROUPS
21# define NGROUPS 32
22# endif
b7953727
JH
23# ifdef I_GRP
24# include <grp.h>
25# endif
188ea221
CS
26#endif
27
51371543
GS
28static void restore_magic(pTHXo_ void *p);
29static void unwind_handler_stack(pTHXo_ void *p);
30
c07a80fd
PP
31/*
32 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
33 */
34
35struct magic_state {
36 SV* mgs_sv;
37 U32 mgs_flags;
455ece5e 38 I32 mgs_ss_ix;
c07a80fd 39};
455ece5e 40/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
41
42STATIC void
8fb26106 43S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 44{
455ece5e 45 MGS* mgs;
c07a80fd
PP
46 assert(SvMAGICAL(sv));
47
685f876f 48 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
49
50 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd
PP
51 mgs->mgs_sv = sv;
52 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 53 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd
PP
54
55 SvMAGICAL_off(sv);
56 SvREADONLY_off(sv);
06759ea0 57 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd
PP
58}
59
954c1994
GS
60/*
61=for apidoc mg_magical
62
63Turns on the magical status of an SV. See C<sv_magic>.
64
65=cut
66*/
67
8990e307 68void
864dbfa3 69Perl_mg_magical(pTHX_ SV *sv)
8990e307
LW
70{
71 MAGIC* mg;
72 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
73 MGVTBL* vtbl = mg->mg_virtual;
74 if (vtbl) {
2b260de0 75 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
76 SvGMAGICAL_on(sv);
77 if (vtbl->svt_set)
78 SvSMAGICAL_on(sv);
2b260de0 79 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307
LW
80 SvRMAGICAL_on(sv);
81 }
82 }
83}
84
954c1994
GS
85/*
86=for apidoc mg_get
87
88Do magic after a value is retrieved from the SV. See C<sv_magic>.
89
90=cut
91*/
92
79072805 93int
864dbfa3 94Perl_mg_get(pTHX_ SV *sv)
79072805 95{
8fb26106 96 I32 mgs_ix;
79072805 97 MAGIC* mg;
c6496cc7 98 MAGIC** mgp;
760ac839 99 int mgp_valid = 0;
463ee0b2 100
455ece5e
AD
101 mgs_ix = SSNEW(sizeof(MGS));
102 save_magic(mgs_ix, sv);
463ee0b2 103
c6496cc7
PP
104 mgp = &SvMAGIC(sv);
105 while ((mg = *mgp) != 0) {
79072805 106 MGVTBL* vtbl = mg->mg_virtual;
2b260de0 107 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 108 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
c6496cc7 109 /* Ignore this magic if it's been deleted */
48e43a1c
CS
110 if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
111 (mg->mg_flags & MGf_GSKIP))
455ece5e 112 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 113 }
c6496cc7 114 /* Advance to next magic (complicated by possible deletion) */
760ac839 115 if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
c6496cc7 116 mgp = &mg->mg_moremagic;
760ac839
LW
117 mgp_valid = 1;
118 }
119 else
120 mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
79072805 121 }
463ee0b2 122
685f876f 123 restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW
124 return 0;
125}
126
954c1994
GS
127/*
128=for apidoc mg_set
129
130Do magic after a value is assigned to the SV. See C<sv_magic>.
131
132=cut
133*/
134
79072805 135int
864dbfa3 136Perl_mg_set(pTHX_ SV *sv)
79072805 137{
8fb26106 138 I32 mgs_ix;
79072805 139 MAGIC* mg;
463ee0b2
LW
140 MAGIC* nextmg;
141
455ece5e
AD
142 mgs_ix = SSNEW(sizeof(MGS));
143 save_magic(mgs_ix, sv);
463ee0b2
LW
144
145 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
79072805 146 MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 147 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
148 if (mg->mg_flags & MGf_GSKIP) {
149 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 150 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 151 }
2b260de0 152 if (vtbl && vtbl->svt_set)
fc0dc3b3 153 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
79072805 154 }
463ee0b2 155
685f876f 156 restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW
157 return 0;
158}
159
954c1994
GS
160/*
161=for apidoc mg_length
162
163Report on the SV's length. See C<sv_magic>.
164
165=cut
166*/
167
79072805 168U32
864dbfa3 169Perl_mg_length(pTHX_ SV *sv)
79072805
LW
170{
171 MAGIC* mg;
748a9306 172 char *junk;
463ee0b2 173 STRLEN len;
463ee0b2 174
79072805
LW
175 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
176 MGVTBL* vtbl = mg->mg_virtual;
2b260de0 177 if (vtbl && vtbl->svt_len) {
8fb26106 178 I32 mgs_ix;
48e43a1c 179
455ece5e
AD
180 mgs_ix = SSNEW(sizeof(MGS));
181 save_magic(mgs_ix, sv);
a0d0e21e 182 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 183 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
685f876f 184 restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
185 return len;
186 }
187 }
188
748a9306 189 junk = SvPV(sv, len);
463ee0b2 190 return len;
79072805
LW
191}
192
8fb26106 193I32
864dbfa3 194Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
195{
196 MAGIC* mg;
197 I32 len;
ac27b0f5 198
93965878
NIS
199 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
200 MGVTBL* vtbl = mg->mg_virtual;
2b260de0 201 if (vtbl && vtbl->svt_len) {
8fb26106 202 I32 mgs_ix;
455ece5e
AD
203
204 mgs_ix = SSNEW(sizeof(MGS));
205 save_magic(mgs_ix, sv);
93965878 206 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 207 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
685f876f 208 restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
209 return len;
210 }
211 }
212
213 switch(SvTYPE(sv)) {
214 case SVt_PVAV:
215 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
216 return len;
217 case SVt_PVHV:
218 /* FIXME */
219 default:
cea2e8a9 220 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
221 break;
222 }
223 return 0;
224}
225
954c1994
GS
226/*
227=for apidoc mg_clear
228
229Clear something magical that the SV represents. See C<sv_magic>.
230
231=cut
232*/
233
79072805 234int
864dbfa3 235Perl_mg_clear(pTHX_ SV *sv)
79072805 236{
8fb26106 237 I32 mgs_ix;
79072805 238 MAGIC* mg;
463ee0b2 239
455ece5e
AD
240 mgs_ix = SSNEW(sizeof(MGS));
241 save_magic(mgs_ix, sv);
463ee0b2 242
79072805
LW
243 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
244 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e
LW
245 /* omit GSKIP -- never set here */
246
2b260de0 247 if (vtbl && vtbl->svt_clear)
fc0dc3b3 248 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 249 }
463ee0b2 250
685f876f 251 restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW
252 return 0;
253}
254
954c1994
GS
255/*
256=for apidoc mg_find
257
258Finds the magic pointer for type matching the SV. See C<sv_magic>.
259
260=cut
261*/
262
93a17b20 263MAGIC*
864dbfa3 264Perl_mg_find(pTHX_ SV *sv, int type)
93a17b20
LW
265{
266 MAGIC* mg;
3f8f4626
DC
267 if (!sv)
268 return 0;
93a17b20
LW
269 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
270 if (mg->mg_type == type)
271 return mg;
272 }
273 return 0;
274}
275
954c1994
GS
276/*
277=for apidoc mg_copy
278
279Copies the magic from one SV to another. See C<sv_magic>.
280
281=cut
282*/
283
79072805 284int
864dbfa3 285Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 286{
463ee0b2 287 int count = 0;
79072805 288 MAGIC* mg;
463ee0b2
LW
289 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
290 if (isUPPER(mg->mg_type)) {
33c27489 291 sv_magic(nsv,
14befaf4
DM
292 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
293 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
294 ? sv : mg->mg_obj,
33c27489 295 toLOWER(mg->mg_type), key, klen);
463ee0b2 296 count++;
79072805 297 }
79072805 298 }
463ee0b2 299 return count;
79072805
LW
300}
301
954c1994
GS
302/*
303=for apidoc mg_free
304
305Free any magic storage used by the SV. See C<sv_magic>.
306
307=cut
308*/
309
79072805 310int
864dbfa3 311Perl_mg_free(pTHX_ SV *sv)
79072805
LW
312{
313 MAGIC* mg;
314 MAGIC* moremagic;
315 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
316 MGVTBL* vtbl = mg->mg_virtual;
317 moremagic = mg->mg_moremagic;
2b260de0 318 if (vtbl && vtbl->svt_free)
fc0dc3b3 319 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 320 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
565764a8 321 if (mg->mg_len >= 0)
88e89b8a 322 Safefree(mg->mg_ptr);
565764a8 323 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 324 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 325 }
85e6fe83 326 if (mg->mg_flags & MGf_REFCOUNTED)
8990e307 327 SvREFCNT_dec(mg->mg_obj);
79072805
LW
328 Safefree(mg);
329 }
330 SvMAGIC(sv) = 0;
331 return 0;
332}
333
d460ef45 334
79072805
LW
335#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
336#include <signal.h>
337#endif
338
942e002e 339U32
864dbfa3 340Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 341{
6cef1e77 342 register REGEXP *rx;
6cef1e77 343
aaa362c4 344 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
8f580fb8
IZ
345 if (mg->mg_obj) /* @+ */
346 return rx->nparens;
347 else /* @- */
348 return rx->lastparen;
349 }
ac27b0f5 350
942e002e 351 return (U32)-1;
6cef1e77
IZ
352}
353
354int
864dbfa3 355Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 356{
6cef1e77 357 register I32 paren;
cf93c79d 358 register I32 s;
6cef1e77
IZ
359 register I32 i;
360 register REGEXP *rx;
cf93c79d 361 I32 t;
6cef1e77 362
aaa362c4 363 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
6cef1e77
IZ
364 paren = mg->mg_len;
365 if (paren < 0)
366 return 0;
367 if (paren <= rx->nparens &&
cf93c79d
IZ
368 (s = rx->startp[paren]) != -1 &&
369 (t = rx->endp[paren]) != -1)
6cef1e77
IZ
370 {
371 if (mg->mg_obj) /* @+ */
cf93c79d 372 i = t;
6cef1e77 373 else /* @- */
cf93c79d 374 i = s;
1aa99e6b
IH
375
376 if (i > 0 && DO_UTF8(PL_reg_sv)) {
377 char *b = rx->subbeg;
0064a8a9
JH
378 if (b)
379 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
1aa99e6b 380 }
0064a8a9
JH
381
382 sv_setiv(sv, i);
6cef1e77
IZ
383 }
384 }
385 return 0;
386}
387
e4b89193 388int
a29d06ed
MG
389Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
390{
a29d06ed 391 Perl_croak(aTHX_ PL_no_modify);
e4b89193
GS
392 /* NOT REACHED */
393 return 0;
a29d06ed
MG
394}
395
93a17b20 396U32
864dbfa3 397Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20
LW
398{
399 register I32 paren;
93a17b20 400 register I32 i;
d9f97599 401 register REGEXP *rx;
a197cbdd 402 I32 s1, t1;
93a17b20
LW
403
404 switch (*mg->mg_ptr) {
405 case '1': case '2': case '3': case '4':
406 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 407 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 408
ffc61ed2 409 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 410 getparen:
d9f97599 411 if (paren <= rx->nparens &&
cf93c79d
IZ
412 (s1 = rx->startp[paren]) != -1 &&
413 (t1 = rx->endp[paren]) != -1)
bbce6d69 414 {
cf93c79d 415 i = t1 - s1;
a197cbdd 416 getlen:
ffc61ed2
JH
417 if (i > 0 && DO_UTF8(PL_reg_sv)) {
418 char *s = rx->subbeg + s1;
a197cbdd 419 char *send = rx->subbeg + t1;
ffc61ed2 420
60425c38
JH
421 i = t1 - s1;
422 if (is_utf8_string((U8*)s, i))
423 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
a197cbdd 424 }
ffc61ed2 425 if (i < 0)
0844c848 426 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 427 return i;
93a17b20 428 }
93a17b20 429 }
748a9306 430 return 0;
93a17b20 431 case '+':
aaa362c4 432 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 433 paren = rx->lastparen;
13f57bf8
CS
434 if (paren)
435 goto getparen;
93a17b20 436 }
748a9306 437 return 0;
a01268b5
JH
438 case '\016': /* ^N */
439 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
440 paren = rx->lastcloseparen;
441 if (paren)
442 goto getparen;
443 }
444 return 0;
93a17b20 445 case '`':
aaa362c4 446 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
447 if (rx->startp[0] != -1) {
448 i = rx->startp[0];
a197cbdd
GS
449 if (i > 0) {
450 s1 = 0;
451 t1 = i;
452 goto getlen;
453 }
93a17b20 454 }
93a17b20 455 }
748a9306 456 return 0;
93a17b20 457 case '\'':
aaa362c4 458 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
459 if (rx->endp[0] != -1) {
460 i = rx->sublen - rx->endp[0];
a197cbdd
GS
461 if (i > 0) {
462 s1 = rx->endp[0];
463 t1 = rx->sublen;
464 goto getlen;
465 }
93a17b20 466 }
93a17b20 467 }
748a9306 468 return 0;
93a17b20
LW
469 }
470 magic_get(sv,mg);
2d8e6c8d
GS
471 if (!SvPOK(sv) && SvNIOK(sv)) {
472 STRLEN n_a;
473 sv_2pv(sv, &n_a);
474 }
93a17b20
LW
475 if (SvPOK(sv))
476 return SvCUR(sv);
477 return 0;
478}
479
79072805 480int
864dbfa3 481Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
482{
483 register I32 paren;
484 register char *s;
485 register I32 i;
d9f97599 486 register REGEXP *rx;
79072805
LW
487
488 switch (*mg->mg_ptr) {
748a9306 489 case '\001': /* ^A */
3280af22 490 sv_setsv(sv, PL_bodytarget);
748a9306 491 break;
49460fe6
NIS
492 case '\003': /* ^C */
493 sv_setiv(sv, (IV)PL_minus_c);
494 break;
495
79072805 496 case '\004': /* ^D */
aea4f609 497 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
d056ab3f 498#if defined(YYDEBUG) && defined(DEBUGGING)
aea4f609 499 PL_yydebug = DEBUG_p_TEST;
d056ab3f 500#endif
79072805 501 break;
28f23441 502 case '\005': /* ^E */
cd39f2b6
JH
503#ifdef MACOS_TRADITIONAL
504 {
505 char msg[256];
ac27b0f5 506
bf4acbe4
GS
507 sv_setnv(sv,(double)gMacPerl_OSErr);
508 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
cd39f2b6
JH
509 }
510#else
28f23441
PP
511#ifdef VMS
512 {
513# include <descrip.h>
514# include <starlet.h>
515 char msg[255];
516 $DESCRIPTOR(msgdsc,msg);
65202027 517 sv_setnv(sv,(NV) vaxc$errno);
28f23441
PP
518 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
519 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
520 else
521 sv_setpv(sv,"");
522 }
523#else
88e89b8a 524#ifdef OS2
fb73857a 525 if (!(_emx_env & 0x200)) { /* Under DOS */
65202027 526 sv_setnv(sv, (NV)errno);
fb73857a
PP
527 sv_setpv(sv, errno ? Strerror(errno) : "");
528 } else {
017f25f1
IZ
529 if (errno != errno_isOS2) {
530 int tmp = _syserrno();
531 if (tmp) /* 2nd call to _syserrno() makes it 0 */
532 Perl_rc = tmp;
533 }
65202027 534 sv_setnv(sv, (NV)Perl_rc);
fb73857a
PP
535 sv_setpv(sv, os2error(Perl_rc));
536 }
88e89b8a 537#else
22fae026
TM
538#ifdef WIN32
539 {
540 DWORD dwErr = GetLastError();
65202027 541 sv_setnv(sv, (NV)dwErr);
22fae026 542 if (dwErr)
76e3520e 543 {
0cb96387 544 PerlProc_GetOSError(sv, dwErr);
76e3520e 545 }
22fae026
TM
546 else
547 sv_setpv(sv, "");
548 SetLastError(dwErr);
549 }
550#else
65202027 551 sv_setnv(sv, (NV)errno);
28f23441
PP
552 sv_setpv(sv, errno ? Strerror(errno) : "");
553#endif
88e89b8a 554#endif
22fae026 555#endif
cd39f2b6 556#endif
946ec16e 557 SvNOK_on(sv); /* what a wonderful hack! */
28f23441 558 break;
79072805 559 case '\006': /* ^F */
3280af22 560 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 561 break;
a0d0e21e 562 case '\010': /* ^H */
3280af22 563 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 564 break;
9d116dd7 565 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
566 if (PL_inplace)
567 sv_setpv(sv, PL_inplace);
79072805 568 else
3280af22 569 sv_setsv(sv, &PL_sv_undef);
79072805 570 break;
ac27b0f5
NIS
571 case '\017': /* ^O & ^OPEN */
572 if (*(mg->mg_ptr+1) == '\0')
573 sv_setpv(sv, PL_osname);
574 else if (strEQ(mg->mg_ptr, "\017PEN")) {
575 if (!PL_compiling.cop_io)
576 sv_setsv(sv, &PL_sv_undef);
577 else {
578 sv_setsv(sv, PL_compiling.cop_io);
579 }
580 }
28f23441 581 break;
79072805 582 case '\020': /* ^P */
3280af22 583 sv_setiv(sv, (IV)PL_perldb);
79072805 584 break;
fb73857a 585 case '\023': /* ^S */
d58bf5aa 586 {
3280af22 587 if (PL_lex_state != LEX_NOTPARSING)
155aba94 588 (void)SvOK_off(sv);
3280af22 589 else if (PL_in_eval)
6dc8a9e4 590 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
591 else
592 sv_setiv(sv, 0);
d58bf5aa 593 }
fb73857a 594 break;
79072805 595 case '\024': /* ^T */
88e89b8a 596#ifdef BIG_TIME
6b88bc9c 597 sv_setnv(sv, PL_basetime);
88e89b8a 598#else
3280af22 599 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 600#endif
79072805 601 break;
46487f74 602 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
4438c4b7
JH
603 if (*(mg->mg_ptr+1) == '\0')
604 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
6a818117 605 else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
d3a7d8c7
GS
606 if (PL_compiling.cop_warnings == pWARN_NONE ||
607 PL_compiling.cop_warnings == pWARN_STD)
4438c4b7
JH
608 {
609 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
610 }
d3a7d8c7 611 else if (PL_compiling.cop_warnings == pWARN_ALL) {
4438c4b7 612 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
ac27b0f5 613 }
4438c4b7
JH
614 else {
615 sv_setsv(sv, PL_compiling.cop_warnings);
ac27b0f5 616 }
d3a7d8c7 617 SvPOK_only(sv);
4438c4b7 618 }
46487f74
GS
619 else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
620 sv_setiv(sv, (IV)PL_widesyscalls);
79072805
LW
621 break;
622 case '1': case '2': case '3': case '4':
623 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 624 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
625 I32 s1, t1;
626
a863c7d1
MB
627 /*
628 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
629 * XXX Does the new way break anything?
630 */
ffc61ed2 631 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 632 getparen:
d9f97599 633 if (paren <= rx->nparens &&
cf93c79d
IZ
634 (s1 = rx->startp[paren]) != -1 &&
635 (t1 = rx->endp[paren]) != -1)
bbce6d69 636 {
cf93c79d
IZ
637 i = t1 - s1;
638 s = rx->subbeg + s1;
01ec43d0 639 if (!rx->subbeg)
c2e66d9e
GS
640 break;
641
13f57bf8 642 getrx:
748a9306 643 if (i >= 0) {
b7953727 644 bool was_tainted = FALSE;
3280af22
NIS
645 if (PL_tainting) {
646 was_tainted = PL_tainted;
647 PL_tainted = FALSE;
13f57bf8 648 }
cf93c79d 649 sv_setpvn(sv, s, i);
bdc14a33 650 if (PL_reg_sv && DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i))
7e2040f0
GS
651 SvUTF8_on(sv);
652 else
653 SvUTF8_off(sv);
3280af22
NIS
654 if (PL_tainting)
655 PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
748a9306
LW
656 break;
657 }
79072805 658 }
79072805 659 }
3280af22 660 sv_setsv(sv,&PL_sv_undef);
79072805
LW
661 break;
662 case '+':
aaa362c4 663 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 664 paren = rx->lastparen;
a0d0e21e
LW
665 if (paren)
666 goto getparen;
79072805 667 }
3280af22 668 sv_setsv(sv,&PL_sv_undef);
79072805 669 break;
a01268b5
JH
670 case '\016': /* ^N */
671 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
672 paren = rx->lastcloseparen;
673 if (paren)
674 goto getparen;
675 }
676 sv_setsv(sv,&PL_sv_undef);
677 break;
79072805 678 case '`':
aaa362c4 679 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
680 if ((s = rx->subbeg) && rx->startp[0] != -1) {
681 i = rx->startp[0];
13f57bf8 682 goto getrx;
79072805 683 }
79072805 684 }
3280af22 685 sv_setsv(sv,&PL_sv_undef);
79072805
LW
686 break;
687 case '\'':
aaa362c4 688 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
689 if (rx->subbeg && rx->endp[0] != -1) {
690 s = rx->subbeg + rx->endp[0];
691 i = rx->sublen - rx->endp[0];
13f57bf8 692 goto getrx;
79072805 693 }
79072805 694 }
3280af22 695 sv_setsv(sv,&PL_sv_undef);
79072805
LW
696 break;
697 case '.':
698#ifndef lint
3280af22 699 if (GvIO(PL_last_in_gv)) {
357c8808 700 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805
LW
701 }
702#endif
703 break;
704 case '?':
809a5acc 705 {
809a5acc 706 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 707#ifdef COMPLEX_STATUS
6b88bc9c
GS
708 LvTARGOFF(sv) = PL_statusvalue;
709 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 710#endif
809a5acc 711 }
79072805
LW
712 break;
713 case '^':
3280af22 714 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
715 if (s)
716 sv_setpv(sv,s);
717 else {
3280af22 718 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
719 sv_catpv(sv,"_TOP");
720 }
721 break;
722 case '~':
3280af22 723 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 724 if (!s)
3280af22 725 s = GvENAME(PL_defoutgv);
79072805
LW
726 sv_setpv(sv,s);
727 break;
728#ifndef lint
729 case '=':
3280af22 730 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
731 break;
732 case '-':
3280af22 733 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
734 break;
735 case '%':
3280af22 736 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805
LW
737 break;
738#endif
739 case ':':
740 break;
741 case '/':
742 break;
743 case '[':
3280af22 744 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
745 break;
746 case '|':
3280af22 747 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
748 break;
749 case ',':
79072805
LW
750 break;
751 case '\\':
79072805
LW
752 break;
753 case '#':
3280af22 754 sv_setpv(sv,PL_ofmt);
79072805
LW
755 break;
756 case '!':
a5f75d66 757#ifdef VMS
65202027 758 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 759 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 760#else
88e89b8a
PP
761 {
762 int saveerrno = errno;
65202027 763 sv_setnv(sv, (NV)errno);
88e89b8a 764#ifdef OS2
ed344e4f
IZ
765 if (errno == errno_isOS2 || errno == errno_isOS2_set)
766 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 767 else
a5f75d66 768#endif
2304df62 769 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
770 errno = saveerrno;
771 }
772#endif
946ec16e 773 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
774 break;
775 case '<':
3280af22 776 sv_setiv(sv, (IV)PL_uid);
79072805
LW
777 break;
778 case '>':
3280af22 779 sv_setiv(sv, (IV)PL_euid);
79072805
LW
780 break;
781 case '(':
3280af22 782 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 783#ifdef HAS_GETGROUPS
785fb66b 784 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 785#endif
79072805
LW
786 goto add_groups;
787 case ')':
3280af22 788 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 789#ifdef HAS_GETGROUPS
785fb66b 790 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 791#endif
79072805 792 add_groups:
79072805 793#ifdef HAS_GETGROUPS
79072805 794 {
a0d0e21e 795 Groups_t gary[NGROUPS];
79072805 796 i = getgroups(NGROUPS,gary);
46fc3d4c 797 while (--i >= 0)
785fb66b 798 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
79072805
LW
799 }
800#endif
155aba94 801 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805
LW
802 break;
803 case '*':
804 break;
cd39f2b6 805#ifndef MACOS_TRADITIONAL
79072805
LW
806 case '0':
807 break;
cd39f2b6 808#endif
a863c7d1
MB
809#ifdef USE_THREADS
810 case '@':
38a03e6e 811 sv_setsv(sv, thr->errsv);
a863c7d1
MB
812 break;
813#endif /* USE_THREADS */
79072805 814 }
a0d0e21e 815 return 0;
79072805
LW
816}
817
818int
864dbfa3 819Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
820{
821 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
822
823 if (uf && uf->uf_val)
24f81a43 824 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
825 return 0;
826}
827
828int
864dbfa3 829Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
830{
831 register char *s;
88e89b8a 832 char *ptr;
5aabfad6 833 STRLEN len, klen;
a0d0e21e 834 I32 i;
1e422769 835
a0d0e21e 836 s = SvPV(sv,len);
5aabfad6 837 ptr = MgPV(mg,klen);
88e89b8a 838 my_setenv(ptr, s);
1e422769 839
a0d0e21e
LW
840#ifdef DYNAMIC_ENV_FETCH
841 /* We just undefd an environment var. Is a replacement */
842 /* waiting in the wings? */
843 if (!len) {
5aabfad6 844 SV **valp;
6b88bc9c 845 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 846 s = SvPV(*valp, len);
a0d0e21e
LW
847 }
848#endif
1e422769 849
39e571d4 850#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
851 /* And you'll never guess what the dog had */
852 /* in its mouth... */
3280af22 853 if (PL_tainting) {
1e422769
PP
854 MgTAINTEDDIR_off(mg);
855#ifdef VMS
5aabfad6 856 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769
PP
857 char pathbuf[256], eltbuf[256], *cp, *elt = s;
858 struct stat sbuf;
859 int i = 0, j = 0;
860
861 do { /* DCL$PATH may be a search list */
862 while (1) { /* as may dev portion of any element */
863 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
864 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
865 cando_by_name(S_IWUSR,0,elt) ) {
866 MgTAINTEDDIR_on(mg);
867 return 0;
868 }
869 }
870 if ((cp = strchr(elt, ':')) != Nullch)
871 *cp = '\0';
872 if (my_trnlnm(elt, eltbuf, j++))
873 elt = eltbuf;
874 else
875 break;
876 }
877 j = 0;
878 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
879 }
880#endif /* VMS */
5aabfad6 881 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 882 char *strend = s + len;
463ee0b2
LW
883
884 while (s < strend) {
96827780 885 char tmpbuf[256];
1e422769 886 struct stat st;
96827780 887 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 888 s, strend, ':', &i);
463ee0b2 889 s++;
96827780
MB
890 if (i >= sizeof tmpbuf /* too long -- assume the worst */
891 || *tmpbuf != '/'
c6ed36e1 892 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 893 MgTAINTEDDIR_on(mg);
1e422769
PP
894 return 0;
895 }
463ee0b2 896 }
79072805
LW
897 }
898 }
39e571d4 899#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 900
79072805
LW
901 return 0;
902}
903
904int
864dbfa3 905Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 906{
2d8e6c8d
GS
907 STRLEN n_a;
908 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83
LW
909 return 0;
910}
911
88e89b8a 912int
864dbfa3 913Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a
PP
914{
915#if defined(VMS)
cea2e8a9 916 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 917#else
3280af22 918 if (PL_localizing) {
fb73857a 919 HE* entry;
2d8e6c8d 920 STRLEN n_a;
fb73857a
PP
921 magic_clear_all_env(sv,mg);
922 hv_iterinit((HV*)sv);
155aba94 923 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
924 I32 keylen;
925 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 926 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a
PP
927 }
928 }
929#endif
930 return 0;
931}
932
933int
864dbfa3 934Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 935{
ed79a026 936#if defined(VMS) || defined(EPOC)
cea2e8a9 937 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 938#else
7766f137
GS
939# ifdef PERL_IMPLICIT_SYS
940 PerlEnv_clearenv();
941# else
942# ifdef WIN32
3e3baf6d
TB
943 char *envv = GetEnvironmentStrings();
944 char *cur = envv;
945 STRLEN len;
946 while (*cur) {
947 char *end = strchr(cur,'=');
948 if (end && end != cur) {
949 *end = '\0';
950 my_setenv(cur,Nullch);
951 *end = '=';
ac5c734f 952 cur = end + strlen(end+1)+2;
3e3baf6d
TB
953 }
954 else if ((len = strlen(cur)))
955 cur += len+1;
956 }
957 FreeEnvironmentStrings(envv);
7766f137 958# else
5acaa6ec 959#ifdef USE_ENVIRON_ARRAY
7766f137 960# ifndef PERL_USE_SAFE_PUTENV
66b1d557
HM
961 I32 i;
962
3280af22 963 if (environ == PL_origenviron)
f2517201 964 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
965 else
966 for (i = 0; environ[i]; i++)
f2517201 967 safesysfree(environ[i]);
7766f137 968# endif /* PERL_USE_SAFE_PUTENV */
f2517201 969
66b1d557
HM
970 environ[0] = Nullch;
971
5acaa6ec 972#endif /* USE_ENVIRON_ARRAY */
7766f137
GS
973# endif /* WIN32 */
974# endif /* PERL_IMPLICIT_SYS */
f2517201 975#endif /* VMS */
3e3baf6d 976 return 0;
66b1d557
HM
977}
978
64ca3a65 979#ifndef PERL_MICRO
66b1d557 980int
864dbfa3 981Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
982{
983 I32 i;
2d8e6c8d 984 STRLEN n_a;
88e89b8a 985 /* Are we fetching a signal entry? */
2d8e6c8d 986 i = whichsig(MgPV(mg,n_a));
88e89b8a 987 if (i) {
22c35a8c
GS
988 if(PL_psig_ptr[i])
989 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 990 else {
ff68c719
PP
991 Sighandler_t sigstate = rsignal_state(i);
992
88e89b8a 993 /* cache state so we don't fetch it again */
ff68c719 994 if(sigstate == SIG_IGN)
88e89b8a
PP
995 sv_setpv(sv,"IGNORE");
996 else
3280af22 997 sv_setsv(sv,&PL_sv_undef);
22c35a8c 998 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
999 SvTEMP_off(sv);
1000 }
1001 }
1002 return 0;
1003}
1004int
864dbfa3 1005Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
1006{
1007 I32 i;
2d8e6c8d 1008 STRLEN n_a;
88e89b8a 1009 /* Are we clearing a signal entry? */
2d8e6c8d 1010 i = whichsig(MgPV(mg,n_a));
88e89b8a 1011 if (i) {
22c35a8c
GS
1012 if(PL_psig_ptr[i]) {
1013 SvREFCNT_dec(PL_psig_ptr[i]);
1014 PL_psig_ptr[i]=0;
88e89b8a 1015 }
22c35a8c
GS
1016 if(PL_psig_name[i]) {
1017 SvREFCNT_dec(PL_psig_name[i]);
1018 PL_psig_name[i]=0;
88e89b8a
PP
1019 }
1020 }
1021 return 0;
1022}
3d37d572 1023
0a8e0eff
NIS
1024void
1025Perl_raise_signal(pTHX_ int sig)
1026{
1027 /* Set a flag to say this signal is pending */
1028 PL_psig_pend[sig]++;
1029 /* And one to say _a_ signal is pending */
1030 PL_sig_pending = 1;
1031}
1032
1033Signal_t
1034Perl_csighandler(int sig)
1035{
1036#ifdef PERL_OLD_SIGNALS
1037 /* Call the perl level handler now with risk we may be in malloc() etc. */
1038 (*PL_sighandlerp)(sig);
1039#else
1040 dTHX;
1041 Perl_raise_signal(aTHX_ sig);
1042#endif
1043}
1044
1045void
1046Perl_despatch_signals(pTHX)
1047{
1048 int sig;
1049 PL_sig_pending = 0;
1050 for (sig = 1; sig < SIG_SIZE; sig++) {
1051 if (PL_psig_pend[sig]) {
1052 PL_psig_pend[sig] = 0;
1053 (*PL_sighandlerp)(sig);
1054 }
1055 }
1056}
1057
85e6fe83 1058int
864dbfa3 1059Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1060{
1061 register char *s;
1062 I32 i;
b7953727 1063 SV** svp = 0;
e72dc28c 1064 STRLEN len;
a0d0e21e 1065
e72dc28c 1066 s = MgPV(mg,len);
748a9306
LW
1067 if (*s == '_') {
1068 if (strEQ(s,"__DIE__"))
3280af22 1069 svp = &PL_diehook;
748a9306 1070 else if (strEQ(s,"__WARN__"))
3280af22 1071 svp = &PL_warnhook;
748a9306 1072 else
cea2e8a9 1073 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1074 i = 0;
4633a7c4
LW
1075 if (*svp) {
1076 SvREFCNT_dec(*svp);
1077 *svp = 0;
1078 }
748a9306
LW
1079 }
1080 else {
1081 i = whichsig(s); /* ...no, a brick */
1082 if (!i) {
e476b1b5 1083 if (ckWARN(WARN_SIGNAL))
cea2e8a9 1084 Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
748a9306
LW
1085 return 0;
1086 }
22c35a8c
GS
1087 SvREFCNT_dec(PL_psig_name[i]);
1088 SvREFCNT_dec(PL_psig_ptr[i]);
1089 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1090 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1091 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1092 SvREADONLY_on(PL_psig_name[i]);
748a9306 1093 }
a0d0e21e 1094 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 1095 if (i)
0a8e0eff 1096 (void)rsignal(i, &Perl_csighandler);
748a9306
LW
1097 else
1098 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
1099 return 0;
1100 }
e72dc28c 1101 s = SvPV_force(sv,len);
748a9306
LW
1102 if (strEQ(s,"IGNORE")) {
1103 if (i)
ff68c719 1104 (void)rsignal(i, SIG_IGN);
748a9306
LW
1105 else
1106 *svp = 0;
1107 }
1108 else if (strEQ(s,"DEFAULT") || !*s) {
1109 if (i)
ff68c719 1110 (void)rsignal(i, SIG_DFL);
748a9306
LW
1111 else
1112 *svp = 0;
1113 }
79072805 1114 else {
5aabfad6
PP
1115 /*
1116 * We should warn if HINT_STRICT_REFS, but without
1117 * access to a known hint bit in a known OP, we can't
1118 * tell whether HINT_STRICT_REFS is in force or not.
1119 */
46fc3d4c 1120 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1121 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1122 if (i)
0a8e0eff 1123 (void)rsignal(i, &Perl_csighandler);
748a9306
LW
1124 else
1125 *svp = SvREFCNT_inc(sv);
79072805
LW
1126 }
1127 return 0;
1128}
64ca3a65 1129#endif /* !PERL_MICRO */
79072805
LW
1130
1131int
864dbfa3 1132Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1133{
3280af22 1134 PL_sub_generation++;
463ee0b2
LW
1135 return 0;
1136}
1137
1138int
864dbfa3 1139Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1140{
a0d0e21e 1141 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1142 PL_amagic_generation++;
463ee0b2 1143
a0d0e21e
LW
1144 return 0;
1145}
463ee0b2 1146
946ec16e 1147int
864dbfa3 1148Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1149{
1150 HV *hv = (HV*)LvTARG(sv);
1151 HE *entry;
1152 I32 i = 0;
1153
1154 if (hv) {
1155 (void) hv_iterinit(hv);
14befaf4 1156 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
6ff81951
GS
1157 i = HvKEYS(hv);
1158 else {
1159 /*SUPPRESS 560*/
155aba94 1160 while ((entry = hv_iternext(hv))) {
6ff81951
GS
1161 i++;
1162 }
1163 }
1164 }
1165
1166 sv_setiv(sv, (IV)i);
1167 return 0;
1168}
1169
1170int
864dbfa3 1171Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e
PP
1172{
1173 if (LvTARG(sv)) {
1174 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1175 }
1176 return 0;
ac27b0f5 1177}
946ec16e 1178
e336de0d 1179/* caller is responsible for stack switching/cleanup */
565764a8 1180STATIC int
cea2e8a9 1181S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1182{
1183 dSP;
463ee0b2 1184
924508f0
GS
1185 PUSHMARK(SP);
1186 EXTEND(SP, n);
33c27489 1187 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1188 if (n > 1) {
93965878 1189 if (mg->mg_ptr) {
565764a8 1190 if (mg->mg_len >= 0)
79cb57f6 1191 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1192 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1193 PUSHs((SV*)mg->mg_ptr);
1194 }
14befaf4 1195 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1196 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1197 }
1198 }
1199 if (n > 2) {
1200 PUSHs(val);
88e89b8a 1201 }
463ee0b2
LW
1202 PUTBACK;
1203
864dbfa3 1204 return call_method(meth, flags);
946ec16e
PP
1205}
1206
76e3520e 1207STATIC int
cea2e8a9 1208S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1209{
1210 dSP;
463ee0b2 1211
a0d0e21e
LW
1212 ENTER;
1213 SAVETMPS;
e788e7d3 1214 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1215
33c27489 1216 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1217 sv_setsv(sv, *PL_stack_sp--);
93965878 1218 }
463ee0b2 1219
d3acc0f7 1220 POPSTACK;
a0d0e21e
LW
1221 FREETMPS;
1222 LEAVE;
1223 return 0;
1224}
463ee0b2 1225
a0d0e21e 1226int
864dbfa3 1227Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1228{
1229 magic_methpack(sv,mg,"FETCH");
1230 if (mg->mg_ptr)
1231 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
1232 return 0;
1233}
1234
1235int
864dbfa3 1236Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d
GS
1237{
1238 dSP;
a60c0954 1239 ENTER;
e788e7d3 1240 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1241 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1242 POPSTACK;
a60c0954 1243 LEAVE;
463ee0b2
LW
1244 return 0;
1245}
1246
1247int
864dbfa3 1248Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1249{
a0d0e21e
LW
1250 return magic_methpack(sv,mg,"DELETE");
1251}
463ee0b2 1252
93965878
NIS
1253
1254U32
864dbfa3 1255Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1256{
e336de0d 1257 dSP;
93965878
NIS
1258 U32 retval = 0;
1259
1260 ENTER;
1261 SAVETMPS;
e788e7d3 1262 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1263 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1264 sv = *PL_stack_sp--;
a60c0954 1265 retval = (U32) SvIV(sv)-1;
93965878 1266 }
d3acc0f7 1267 POPSTACK;
93965878
NIS
1268 FREETMPS;
1269 LEAVE;
1270 return retval;
1271}
1272
cea2e8a9
GS
1273int
1274Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1275{
1276 dSP;
463ee0b2 1277
e336de0d 1278 ENTER;
e788e7d3 1279 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1280 PUSHMARK(SP);
33c27489 1281 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1282 PUTBACK;
864dbfa3 1283 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1284 POPSTACK;
a60c0954 1285 LEAVE;
463ee0b2
LW
1286 return 0;
1287}
1288
1289int
864dbfa3 1290Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1291{
463ee0b2 1292 dSP;
dff6d3cd 1293 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1294
1295 ENTER;
a0d0e21e 1296 SAVETMPS;
e788e7d3 1297 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1298 PUSHMARK(SP);
1299 EXTEND(SP, 2);
33c27489 1300 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1301 if (SvOK(key))
1302 PUSHs(key);
1303 PUTBACK;
1304
864dbfa3 1305 if (call_method(meth, G_SCALAR))
3280af22 1306 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1307
d3acc0f7 1308 POPSTACK;
a0d0e21e
LW
1309 FREETMPS;
1310 LEAVE;
79072805
LW
1311 return 0;
1312}
1313
1314int
864dbfa3 1315Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1316{
1317 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1318}
a0d0e21e
LW
1319
1320int
864dbfa3 1321Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1322{
1323 OP *o;
1324 I32 i;
1325 GV* gv;
1326 SV** svp;
2d8e6c8d 1327 STRLEN n_a;
79072805 1328
3280af22 1329 gv = PL_DBline;
79072805 1330 i = SvTRUE(sv);
188ea221 1331 svp = av_fetch(GvAV(gv),
2d8e6c8d 1332 atoi(MgPV(mg,n_a)), FALSE);
57b2e452 1333 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp))))
93a17b20 1334 o->op_private = i;
79072805
LW
1335 return 0;
1336}
1337
1338int
864dbfa3 1339Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1340{
3280af22 1341 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1342 return 0;
1343}
1344
1345int
864dbfa3 1346Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1347{
3280af22 1348 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1349 return 0;
1350}
1351
1352int
864dbfa3 1353Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1354{
1355 SV* lsv = LvTARG(sv);
ac27b0f5 1356
a0d0e21e 1357 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1358 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1359 if (mg && mg->mg_len >= 0) {
a0ed51b3 1360 I32 i = mg->mg_len;
7e2040f0 1361 if (DO_UTF8(lsv))
a0ed51b3
LW
1362 sv_pos_b2u(lsv, &i);
1363 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1364 return 0;
1365 }
1366 }
1367 (void)SvOK_off(sv);
1368 return 0;
1369}
1370
1371int
864dbfa3 1372Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1373{
1374 SV* lsv = LvTARG(sv);
1375 SSize_t pos;
1376 STRLEN len;
c00206c8 1377 STRLEN ulen = 0;
a0d0e21e
LW
1378
1379 mg = 0;
ac27b0f5 1380
a0d0e21e 1381 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1382 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1383 if (!mg) {
1384 if (!SvOK(sv))
1385 return 0;
14befaf4
DM
1386 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1387 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1388 }
1389 else if (!SvOK(sv)) {
565764a8 1390 mg->mg_len = -1;
a0d0e21e
LW
1391 return 0;
1392 }
1393 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1394
c485e607 1395 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1396
7e2040f0 1397 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1398 ulen = sv_len_utf8(lsv);
1399 if (ulen)
1400 len = ulen;
a0ed51b3
LW
1401 }
1402
a0d0e21e
LW
1403 if (pos < 0) {
1404 pos += len;
1405 if (pos < 0)
1406 pos = 0;
1407 }
1408 else if (pos > len)
1409 pos = len;
a0ed51b3
LW
1410
1411 if (ulen) {
1412 I32 p = pos;
1413 sv_pos_u2b(lsv, &p, 0);
1414 pos = p;
1415 }
1416
565764a8 1417 mg->mg_len = pos;
71be2cbc 1418 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1419
79072805
LW
1420 return 0;
1421}
1422
1423int
864dbfa3 1424Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1425{
8646b087
PP
1426 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1427 SvFAKE_off(sv);
946ec16e 1428 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1429 SvFAKE_on(sv);
1430 }
1431 else
946ec16e 1432 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1433 return 0;
1434}
1435
1436int
864dbfa3 1437Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1438{
1439 register char *s;
1440 GV* gv;
2d8e6c8d 1441 STRLEN n_a;
79072805
LW
1442
1443 if (!SvOK(sv))
1444 return 0;
2d8e6c8d 1445 s = SvPV(sv, n_a);
79072805
LW
1446 if (*s == '*' && s[1])
1447 s++;
85e6fe83 1448 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1449 if (sv == (SV*)gv)
1450 return 0;
1451 if (GvGP(sv))
88e89b8a 1452 gp_free((GV*)sv);
79072805 1453 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1454 return 0;
1455}
1456
1457int
864dbfa3 1458Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1459{
1460 STRLEN len;
1461 SV *lsv = LvTARG(sv);
1462 char *tmps = SvPV(lsv,len);
1463 I32 offs = LvTARGOFF(sv);
1464 I32 rem = LvTARGLEN(sv);
1465
9aa983d2
JH
1466 if (SvUTF8(lsv))
1467 sv_pos_u2b(lsv, &offs, &rem);
6ff81951
GS
1468 if (offs > len)
1469 offs = len;
1470 if (rem + offs > len)
1471 rem = len - offs;
1472 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1473 if (SvUTF8(lsv))
2ef4b674 1474 SvUTF8_on(sv);
6ff81951
GS
1475 return 0;
1476}
1477
1478int
864dbfa3 1479Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1480{
9aa983d2
JH
1481 STRLEN len;
1482 char *tmps = SvPV(sv, len);
1483 SV *lsv = LvTARG(sv);
1484 I32 lvoff = LvTARGOFF(sv);
1485 I32 lvlen = LvTARGLEN(sv);
075a4a2b 1486
1aa99e6b 1487 if (DO_UTF8(sv)) {
9aa983d2
JH
1488 sv_utf8_upgrade(lsv);
1489 sv_pos_u2b(lsv, &lvoff, &lvlen);
1490 sv_insert(lsv, lvoff, lvlen, tmps, len);
1491 SvUTF8_on(lsv);
1492 }
1493 else if (SvUTF8(lsv)) {
1494 sv_pos_u2b(lsv, &lvoff, &lvlen);
e95af362 1495 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1496 sv_insert(lsv, lvoff, lvlen, tmps, len);
1497 Safefree(tmps);
1aa99e6b
IH
1498 }
1499 else
9aa983d2 1500 sv_insert(lsv, lvoff, lvlen, tmps, len);
1aa99e6b 1501
79072805
LW
1502 return 0;
1503}
1504
1505int
864dbfa3 1506Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1507{
565764a8 1508 TAINT_IF((mg->mg_len & 1) ||
155aba94 1509 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW
1510 return 0;
1511}
1512
1513int
864dbfa3 1514Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1515{
3280af22
NIS
1516 if (PL_localizing) {
1517 if (PL_localizing == 1)
565764a8 1518 mg->mg_len <<= 1;
748a9306 1519 else
565764a8 1520 mg->mg_len >>= 1;
a0d0e21e 1521 }
3280af22 1522 else if (PL_tainted)
565764a8 1523 mg->mg_len |= 1;
748a9306 1524 else
565764a8 1525 mg->mg_len &= ~1;
463ee0b2
LW
1526 return 0;
1527}
1528
1529int
864dbfa3 1530Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1531{
1532 SV *lsv = LvTARG(sv);
6ff81951
GS
1533
1534 if (!lsv) {
155aba94 1535 (void)SvOK_off(sv);
6ff81951
GS
1536 return 0;
1537 }
6ff81951 1538
81e118e0 1539 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1540 return 0;
1541}
1542
1543int
864dbfa3 1544Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1545{
1546 do_vecset(sv); /* XXX slurp this routine */
1547 return 0;
1548}
1549
1550int
864dbfa3 1551Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1552{
71be2cbc 1553 SV *targ = Nullsv;
5f05dabc 1554 if (LvTARGLEN(sv)) {
68dc0745 1555 if (mg->mg_obj) {
74e13ce4
GS
1556 SV *ahv = LvTARG(sv);
1557 if (SvTYPE(ahv) == SVt_PVHV) {
1558 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1559 if (he)
1560 targ = HeVAL(he);
1561 }
1562 else {
1563 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1564 if (svp)
1565 targ = *svp;
1566 }
68dc0745
PP
1567 }
1568 else {
3c78fafa 1569 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1570 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1571 targ = AvARRAY(av)[LvTARGOFF(sv)];
1572 }
3280af22 1573 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1574 /* somebody else defined it for us */
1575 SvREFCNT_dec(LvTARG(sv));
1576 LvTARG(sv) = SvREFCNT_inc(targ);
1577 LvTARGLEN(sv) = 0;
1578 SvREFCNT_dec(mg->mg_obj);
1579 mg->mg_obj = Nullsv;
1580 mg->mg_flags &= ~MGf_REFCOUNTED;
1581 }
5f05dabc 1582 }
71be2cbc
PP
1583 else
1584 targ = LvTARG(sv);
3280af22 1585 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1586 return 0;
1587}
1588
1589int
864dbfa3 1590Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc
PP
1591{
1592 if (LvTARGLEN(sv))
68dc0745
PP
1593 vivify_defelem(sv);
1594 if (LvTARG(sv)) {
5f05dabc 1595 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1596 SvSETMAGIC(LvTARG(sv));
1597 }
5f05dabc
PP
1598 return 0;
1599}
1600
71be2cbc 1601void
864dbfa3 1602Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1603{
74e13ce4
GS
1604 MAGIC *mg;
1605 SV *value = Nullsv;
71be2cbc 1606
14befaf4 1607 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1608 return;
68dc0745 1609 if (mg->mg_obj) {
74e13ce4 1610 SV *ahv = LvTARG(sv);
2d8e6c8d 1611 STRLEN n_a;
74e13ce4 1612 if (SvTYPE(ahv) == SVt_PVHV) {
af7f9c15 1613 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1614 if (he)
1615 value = HeVAL(he);
1616 }
1617 else {
af7f9c15 1618 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1619 if (svp)
1620 value = *svp;
1621 }
3280af22 1622 if (!value || value == &PL_sv_undef)
cea2e8a9 1623 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1624 }
68dc0745
PP
1625 else {
1626 AV* av = (AV*)LvTARG(sv);
5aabfad6 1627 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1628 LvTARG(sv) = Nullsv; /* array can't be extended */
1629 else {
1630 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1631 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1632 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1633 }
1634 }
3e3baf6d 1635 (void)SvREFCNT_inc(value);
68dc0745
PP
1636 SvREFCNT_dec(LvTARG(sv));
1637 LvTARG(sv) = value;
71be2cbc 1638 LvTARGLEN(sv) = 0;
68dc0745
PP
1639 SvREFCNT_dec(mg->mg_obj);
1640 mg->mg_obj = Nullsv;
1641 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1642}
1643
1644int
864dbfa3 1645Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1646{
1647 AV *av = (AV*)mg->mg_obj;
1648 SV **svp = AvARRAY(av);
1649 I32 i = AvFILLp(av);
1650 while (i >= 0) {
1651 if (svp[i] && svp[i] != &PL_sv_undef) {
1652 if (!SvWEAKREF(svp[i]))
cea2e8a9 1653 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS
1654 /* XXX Should we check that it hasn't changed? */
1655 SvRV(svp[i]) = 0;
155aba94 1656 (void)SvOK_off(svp[i]);
810b8aa5
GS
1657 SvWEAKREF_off(svp[i]);
1658 svp[i] = &PL_sv_undef;
1659 }
1660 i--;
1661 }
1662 return 0;
1663}
1664
1665int
864dbfa3 1666Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1667{
565764a8 1668 mg->mg_len = -1;
c6496cc7 1669 SvSCREAM_off(sv);
93a17b20
LW
1670 return 0;
1671}
1672
1673int
864dbfa3 1674Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1675{
14befaf4 1676 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
1677 SvVALID_off(sv);
1678 return 0;
1679}
1680
1681int
864dbfa3 1682Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1683{
14befaf4 1684 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
1685 SvCOMPILED_off(sv);
1686 return 0;
1687}
1688
1689int
864dbfa3 1690Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1691{
1692 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1693
1694 if (uf && uf->uf_set)
24f81a43 1695 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
1696 return 0;
1697}
1698
c277df42 1699int
864dbfa3 1700Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
1701{
1702 regexp *re = (regexp *)mg->mg_obj;
1703 ReREFCNT_dec(re);
1704 return 0;
1705}
1706
7a4c00b4 1707#ifdef USE_LOCALE_COLLATE
79072805 1708int
864dbfa3 1709Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
1710{
1711 /*
838b5b74 1712 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1713 * and vanished with a faint plop.
1714 */
7a4c00b4
PP
1715 if (mg->mg_ptr) {
1716 Safefree(mg->mg_ptr);
1717 mg->mg_ptr = NULL;
565764a8 1718 mg->mg_len = -1;
7a4c00b4 1719 }
bbce6d69
PP
1720 return 0;
1721}
7a4c00b4 1722#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1723
1724int
864dbfa3 1725Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1726{
1727 register char *s;
1728 I32 i;
8990e307 1729 STRLEN len;
79072805 1730 switch (*mg->mg_ptr) {
748a9306 1731 case '\001': /* ^A */
3280af22 1732 sv_setsv(PL_bodytarget, sv);
748a9306 1733 break;
49460fe6
NIS
1734 case '\003': /* ^C */
1735 PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1736 break;
1737
79072805 1738 case '\004': /* ^D */
aea4f609 1739 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
79072805
LW
1740 DEBUG_x(dump_all());
1741 break;
28f23441 1742 case '\005': /* ^E */
cd39f2b6 1743#ifdef MACOS_TRADITIONAL
bf4acbe4 1744 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 1745#else
cd39f2b6
JH
1746# ifdef VMS
1747 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 1748# else
cd39f2b6
JH
1749# ifdef WIN32
1750 SetLastError( SvIV(sv) );
1751# else
9fed8b87
IZ
1752# ifdef OS2
1753 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1754# else
f86702cc
PP
1755 /* will anyone ever use this? */
1756 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 1757# endif
048c1ddf
IZ
1758# endif
1759# endif
22fae026 1760#endif
28f23441 1761 break;
79072805 1762 case '\006': /* ^F */
3280af22 1763 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1764 break;
a0d0e21e 1765 case '\010': /* ^H */
3280af22 1766 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 1767 break;
9d116dd7 1768 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
1769 if (PL_inplace)
1770 Safefree(PL_inplace);
79072805 1771 if (SvOK(sv))
2d8e6c8d 1772 PL_inplace = savepv(SvPV(sv,len));
79072805 1773 else
3280af22 1774 PL_inplace = Nullch;
79072805 1775 break;
28f23441 1776 case '\017': /* ^O */
ac27b0f5
NIS
1777 if (*(mg->mg_ptr+1) == '\0') {
1778 if (PL_osname)
1779 Safefree(PL_osname);
1780 if (SvOK(sv))
1781 PL_osname = savepv(SvPV(sv,len));
1782 else
1783 PL_osname = Nullch;
1784 }
1785 else if (strEQ(mg->mg_ptr, "\017PEN")) {
1786 if (!PL_compiling.cop_io)
1787 PL_compiling.cop_io = newSVsv(sv);
1788 else
1789 sv_setsv(PL_compiling.cop_io,sv);
1790 }
28f23441 1791 break;
79072805 1792 case '\020': /* ^P */
3280af22 1793 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ
1794 if (PL_perldb && !PL_DBsingle)
1795 init_debugger();
79072805
LW
1796 break;
1797 case '\024': /* ^T */
88e89b8a 1798#ifdef BIG_TIME
6b88bc9c 1799 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 1800#else
3280af22 1801 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1802#endif
79072805 1803 break;
46487f74 1804 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
4438c4b7
JH
1805 if (*(mg->mg_ptr+1) == '\0') {
1806 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1807 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 1808 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 1809 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 1810 }
599cee73 1811 }
6a818117 1812 else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
4438c4b7 1813 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
1814 if (!SvPOK(sv) && PL_localizing) {
1815 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 1816 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
1817 break;
1818 }
f4fc7782 1819 {
b5477537 1820 STRLEN len, i;
d3a7d8c7 1821 int accumulate = 0 ;
f4fc7782 1822 int any_fatals = 0 ;
d3a7d8c7 1823 char * ptr = (char*)SvPV(sv, len) ;
f4fc7782
JH
1824 for (i = 0 ; i < len ; ++i) {
1825 accumulate |= ptr[i] ;
1826 any_fatals |= (ptr[i] & 0xAA) ;
1827 }
d3a7d8c7
GS
1828 if (!accumulate)
1829 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
1830 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
1831 PL_compiling.cop_warnings = pWARN_ALL;
1832 PL_dowarn |= G_WARN_ONCE ;
1833 }
d3a7d8c7
GS
1834 else {
1835 if (specialWARN(PL_compiling.cop_warnings))
1836 PL_compiling.cop_warnings = newSVsv(sv) ;
1837 else
1838 sv_setsv(PL_compiling.cop_warnings, sv);
1839 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1840 PL_dowarn |= G_WARN_ONCE ;
1841 }
f4fc7782 1842
d3a7d8c7 1843 }
4438c4b7 1844 }
971a9dd3 1845 }
46487f74
GS
1846 else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
1847 PL_widesyscalls = SvTRUE(sv);
79072805
LW
1848 break;
1849 case '.':
3280af22
NIS
1850 if (PL_localizing) {
1851 if (PL_localizing == 1)
7766f137 1852 SAVESPTR(PL_last_in_gv);
748a9306 1853 }
3280af22
NIS
1854 else if (SvOK(sv) && GvIO(PL_last_in_gv))
1855 IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
79072805
LW
1856 break;
1857 case '^':
3280af22 1858 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1859 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1860 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1861 break;
1862 case '~':
3280af22 1863 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1864 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1865 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1866 break;
1867 case '=':
3280af22 1868 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1869 break;
1870 case '-':
3280af22
NIS
1871 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1872 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1873 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
1874 break;
1875 case '%':
3280af22 1876 IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1877 break;
1878 case '|':
4b65379b 1879 {
3280af22 1880 IO *io = GvIOp(PL_defoutgv);
4b65379b
CS
1881 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1882 IoFLAGS(io) &= ~IOf_FLUSH;
1883 else {
1884 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1885 PerlIO *ofp = IoOFP(io);
1886 if (ofp)
1887 (void)PerlIO_flush(ofp);
1888 IoFLAGS(io) |= IOf_FLUSH;
1889 }
1890 }
79072805
LW
1891 }
1892 break;
1893 case '*':
463ee0b2 1894 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 1895 PL_multiline = (i != 0);
79072805
LW
1896 break;
1897 case '/':
3280af22
NIS
1898 SvREFCNT_dec(PL_nrs);
1899 PL_nrs = newSVsv(sv);
1900 SvREFCNT_dec(PL_rs);
1901 PL_rs = SvREFCNT_inc(PL_nrs);
79072805
LW
1902 break;
1903 case '\\':
7889fe52
NIS
1904 if (PL_ors_sv)
1905 SvREFCNT_dec(PL_ors_sv);
009c130f 1906 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 1907 PL_ors_sv = newSVsv(sv);
009c130f 1908 }
e3c19b7b 1909 else {
7889fe52 1910 PL_ors_sv = Nullsv;
e3c19b7b 1911 }
79072805
LW
1912 break;
1913 case ',':
7889fe52
NIS
1914 if (PL_ofs_sv)
1915 SvREFCNT_dec(PL_ofs_sv);
1916 if (SvOK(sv) || SvGMAGICAL(sv)) {
1917 PL_ofs_sv = newSVsv(sv);
1918 }
1919 else {
1920 PL_ofs_sv = Nullsv;
1921 }
79072805
LW
1922 break;
1923 case '#':
3280af22
NIS
1924 if (PL_ofmt)
1925 Safefree(PL_ofmt);
2d8e6c8d 1926 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW
1927 break;
1928 case '[':
3280af22 1929 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1930 break;
1931 case '?':
ff0cee69 1932#ifdef COMPLEX_STATUS
6b88bc9c
GS
1933 if (PL_localizing == 2) {
1934 PL_statusvalue = LvTARGOFF(sv);
1935 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
1936 }
1937 else
1938#endif
1939#ifdef VMSISH_STATUS
1940 if (VMSISH_STATUS)
1941 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1942 else
1943#endif
1944 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1945 break;
1946 case '!':
78987ded 1947 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
f86702cc 1948 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1949 break;
1950 case '<':
3280af22
NIS
1951 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1952 if (PL_delaymagic) {
1953 PL_delaymagic |= DM_RUID;
79072805
LW
1954 break; /* don't do magic till later */
1955 }
1956#ifdef HAS_SETRUID
b28d0864 1957 (void)setruid((Uid_t)PL_uid);
79072805
LW
1958#else
1959#ifdef HAS_SETREUID
3280af22 1960 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 1961#else
85e6fe83 1962#ifdef HAS_SETRESUID
b28d0864 1963 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 1964#else
b28d0864
NIS
1965 if (PL_uid == PL_euid) /* special case $< = $> */
1966 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1967 else {
d8eceb89 1968 PL_uid = PerlProc_getuid();
cea2e8a9 1969 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 1970 }
79072805
LW
1971#endif
1972#endif
85e6fe83 1973#endif
d8eceb89 1974 PL_uid = PerlProc_getuid();
3280af22 1975 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1976 break;
1977 case '>':
3280af22
NIS
1978 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1979 if (PL_delaymagic) {
1980 PL_delaymagic |= DM_EUID;
79072805
LW
1981 break; /* don't do magic till later */
1982 }
1983#ifdef HAS_SETEUID
3280af22 1984 (void)seteuid((Uid_t)PL_euid);
79072805
LW
1985#else
1986#ifdef HAS_SETREUID
b28d0864 1987 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
1988#else
1989#ifdef HAS_SETRESUID
6b88bc9c 1990 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 1991#else
b28d0864
NIS
1992 if (PL_euid == PL_uid) /* special case $> = $< */
1993 PerlProc_setuid(PL_euid);
a0d0e21e 1994 else {
e8ee3774 1995 PL_euid = PerlProc_geteuid();
cea2e8a9 1996 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 1997 }
79072805
LW
1998#endif
1999#endif
85e6fe83 2000#endif
d8eceb89 2001 PL_euid = PerlProc_geteuid();
3280af22 2002 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2003 break;
2004 case '(':
3280af22
NIS
2005 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2006 if (PL_delaymagic) {
2007 PL_delaymagic |= DM_RGID;
79072805
LW
2008 break; /* don't do magic till later */
2009 }
2010#ifdef HAS_SETRGID
b28d0864 2011 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2012#else
2013#ifdef HAS_SETREGID
3280af22 2014 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2015#else
2016#ifdef HAS_SETRESGID
b28d0864 2017 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2018#else
b28d0864
NIS
2019 if (PL_gid == PL_egid) /* special case $( = $) */
2020 (void)PerlProc_setgid(PL_gid);
748a9306 2021 else {
d8eceb89 2022 PL_gid = PerlProc_getgid();
cea2e8a9 2023 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2024 }
79072805
LW
2025#endif
2026#endif
85e6fe83 2027#endif
d8eceb89 2028 PL_gid = PerlProc_getgid();
3280af22 2029 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2030 break;
2031 case ')':
5cd24f17
PP
2032#ifdef HAS_SETGROUPS
2033 {
2d8e6c8d 2034 char *p = SvPV(sv, len);
5cd24f17
PP
2035 Groups_t gary[NGROUPS];
2036
5cd24f17
PP
2037 while (isSPACE(*p))
2038 ++p;
2d4389e4 2039 PL_egid = Atol(p);
5cd24f17
PP
2040 for (i = 0; i < NGROUPS; ++i) {
2041 while (*p && !isSPACE(*p))
2042 ++p;
2043 while (isSPACE(*p))
2044 ++p;
2045 if (!*p)
2046 break;
2d4389e4 2047 gary[i] = Atol(p);
5cd24f17 2048 }
8cc95fdb
PP
2049 if (i)
2050 (void)setgroups(i, gary);
5cd24f17
PP
2051 }
2052#else /* HAS_SETGROUPS */
b28d0864 2053 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2054#endif /* HAS_SETGROUPS */
3280af22
NIS
2055 if (PL_delaymagic) {
2056 PL_delaymagic |= DM_EGID;
79072805
LW
2057 break; /* don't do magic till later */
2058 }
2059#ifdef HAS_SETEGID
3280af22 2060 (void)setegid((Gid_t)PL_egid);
79072805
LW
2061#else
2062#ifdef HAS_SETREGID
b28d0864 2063 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2064#else
2065#ifdef HAS_SETRESGID
b28d0864 2066 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2067#else
b28d0864
NIS
2068 if (PL_egid == PL_gid) /* special case $) = $( */
2069 (void)PerlProc_setgid(PL_egid);
748a9306 2070 else {
d8eceb89 2071 PL_egid = PerlProc_getegid();
cea2e8a9 2072 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2073 }
79072805
LW
2074#endif
2075#endif
85e6fe83 2076#endif
d8eceb89 2077 PL_egid = PerlProc_getegid();
3280af22 2078 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2079 break;
2080 case ':':
2d8e6c8d 2081 PL_chopset = SvPV_force(sv,len);
79072805 2082 break;
cd39f2b6 2083#ifndef MACOS_TRADITIONAL
79072805 2084 case '0':
4bc88a62
PS
2085#ifdef HAS_SETPROCTITLE
2086 /* The BSDs don't show the argv[] in ps(1) output, they
2087 * show a string from the process struct and provide
2088 * the setproctitle() routine to manipulate that. */
2089 {
2090 s = SvPV(sv, len);
9aad2c0e
JH
2091# if __FreeBSD_version >= 410001
2092 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2093 * but not the "(perl) suffix from the ps(1)
2094 * output, because that's what ps(1) shows if the
2095 * argv[] is modified. */
2096 setproctitle("-%s", s, len + 1);
9aad2c0e 2097# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2098 /* This doesn't really work if you assume that
2099 * $0 = 'foobar'; will wipe out 'perl' from the $0
2100 * because in ps(1) output the result will be like
2101 * sprintf("perl: %s (perl)", s)
2102 * I guess this is a security feature:
2103 * one (a user process) cannot get rid of the original name.
2104 * --jhi */
2105 setproctitle("%s", s);
2106# endif
2107 }
2108#endif
3280af22
NIS
2109 if (!PL_origalen) {
2110 s = PL_origargv[0];
79072805
LW
2111 s += strlen(s);
2112 /* See if all the arguments are contiguous in memory */
3280af22
NIS
2113 for (i = 1; i < PL_origargc; i++) {
2114 if (PL_origargv[i] == s + 1
fb73857a 2115#ifdef OS2
6b88bc9c 2116 || PL_origargv[i] == s + 2
ac27b0f5 2117#endif
fb73857a 2118 )
379c4362
GS
2119 {
2120 ++s;
2121 s += strlen(s); /* this one is ok too */
2122 }
fb73857a
PP
2123 else
2124 break;
79072805 2125 }
bbce6d69 2126 /* can grab env area too? */
3280af22 2127 if (PL_origenviron && (PL_origenviron[0] == s + 1
fb73857a 2128#ifdef OS2
6b88bc9c 2129 || (PL_origenviron[0] == s + 9 && (s += 8))
ac27b0f5 2130#endif
fb73857a 2131 )) {
66b1d557 2132 my_setenv("NoNe SuCh", Nullch);
79072805 2133 /* force copy of environment */
3280af22 2134 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS
2135 if (PL_origenviron[i] == s + 1) {
2136 ++s;
2137 s += strlen(s);
2138 }
fb73857a
PP
2139 else
2140 break;
79072805 2141 }
3280af22 2142 PL_origalen = s - PL_origargv[0];
79072805 2143 }
a0d0e21e 2144 s = SvPV_force(sv,len);
8990e307 2145 i = len;
3280af22
NIS
2146 if (i >= PL_origalen) {
2147 i = PL_origalen;
fb73857a
PP
2148 /* don't allow system to limit $0 seen by script */
2149 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS
2150 Copy(s, PL_origargv[0], i, char);
2151 s = PL_origargv[0]+i;
fb73857a 2152 *s = '\0';
79072805
LW
2153 }
2154 else {
3280af22
NIS
2155 Copy(s, PL_origargv[0], i, char);
2156 s = PL_origargv[0]+i;
79072805 2157 *s++ = '\0';
3280af22 2158 while (++i < PL_origalen)
8990e307 2159 *s++ = ' ';
3280af22
NIS
2160 s = PL_origargv[0]+i;
2161 for (i = 1; i < PL_origargc; i++)
2162 PL_origargv[i] = Nullch;
79072805
LW
2163 }
2164 break;
cd39f2b6 2165#endif
a863c7d1
MB
2166#ifdef USE_THREADS
2167 case '@':
38a03e6e 2168 sv_setsv(thr->errsv, sv);
a863c7d1
MB
2169 break;
2170#endif /* USE_THREADS */
79072805
LW
2171 }
2172 return 0;
2173}
2174
f93b4edd
MB
2175#ifdef USE_THREADS
2176int
864dbfa3 2177Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
f93b4edd 2178{
b900a521
JH
2179 DEBUG_S(PerlIO_printf(Perl_debug_log,
2180 "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
a674cc95 2181 PTR2UV(thr), PTR2UV(sv)));
f93b4edd 2182 if (MgOWNER(mg))
cea2e8a9 2183 Perl_croak(aTHX_ "panic: magic_mutexfree");
f93b4edd
MB
2184 MUTEX_DESTROY(MgMUTEXP(mg));
2185 COND_DESTROY(MgCONDP(mg));
2186 return 0;
2187}
2188#endif /* USE_THREADS */
2189
79072805 2190I32
864dbfa3 2191Perl_whichsig(pTHX_ char *sig)
79072805
LW
2192{
2193 register char **sigv;
2194
22c35a8c 2195 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 2196 if (strEQ(sig,*sigv))
22c35a8c 2197 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
2198#ifdef SIGCLD
2199 if (strEQ(sig,"CHLD"))
2200 return SIGCLD;
2201#endif
2202#ifdef SIGCHLD
2203 if (strEQ(sig,"CLD"))
2204 return SIGCHLD;
2205#endif
2206 return 0;
2207}
2208
84902520
TB
2209static SV* sig_sv;
2210
ecfc5424 2211Signal_t
cea2e8a9 2212Perl_sighandler(int sig)
79072805 2213{
71d280e3
GS
2214#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
2215 dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */
2216#else
cea2e8a9 2217 dTHX;
71d280e3 2218#endif
79072805 2219 dSP;
00d579c5 2220 GV *gv = Nullgv;
a0d0e21e 2221 HV *st;
b7953727 2222 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2223 CV *cv = Nullcv;
533c011a 2224 OP *myop = PL_op;
84902520 2225 U32 flags = 0;
155aba94 2226 I32 o_save_i = PL_savestack_ix;
3280af22 2227 XPV *tXpv = PL_Xpv;
71d280e3
GS
2228
2229#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
2230 PERL_SET_THX(aTHXo); /* fake TLS, see above */
2231#endif
ac27b0f5 2232
3280af22 2233 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2234 flags |= 1;
3280af22 2235 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2236 flags |= 4;
3280af22 2237 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2238 flags |= 8;
3280af22 2239 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2240 flags |= 16;
2241
22c35a8c 2242 if (!PL_psig_ptr[sig])
cea2e8a9 2243 Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
22c35a8c 2244 PL_sig_name[sig]);
ff0cee69 2245
84902520
TB
2246 /* Max number of items pushed there is 3*n or 4. We cannot fix
2247 infinity, so we fix 4 (in fact 5): */
2248 if (flags & 1) {
3280af22
NIS
2249 PL_savestack_ix += 5; /* Protect save in progress. */
2250 o_save_i = PL_savestack_ix;
c76ac1ee 2251 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2252 }
ac27b0f5 2253 if (flags & 4)
3280af22 2254 PL_markstack_ptr++; /* Protect mark. */
84902520 2255 if (flags & 8) {
3280af22
NIS
2256 PL_retstack_ix++;
2257 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2258 }
2259 if (flags & 16)
3280af22 2260 PL_scopestack_ix += 1;
84902520 2261 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2262 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2263 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2264 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2265
a0d0e21e 2266 if (!cv || !CvROOT(cv)) {
599cee73 2267 if (ckWARN(WARN_SIGNAL))
cea2e8a9 2268 Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2269 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2270 : ((cv && CvGV(cv))
2271 ? GvENAME(CvGV(cv))
2272 : "__ANON__")));
2273 goto cleanup;
79072805
LW
2274 }
2275
22c35a8c
GS
2276 if(PL_psig_name[sig]) {
2277 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520
TB
2278 flags |= 64;
2279 sig_sv = sv;
2280 } else {
ff0cee69 2281 sv = sv_newmortal();
22c35a8c 2282 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2283 }
e336de0d 2284
e788e7d3 2285 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2286 PUSHMARK(SP);
79072805 2287 PUSHs(sv);
79072805 2288 PUTBACK;
a0d0e21e 2289
1b266415 2290 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2291
d3acc0f7 2292 POPSTACK;
1b266415 2293 if (SvTRUE(ERRSV)) {
1d615522 2294#ifndef PERL_MICRO
983dbef6 2295#ifdef HAS_SIGPROCMASK
1b266415
NIS
2296 /* Handler "died", for example to get out of a restart-able read().
2297 * Before we re-do that on its behalf re-enable the signal which was
2298 * blocked by the system when we entered.
2299 */
2300 sigset_t set;
2301 sigemptyset(&set);
2302 sigaddset(&set,sig);
2303 sigprocmask(SIG_UNBLOCK, &set, NULL);
2304#else
2305 /* Not clear if this will work */
2306 (void)rsignal(sig, SIG_IGN);
0a8e0eff 2307 (void)rsignal(sig, &Perl_csighandler);
1b266415 2308#endif
1d615522 2309#endif /* !PERL_MICRO */
1b266415
NIS
2310 Perl_die(aTHX_ Nullch);
2311 }
00d579c5 2312cleanup:
84902520 2313 if (flags & 1)
3280af22 2314 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2315 if (flags & 4)
3280af22 2316 PL_markstack_ptr--;
ac27b0f5 2317 if (flags & 8)
3280af22 2318 PL_retstack_ix--;
84902520 2319 if (flags & 16)
3280af22 2320 PL_scopestack_ix -= 1;
84902520
TB
2321 if (flags & 64)
2322 SvREFCNT_dec(sv);
533c011a 2323 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2324
3280af22
NIS
2325 PL_Sv = tSv; /* Restore global temporaries. */
2326 PL_Xpv = tXpv;
79072805
LW
2327 return;
2328}
4e35701f
NIS
2329
2330
51371543 2331#ifdef PERL_OBJECT
51371543
GS
2332#include "XSUB.h"
2333#endif
2334
2335static void
2336restore_magic(pTHXo_ void *p)
2337{
48944bdf 2338 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS
2339 SV* sv = mgs->mgs_sv;
2340
2341 if (!sv)
2342 return;
2343
2344 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2345 {
2346 if (mgs->mgs_flags)
2347 SvFLAGS(sv) |= mgs->mgs_flags;
2348 else
2349 mg_magical(sv);
2350 if (SvGMAGICAL(sv))
2351 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2352 }
2353
2354 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2355
2356 /* If we're still on top of the stack, pop us off. (That condition
2357 * will be satisfied if restore_magic was called explicitly, but *not*
2358 * if it's being called via leave_scope.)
2359 * The reason for doing this is that otherwise, things like sv_2cv()
2360 * may leave alloc gunk on the savestack, and some code
2361 * (e.g. sighandler) doesn't expect that...
2362 */
2363 if (PL_savestack_ix == mgs->mgs_ss_ix)
2364 {
2365 I32 popval = SSPOPINT;
c76ac1ee 2366 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2367 PL_savestack_ix -= 2;
2368 popval = SSPOPINT;
2369 assert(popval == SAVEt_ALLOC);
2370 popval = SSPOPINT;
2371 PL_savestack_ix -= popval;
2372 }
2373
2374}
2375
2376static void
2377unwind_handler_stack(pTHXo_ void *p)
2378{
51371543
GS
2379 U32 flags = *(U32*)p;
2380
2381 if (flags & 1)
2382 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2383 /* cxstack_ix-- Not needed, die already unwound it. */
2384 if (flags & 64)
2385 SvREFCNT_dec(sig_sv);
2386}