This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Clean up temp files/dirs left by Archive-Tar tests
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b94e2f88 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805
LW
14 */
15
ccfc67b7
JH
16/*
17=head1 Magical Functions
166f8a29
DM
18
19"Magic" is special data attached to SV structures in order to give them
20"magical" properties. When any Perl code tries to read from, or assign to,
21an SV marked as magical, it calls the 'get' or 'set' function associated
22with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 23give it a chance to update its internal value (get on $. writes the line
166f8a29
DM
24number of the last read filehandle into to the SV's IV slot), while
25set is called after an SV has been written to, in order to allow it to make
ddfa107c 26use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM
27PL_rs global variable).
28
29Magic is implemented as a linked list of MAGIC structures attached to the
30SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31of functions that implement the get(), set(), length() etc functions,
32plus space for some flags and pointers. For example, a tied variable has
33a MAGIC structure that contains a pointer to the object associated with the
34tie.
35
ccfc67b7
JH
36*/
37
79072805 38#include "EXTERN.h"
864dbfa3 39#define PERL_IN_MG_C
79072805
LW
40#include "perl.h"
41
5cd24f17 42#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH
43# ifdef I_GRP
44# include <grp.h>
45# endif
188ea221
CS
46#endif
47
757f63d8
SP
48#if defined(HAS_SETGROUPS)
49# ifndef NGROUPS
50# define NGROUPS 32
51# endif
52#endif
53
17aa7f3d
JH
54#ifdef __hpux
55# include <sys/pstat.h>
56#endif
57
8aad04aa
JH
58#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59Signal_t Perl_csighandler(int sig, ...);
60#else
e69880a5 61Signal_t Perl_csighandler(int sig);
8aad04aa 62#endif
e69880a5 63
9cffb111
OS
64#ifdef __Lynx__
65/* Missing protos on LynxOS */
66void setruid(uid_t id);
67void seteuid(uid_t id);
68void setrgid(uid_t id);
69void setegid(uid_t id);
70#endif
71
c07a80fd
PP
72/*
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
74 */
75
76struct magic_state {
77 SV* mgs_sv;
78 U32 mgs_flags;
455ece5e 79 I32 mgs_ss_ix;
c07a80fd 80};
455ece5e 81/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
82
83STATIC void
8fb26106 84S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 85{
97aff369 86 dVAR;
455ece5e 87 MGS* mgs;
c07a80fd 88 assert(SvMAGICAL(sv));
f8c7b90f 89#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
90 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
91 if (SvIsCOW(sv))
9a265e59 92 sv_force_normal_flags(sv, 0);
765f542d 93#endif
c07a80fd 94
8772537c 95 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
96
97 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd
PP
98 mgs->mgs_sv = sv;
99 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 100 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd
PP
101
102 SvMAGICAL_off(sv);
103 SvREADONLY_off(sv);
06759ea0 104 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd
PP
105}
106
954c1994
GS
107/*
108=for apidoc mg_magical
109
110Turns on the magical status of an SV. See C<sv_magic>.
111
112=cut
113*/
114
8990e307 115void
864dbfa3 116Perl_mg_magical(pTHX_ SV *sv)
8990e307 117{
e1ec3a88 118 const MAGIC* mg;
8990e307 119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 120 const MGVTBL* const vtbl = mg->mg_virtual;
8990e307 121 if (vtbl) {
2b260de0 122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
123 SvGMAGICAL_on(sv);
124 if (vtbl->svt_set)
125 SvSMAGICAL_on(sv);
2b260de0 126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307
LW
127 SvRMAGICAL_on(sv);
128 }
129 }
130}
131
954c1994
GS
132/*
133=for apidoc mg_get
134
135Do magic after a value is retrieved from the SV. See C<sv_magic>.
136
137=cut
138*/
139
79072805 140int
864dbfa3 141Perl_mg_get(pTHX_ SV *sv)
79072805 142{
97aff369 143 dVAR;
35a4481c 144 const I32 mgs_ix = SSNEW(sizeof(MGS));
fe2774ed 145 const bool was_temp = (bool)SvTEMP(sv);
0723351e 146 int have_new = 0;
ff76feab 147 MAGIC *newmg, *head, *cur, *mg;
20135930 148 /* guard against sv having being freed midway by holding a private
6683b158
NC
149 reference. */
150
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
153 So restore it.
154 */
155 sv_2mortal(SvREFCNT_inc(sv));
156 if (!was_temp) {
157 SvTEMP_off(sv);
158 }
159
455ece5e 160 save_magic(mgs_ix, sv);
463ee0b2 161
ff76feab
AMS
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
165
166 newmg = cur = head = mg = SvMAGIC(sv);
167 while (mg) {
35a4481c 168 const MGVTBL * const vtbl = mg->mg_virtual;
ff76feab 169
2b260de0 170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
b77f7d40 172
58f82c5c
DM
173 /* guard against magic having been deleted - eg FETCH calling
174 * untie */
175 if (!SvMAGIC(sv))
176 break;
b77f7d40 177
ff76feab
AMS
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
a0d0e21e 181 }
ff76feab
AMS
182
183 mg = mg->mg_moremagic;
184
0723351e 185 if (have_new) {
ff76feab
AMS
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
188 if (mg == head) {
0723351e 189 have_new = 0;
ff76feab
AMS
190 mg = cur;
191 head = newmg;
192 }
193 }
194
195 /* Were any new entries added? */
0723351e
NC
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
197 have_new = 1;
ff76feab
AMS
198 cur = mg;
199 mg = newmg;
760ac839 200 }
79072805 201 }
463ee0b2 202
8772537c 203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
6683b158
NC
204
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
0c34ef67 208 SvOK_off(sv);
6683b158 209 }
79072805
LW
210 return 0;
211}
212
954c1994
GS
213/*
214=for apidoc mg_set
215
216Do magic after a value is assigned to the SV. See C<sv_magic>.
217
218=cut
219*/
220
79072805 221int
864dbfa3 222Perl_mg_set(pTHX_ SV *sv)
79072805 223{
97aff369 224 dVAR;
35a4481c 225 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 226 MAGIC* mg;
463ee0b2
LW
227 MAGIC* nextmg;
228
455ece5e 229 save_magic(mgs_ix, sv);
463ee0b2
LW
230
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 232 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 233 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 237 }
2b260de0 238 if (vtbl && vtbl->svt_set)
fc0dc3b3 239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
79072805 240 }
463ee0b2 241
8772537c 242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
243 return 0;
244}
245
954c1994
GS
246/*
247=for apidoc mg_length
248
249Report on the SV's length. See C<sv_magic>.
250
251=cut
252*/
253
79072805 254U32
864dbfa3 255Perl_mg_length(pTHX_ SV *sv)
79072805 256{
97aff369 257 dVAR;
79072805 258 MAGIC* mg;
463ee0b2 259 STRLEN len;
463ee0b2 260
79072805 261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 262 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 263 if (vtbl && vtbl->svt_len) {
35a4481c 264 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 265 save_magic(mgs_ix, sv);
a0d0e21e 266 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
8772537c 268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
269 return len;
270 }
271 }
272
35a4481c 273 if (DO_UTF8(sv)) {
10516c54 274 const U8 *s = (U8*)SvPV_const(sv, len);
5636d518
DB
275 len = Perl_utf8_length(aTHX_ s, s + len);
276 }
277 else
10516c54 278 (void)SvPV_const(sv, len);
463ee0b2 279 return len;
79072805
LW
280}
281
8fb26106 282I32
864dbfa3 283Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
284{
285 MAGIC* mg;
ac27b0f5 286
93965878 287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 288 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 289 if (vtbl && vtbl->svt_len) {
35a4481c
AL
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
291 I32 len;
455ece5e 292 save_magic(mgs_ix, sv);
93965878 293 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
8772537c 295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
296 return len;
297 }
298 }
299
300 switch(SvTYPE(sv)) {
301 case SVt_PVAV:
35a4481c 302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
93965878
NIS
303 case SVt_PVHV:
304 /* FIXME */
305 default:
cea2e8a9 306 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
307 break;
308 }
309 return 0;
310}
311
954c1994
GS
312/*
313=for apidoc mg_clear
314
315Clear something magical that the SV represents. See C<sv_magic>.
316
317=cut
318*/
319
79072805 320int
864dbfa3 321Perl_mg_clear(pTHX_ SV *sv)
79072805 322{
35a4481c 323 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 324 MAGIC* mg;
463ee0b2 325
455ece5e 326 save_magic(mgs_ix, sv);
463ee0b2 327
79072805 328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 329 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 330 /* omit GSKIP -- never set here */
727405f8 331
2b260de0 332 if (vtbl && vtbl->svt_clear)
fc0dc3b3 333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 334 }
463ee0b2 335
8772537c 336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
337 return 0;
338}
339
954c1994
GS
340/*
341=for apidoc mg_find
342
343Finds the magic pointer for type matching the SV. See C<sv_magic>.
344
345=cut
346*/
347
93a17b20 348MAGIC*
35a4481c 349Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 350{
35a4481c
AL
351 if (sv) {
352 MAGIC *mg;
353 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
354 if (mg->mg_type == type)
355 return mg;
356 }
93a17b20
LW
357 }
358 return 0;
359}
360
954c1994
GS
361/*
362=for apidoc mg_copy
363
364Copies the magic from one SV to another. See C<sv_magic>.
365
366=cut
367*/
368
79072805 369int
864dbfa3 370Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 371{
463ee0b2 372 int count = 0;
79072805 373 MAGIC* mg;
463ee0b2 374 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 375 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93
NIS
376 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
377 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
378 }
823a54a3
AL
379 else {
380 const char type = mg->mg_type;
381 if (isUPPER(type)) {
382 sv_magic(nsv,
383 (type == PERL_MAGIC_tied)
384 ? SvTIED_obj(sv, mg)
385 : (type == PERL_MAGIC_regdata && mg->mg_obj)
386 ? sv
387 : mg->mg_obj,
388 toLOWER(type), key, klen);
389 count++;
390 }
79072805 391 }
79072805 392 }
463ee0b2 393 return count;
79072805
LW
394}
395
954c1994 396/*
0cbee0a4
DM
397=for apidoc mg_localize
398
399Copy some of the magic from an existing SV to new localized version of
400that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
401doesn't (eg taint, pos).
402
403=cut
404*/
405
406void
407Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
408{
97aff369 409 dVAR;
0cbee0a4
DM
410 MAGIC *mg;
411 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
412 const MGVTBL* const vtbl = mg->mg_virtual;
413 switch (mg->mg_type) {
414 /* value magic types: don't copy */
415 case PERL_MAGIC_bm:
416 case PERL_MAGIC_fm:
417 case PERL_MAGIC_regex_global:
418 case PERL_MAGIC_nkeys:
419#ifdef USE_LOCALE_COLLATE
420 case PERL_MAGIC_collxfrm:
421#endif
422 case PERL_MAGIC_qr:
423 case PERL_MAGIC_taint:
424 case PERL_MAGIC_vec:
425 case PERL_MAGIC_vstring:
426 case PERL_MAGIC_utf8:
427 case PERL_MAGIC_substr:
428 case PERL_MAGIC_defelem:
429 case PERL_MAGIC_arylen:
430 case PERL_MAGIC_pos:
431 case PERL_MAGIC_backref:
432 case PERL_MAGIC_arylen_p:
433 case PERL_MAGIC_rhash:
434 case PERL_MAGIC_symtab:
435 continue;
436 }
437
a5063e7c
DM
438 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
439 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
440 else
0cbee0a4
DM
441 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
442 mg->mg_ptr, mg->mg_len);
a5063e7c 443
0cbee0a4
DM
444 /* container types should remain read-only across localization */
445 SvFLAGS(nsv) |= SvREADONLY(sv);
446 }
447
448 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
449 SvFLAGS(nsv) |= SvMAGICAL(sv);
450 PL_localizing = 1;
451 SvSETMAGIC(nsv);
452 PL_localizing = 0;
453 }
454}
455
456/*
954c1994
GS
457=for apidoc mg_free
458
459Free any magic storage used by the SV. See C<sv_magic>.
460
461=cut
462*/
463
79072805 464int
864dbfa3 465Perl_mg_free(pTHX_ SV *sv)
79072805
LW
466{
467 MAGIC* mg;
468 MAGIC* moremagic;
469 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
35a4481c 470 const MGVTBL* const vtbl = mg->mg_virtual;
79072805 471 moremagic = mg->mg_moremagic;
2b260de0 472 if (vtbl && vtbl->svt_free)
fc0dc3b3 473 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 474 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
979acdb5 475 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
88e89b8a 476 Safefree(mg->mg_ptr);
565764a8 477 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 478 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 479 }
b881518d
JH
480 if (mg->mg_flags & MGf_REFCOUNTED)
481 SvREFCNT_dec(mg->mg_obj);
79072805
LW
482 Safefree(mg);
483 }
b162af07 484 SvMAGIC_set(sv, NULL);
79072805
LW
485 return 0;
486}
487
79072805 488#include <signal.h>
79072805 489
942e002e 490U32
864dbfa3 491Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 492{
97aff369 493 dVAR;
8772537c 494 PERL_UNUSED_ARG(sv);
6cef1e77 495
0bd48802
AL
496 if (PL_curpm) {
497 register const REGEXP * const rx = PM_GETRE(PL_curpm);
498 if (rx) {
499 return mg->mg_obj
500 ? rx->nparens /* @+ */
501 : rx->lastparen; /* @- */
502 }
8f580fb8 503 }
ac27b0f5 504
942e002e 505 return (U32)-1;
6cef1e77
IZ
506}
507
508int
864dbfa3 509Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 510{
97aff369 511 dVAR;
0bd48802
AL
512 if (PL_curpm) {
513 register const REGEXP * const rx = PM_GETRE(PL_curpm);
514 if (rx) {
515 register const I32 paren = mg->mg_len;
516 register I32 s;
517 register I32 t;
518 if (paren < 0)
519 return 0;
520 if (paren <= (I32)rx->nparens &&
521 (s = rx->startp[paren]) != -1 &&
522 (t = rx->endp[paren]) != -1)
523 {
524 register I32 i;
525 if (mg->mg_obj) /* @+ */
526 i = t;
527 else /* @- */
528 i = s;
529
530 if (i > 0 && RX_MATCH_UTF8(rx)) {
531 const char * const b = rx->subbeg;
532 if (b)
533 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
534 }
727405f8 535
0bd48802 536 sv_setiv(sv, i);
1aa99e6b 537 }
0bd48802 538 }
6cef1e77
IZ
539 }
540 return 0;
541}
542
e4b89193 543int
a29d06ed
MG
544Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
545{
8772537c 546 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
a29d06ed 547 Perl_croak(aTHX_ PL_no_modify);
0dbb1585 548 NORETURN_FUNCTION_END;
a29d06ed
MG
549}
550
93a17b20 551U32
864dbfa3 552Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20 553{
97aff369 554 dVAR;
93a17b20 555 register I32 paren;
93a17b20 556 register I32 i;
dd374669 557 register const REGEXP *rx;
a197cbdd 558 I32 s1, t1;
93a17b20
LW
559
560 switch (*mg->mg_ptr) {
561 case '1': case '2': case '3': case '4':
562 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 563 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 564
ffc61ed2 565 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 566 getparen:
eb160463 567 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
568 (s1 = rx->startp[paren]) != -1 &&
569 (t1 = rx->endp[paren]) != -1)
bbce6d69 570 {
cf93c79d 571 i = t1 - s1;
a197cbdd 572 getlen:
a30b2f1f 573 if (i > 0 && RX_MATCH_UTF8(rx)) {
a28509cc 574 const char * const s = rx->subbeg + s1;
768c67ee
JH
575 const U8 *ep;
576 STRLEN el;
ffc61ed2 577
6d5fa195 578 i = t1 - s1;
768c67ee
JH
579 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
580 i = el;
a197cbdd 581 }
ffc61ed2 582 if (i < 0)
0844c848 583 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 584 return i;
93a17b20 585 }
235bddc8
NIS
586 else {
587 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 588 report_uninit(sv);
235bddc8
NIS
589 }
590 }
591 else {
592 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 593 report_uninit(sv);
93a17b20 594 }
748a9306 595 return 0;
93a17b20 596 case '+':
aaa362c4 597 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 598 paren = rx->lastparen;
13f57bf8
CS
599 if (paren)
600 goto getparen;
93a17b20 601 }
748a9306 602 return 0;
a01268b5
JH
603 case '\016': /* ^N */
604 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
605 paren = rx->lastcloseparen;
606 if (paren)
607 goto getparen;
608 }
609 return 0;
93a17b20 610 case '`':
aaa362c4 611 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
612 if (rx->startp[0] != -1) {
613 i = rx->startp[0];
a197cbdd
GS
614 if (i > 0) {
615 s1 = 0;
616 t1 = i;
617 goto getlen;
618 }
93a17b20 619 }
93a17b20 620 }
748a9306 621 return 0;
93a17b20 622 case '\'':
aaa362c4 623 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
624 if (rx->endp[0] != -1) {
625 i = rx->sublen - rx->endp[0];
a197cbdd
GS
626 if (i > 0) {
627 s1 = rx->endp[0];
628 t1 = rx->sublen;
629 goto getlen;
630 }
93a17b20 631 }
93a17b20 632 }
748a9306 633 return 0;
93a17b20
LW
634 }
635 magic_get(sv,mg);
2d8e6c8d 636 if (!SvPOK(sv) && SvNIOK(sv)) {
8b6b16e7 637 sv_2pv(sv, 0);
2d8e6c8d 638 }
93a17b20
LW
639 if (SvPOK(sv))
640 return SvCUR(sv);
641 return 0;
642}
643
ad3296c6
SH
644#define SvRTRIM(sv) STMT_START { \
645 STRLEN len = SvCUR(sv); \
6136c704
AL
646 char * const p = SvPVX(sv); \
647 while (len > 0 && isSPACE(p[len-1])) \
ad3296c6
SH
648 --len; \
649 SvCUR_set(sv, len); \
bb4058bb 650 p[len] = '\0'; \
ad3296c6
SH
651} STMT_END
652
79072805 653int
864dbfa3 654Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 655{
27da23d5 656 dVAR;
79072805 657 register I32 paren;
35272f84 658 register char *s = NULL;
79072805 659 register I32 i;
d9f97599 660 register REGEXP *rx;
823a54a3
AL
661 const char * const remaining = mg->mg_ptr + 1;
662 const char nextchar = *remaining;
79072805
LW
663
664 switch (*mg->mg_ptr) {
748a9306 665 case '\001': /* ^A */
3280af22 666 sv_setsv(sv, PL_bodytarget);
748a9306 667 break;
e5218da5 668 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
823a54a3 669 if (nextchar == '\0') {
e5218da5
GA
670 sv_setiv(sv, (IV)PL_minus_c);
671 }
823a54a3 672 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
e5218da5
GA
673 sv_setiv(sv, (IV)STATUS_NATIVE);
674 }
49460fe6
NIS
675 break;
676
79072805 677 case '\004': /* ^D */
aea4f609 678 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 679 break;
28f23441 680 case '\005': /* ^E */
823a54a3 681 if (nextchar == '\0') {
cd39f2b6 682#ifdef MACOS_TRADITIONAL
0a378802
JH
683 {
684 char msg[256];
727405f8 685
0a378802 686 sv_setnv(sv,(double)gMacPerl_OSErr);
727405f8 687 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
0a378802 688 }
727405f8 689#else
28f23441 690#ifdef VMS
0a378802
JH
691 {
692# include <descrip.h>
693# include <starlet.h>
694 char msg[255];
695 $DESCRIPTOR(msgdsc,msg);
696 sv_setnv(sv,(NV) vaxc$errno);
697 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
698 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
699 else
c69006e4 700 sv_setpvn(sv,"",0);
0a378802 701 }
28f23441 702#else
88e89b8a 703#ifdef OS2
0a378802
JH
704 if (!(_emx_env & 0x200)) { /* Under DOS */
705 sv_setnv(sv, (NV)errno);
706 sv_setpv(sv, errno ? Strerror(errno) : "");
707 } else {
708 if (errno != errno_isOS2) {
823a54a3 709 const int tmp = _syserrno();
0a378802
JH
710 if (tmp) /* 2nd call to _syserrno() makes it 0 */
711 Perl_rc = tmp;
712 }
713 sv_setnv(sv, (NV)Perl_rc);
714 sv_setpv(sv, os2error(Perl_rc));
715 }
88e89b8a 716#else
22fae026 717#ifdef WIN32
0a378802
JH
718 {
719 DWORD dwErr = GetLastError();
720 sv_setnv(sv, (NV)dwErr);
823a54a3 721 if (dwErr) {
0a378802
JH
722 PerlProc_GetOSError(sv, dwErr);
723 }
724 else
c69006e4 725 sv_setpvn(sv, "", 0);
0a378802
JH
726 SetLastError(dwErr);
727 }
22fae026 728#else
f6c8f21d 729 {
8772537c 730 const int saveerrno = errno;
f6c8f21d
RGS
731 sv_setnv(sv, (NV)errno);
732 sv_setpv(sv, errno ? Strerror(errno) : "");
733 errno = saveerrno;
734 }
28f23441 735#endif
88e89b8a 736#endif
22fae026 737#endif
cd39f2b6 738#endif
ad3296c6 739 SvRTRIM(sv);
0a378802
JH
740 SvNOK_on(sv); /* what a wonderful hack! */
741 }
823a54a3 742 else if (strEQ(remaining, "NCODING"))
0a378802
JH
743 sv_setsv(sv, PL_encoding);
744 break;
79072805 745 case '\006': /* ^F */
3280af22 746 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 747 break;
a0d0e21e 748 case '\010': /* ^H */
3280af22 749 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 750 break;
9d116dd7 751 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
752 if (PL_inplace)
753 sv_setpv(sv, PL_inplace);
79072805 754 else
3280af22 755 sv_setsv(sv, &PL_sv_undef);
79072805 756 break;
ac27b0f5 757 case '\017': /* ^O & ^OPEN */
823a54a3 758 if (nextchar == '\0') {
ac27b0f5 759 sv_setpv(sv, PL_osname);
3511154c
DM
760 SvTAINTED_off(sv);
761 }
823a54a3 762 else if (strEQ(remaining, "PEN")) {
ac27b0f5
NIS
763 if (!PL_compiling.cop_io)
764 sv_setsv(sv, &PL_sv_undef);
765 else {
766 sv_setsv(sv, PL_compiling.cop_io);
767 }
768 }
28f23441 769 break;
79072805 770 case '\020': /* ^P */
3280af22 771 sv_setiv(sv, (IV)PL_perldb);
79072805 772 break;
fb73857a 773 case '\023': /* ^S */
823a54a3 774 if (nextchar == '\0') {
3280af22 775 if (PL_lex_state != LEX_NOTPARSING)
0c34ef67 776 SvOK_off(sv);
3280af22 777 else if (PL_in_eval)
6dc8a9e4 778 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
779 else
780 sv_setiv(sv, 0);
d58bf5aa 781 }
fb73857a 782 break;
79072805 783 case '\024': /* ^T */
823a54a3 784 if (nextchar == '\0') {
88e89b8a 785#ifdef BIG_TIME
7c36658b 786 sv_setnv(sv, PL_basetime);
88e89b8a 787#else
7c36658b 788 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 789#endif
7c36658b 790 }
823a54a3 791 else if (strEQ(remaining, "AINT"))
9aa05f58
RGS
792 sv_setiv(sv, PL_tainting
793 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
794 : 0);
7c36658b 795 break;
7cebcbc0 796 case '\025': /* $^UNICODE, $^UTF8LOCALE */
823a54a3 797 if (strEQ(remaining, "NICODE"))
a05d7ebb 798 sv_setuv(sv, (UV) PL_unicode);
823a54a3 799 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 800 sv_setuv(sv, (UV) PL_utf8locale);
fde18df1
JH
801 break;
802 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 803 if (nextchar == '\0')
4438c4b7 804 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 805 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 806 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 807 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS
808 }
809 else if (PL_compiling.cop_warnings == pWARN_STD) {
810 sv_setpvn(
811 sv,
812 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
813 WARNsize
814 );
815 }
d3a7d8c7 816 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
817 /* Get the bit mask for $warnings::Bits{all}, because
818 * it could have been extended by warnings::register */
819 SV **bits_all;
823a54a3 820 HV * const bits=get_hv("warnings::Bits", FALSE);
75b6c4ca
RGS
821 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
822 sv_setsv(sv, *bits_all);
823 }
824 else {
825 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
826 }
ac27b0f5 827 }
4438c4b7
JH
828 else {
829 sv_setsv(sv, PL_compiling.cop_warnings);
ac27b0f5 830 }
d3a7d8c7 831 SvPOK_only(sv);
4438c4b7 832 }
79072805
LW
833 break;
834 case '1': case '2': case '3': case '4':
835 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 836 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
837 I32 s1, t1;
838
a863c7d1
MB
839 /*
840 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
841 * XXX Does the new way break anything?
842 */
ffc61ed2 843 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 844 getparen:
eb160463 845 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
846 (s1 = rx->startp[paren]) != -1 &&
847 (t1 = rx->endp[paren]) != -1)
bbce6d69 848 {
cf93c79d
IZ
849 i = t1 - s1;
850 s = rx->subbeg + s1;
01ec43d0 851 if (!rx->subbeg)
c2e66d9e
GS
852 break;
853
13f57bf8 854 getrx:
748a9306 855 if (i >= 0) {
fabdb6c0 856 const int oldtainted = PL_tainted;
f6ba9920 857 TAINT_NOT;
cf93c79d 858 sv_setpvn(sv, s, i);
f6ba9920 859 PL_tainted = oldtainted;
a30b2f1f 860 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
7e2040f0
GS
861 SvUTF8_on(sv);
862 else
863 SvUTF8_off(sv);
e9814ee1
HS
864 if (PL_tainting) {
865 if (RX_MATCH_TAINTED(rx)) {
823a54a3 866 MAGIC* const mg = SvMAGIC(sv);
e9814ee1
HS
867 MAGIC* mgt;
868 PL_tainted = 1;
b162af07 869 SvMAGIC_set(sv, mg->mg_moremagic);
e9814ee1
HS
870 SvTAINT(sv);
871 if ((mgt = SvMAGIC(sv))) {
872 mg->mg_moremagic = mgt;
b162af07 873 SvMAGIC_set(sv, mg);
e9814ee1
HS
874 }
875 } else
876 SvTAINTED_off(sv);
877 }
748a9306
LW
878 break;
879 }
79072805 880 }
79072805 881 }
3280af22 882 sv_setsv(sv,&PL_sv_undef);
79072805
LW
883 break;
884 case '+':
aaa362c4 885 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 886 paren = rx->lastparen;
a0d0e21e
LW
887 if (paren)
888 goto getparen;
79072805 889 }
3280af22 890 sv_setsv(sv,&PL_sv_undef);
79072805 891 break;
a01268b5
JH
892 case '\016': /* ^N */
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
894 paren = rx->lastcloseparen;
895 if (paren)
896 goto getparen;
897 }
898 sv_setsv(sv,&PL_sv_undef);
899 break;
79072805 900 case '`':
aaa362c4 901 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
902 if ((s = rx->subbeg) && rx->startp[0] != -1) {
903 i = rx->startp[0];
13f57bf8 904 goto getrx;
79072805 905 }
79072805 906 }
3280af22 907 sv_setsv(sv,&PL_sv_undef);
79072805
LW
908 break;
909 case '\'':
aaa362c4 910 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
911 if (rx->subbeg && rx->endp[0] != -1) {
912 s = rx->subbeg + rx->endp[0];
913 i = rx->sublen - rx->endp[0];
13f57bf8 914 goto getrx;
79072805 915 }
79072805 916 }
3280af22 917 sv_setsv(sv,&PL_sv_undef);
79072805
LW
918 break;
919 case '.':
3280af22 920 if (GvIO(PL_last_in_gv)) {
357c8808 921 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 922 }
79072805
LW
923 break;
924 case '?':
809a5acc 925 {
809a5acc 926 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 927#ifdef COMPLEX_STATUS
6b88bc9c
GS
928 LvTARGOFF(sv) = PL_statusvalue;
929 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 930#endif
809a5acc 931 }
79072805
LW
932 break;
933 case '^':
0daa599b
RGS
934 if (GvIOp(PL_defoutgv))
935 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
936 if (s)
937 sv_setpv(sv,s);
938 else {
3280af22 939 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
940 sv_catpv(sv,"_TOP");
941 }
942 break;
943 case '~':
0daa599b
RGS
944 if (GvIOp(PL_defoutgv))
945 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 946 if (!s)
3280af22 947 s = GvENAME(PL_defoutgv);
79072805
LW
948 sv_setpv(sv,s);
949 break;
79072805 950 case '=':
0daa599b
RGS
951 if (GvIOp(PL_defoutgv))
952 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
953 break;
954 case '-':
0daa599b
RGS
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
957 break;
958 case '%':
0daa599b
RGS
959 if (GvIOp(PL_defoutgv))
960 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 961 break;
79072805
LW
962 case ':':
963 break;
964 case '/':
965 break;
966 case '[':
3280af22 967 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
968 break;
969 case '|':
0daa599b
RGS
970 if (GvIOp(PL_defoutgv))
971 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
972 break;
973 case ',':
79072805
LW
974 break;
975 case '\\':
b2ce0fda 976 if (PL_ors_sv)
f28098ff 977 sv_copypv(sv, PL_ors_sv);
79072805 978 break;
79072805 979 case '!':
a5f75d66 980#ifdef VMS
65202027 981 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 982 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 983#else
88e89b8a 984 {
8772537c 985 const int saveerrno = errno;
65202027 986 sv_setnv(sv, (NV)errno);
88e89b8a 987#ifdef OS2
ed344e4f
IZ
988 if (errno == errno_isOS2 || errno == errno_isOS2_set)
989 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 990 else
a5f75d66 991#endif
2304df62 992 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
993 errno = saveerrno;
994 }
995#endif
ad3296c6 996 SvRTRIM(sv);
946ec16e 997 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
998 break;
999 case '<':
3280af22 1000 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1001 break;
1002 case '>':
3280af22 1003 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1004 break;
1005 case '(':
3280af22 1006 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 1007#ifdef HAS_GETGROUPS
afd78fd5 1008 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 1009#endif
79072805
LW
1010 goto add_groups;
1011 case ')':
3280af22 1012 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 1013#ifdef HAS_GETGROUPS
afd78fd5 1014 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 1015#endif
79072805 1016 add_groups:
79072805 1017#ifdef HAS_GETGROUPS
79072805 1018 {
57d7c65e
JC
1019 Groups_t *gary = NULL;
1020 I32 num_groups = getgroups(0, gary);
1021 Newx(gary, num_groups, Groups_t);
1022 num_groups = getgroups(num_groups, gary);
1023 while (--num_groups >= 0)
1024 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
afd78fd5 1025 gary[num_groups]);
57d7c65e 1026 Safefree(gary);
79072805
LW
1027 }
1028#endif
155aba94 1029 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805 1030 break;
cd39f2b6 1031#ifndef MACOS_TRADITIONAL
79072805
LW
1032 case '0':
1033 break;
cd39f2b6 1034#endif
79072805 1035 }
a0d0e21e 1036 return 0;
79072805
LW
1037}
1038
1039int
864dbfa3 1040Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1041{
8772537c 1042 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
1043
1044 if (uf && uf->uf_val)
24f81a43 1045 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1046 return 0;
1047}
1048
1049int
864dbfa3 1050Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1051{
27da23d5 1052 dVAR;
5aabfad6 1053 STRLEN len, klen;
fabdb6c0
AL
1054 const char *s = SvPV_const(sv,len);
1055 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1056 my_setenv(ptr, s);
1e422769 1057
a0d0e21e
LW
1058#ifdef DYNAMIC_ENV_FETCH
1059 /* We just undefd an environment var. Is a replacement */
1060 /* waiting in the wings? */
1061 if (!len) {
fabdb6c0
AL
1062 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1063 if (valp)
b83604b4 1064 s = SvPV_const(*valp, len);
a0d0e21e
LW
1065 }
1066#endif
1e422769 1067
39e571d4 1068#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1069 /* And you'll never guess what the dog had */
1070 /* in its mouth... */
3280af22 1071 if (PL_tainting) {
1e422769
PP
1072 MgTAINTEDDIR_off(mg);
1073#ifdef VMS
5aabfad6 1074 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1075 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1076 Stat_t sbuf;
1e422769
PP
1077 int i = 0, j = 0;
1078
b8ffc8df
RGS
1079 strncpy(eltbuf, s, 255);
1080 eltbuf[255] = 0;
1081 elt = eltbuf;
1e422769
PP
1082 do { /* DCL$PATH may be a search list */
1083 while (1) { /* as may dev portion of any element */
1084 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1085 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1086 cando_by_name(S_IWUSR,0,elt) ) {
1087 MgTAINTEDDIR_on(mg);
1088 return 0;
1089 }
1090 }
1091 if ((cp = strchr(elt, ':')) != Nullch)
1092 *cp = '\0';
1093 if (my_trnlnm(elt, eltbuf, j++))
1094 elt = eltbuf;
1095 else
1096 break;
1097 }
1098 j = 0;
1099 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1100 }
1101#endif /* VMS */
5aabfad6 1102 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1103 const char * const strend = s + len;
463ee0b2
LW
1104
1105 while (s < strend) {
96827780 1106 char tmpbuf[256];
c623ac67 1107 Stat_t st;
5f74f29c 1108 I32 i;
96827780 1109 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1110 s, strend, ':', &i);
463ee0b2 1111 s++;
96827780
MB
1112 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1113 || *tmpbuf != '/'
c6ed36e1 1114 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1115 MgTAINTEDDIR_on(mg);
1e422769
PP
1116 return 0;
1117 }
463ee0b2 1118 }
79072805
LW
1119 }
1120 }
39e571d4 1121#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1122
79072805
LW
1123 return 0;
1124}
1125
1126int
864dbfa3 1127Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1128{
8772537c 1129 PERL_UNUSED_ARG(sv);
01b8bcb7 1130 my_setenv(MgPV_nolen_const(mg),Nullch);
85e6fe83
LW
1131 return 0;
1132}
1133
88e89b8a 1134int
864dbfa3 1135Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1136{
97aff369 1137 dVAR;
65e66c80 1138 PERL_UNUSED_ARG(mg);
b0269e46 1139#if defined(VMS)
cea2e8a9 1140 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1141#else
3280af22 1142 if (PL_localizing) {
fb73857a 1143 HE* entry;
b0269e46 1144 my_clearenv();
fb73857a 1145 hv_iterinit((HV*)sv);
155aba94 1146 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1147 I32 keylen;
1148 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1149 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1150 }
1151 }
1152#endif
1153 return 0;
1154}
1155
1156int
864dbfa3 1157Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1158{
27da23d5 1159 dVAR;
8772537c
AL
1160 PERL_UNUSED_ARG(sv);
1161 PERL_UNUSED_ARG(mg);
b0269e46
AB
1162#if defined(VMS)
1163 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1164#else
1165 my_clearenv();
1166#endif
3e3baf6d 1167 return 0;
66b1d557
HM
1168}
1169
64ca3a65 1170#ifndef PERL_MICRO
2d4fcd5e
AJ
1171#ifdef HAS_SIGPROCMASK
1172static void
1173restore_sigmask(pTHX_ SV *save_sv)
1174{
0bd48802 1175 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
2d4fcd5e
AJ
1176 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1177}
1178#endif
66b1d557 1179int
864dbfa3 1180Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1181{
97aff369 1182 dVAR;
88e89b8a 1183 /* Are we fetching a signal entry? */
8772537c 1184 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1185 if (i > 0) {
22c35a8c
GS
1186 if(PL_psig_ptr[i])
1187 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1188 else {
85b332e2 1189 Sighandler_t sigstate;
2e34cc90 1190 sigstate = rsignal_state(i);
23ada85b 1191#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1192 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
2e34cc90
CL
1193#endif
1194#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1195 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1196#endif
88e89b8a 1197 /* cache state so we don't fetch it again */
8aad04aa 1198 if(sigstate == (Sighandler_t) SIG_IGN)
88e89b8a
PP
1199 sv_setpv(sv,"IGNORE");
1200 else
3280af22 1201 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1202 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1203 SvTEMP_off(sv);
1204 }
1205 }
1206 return 0;
1207}
1208int
864dbfa3 1209Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1210{
2d4fcd5e
AJ
1211 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1212 * refactoring might be in order.
1213 */
27da23d5 1214 dVAR;
8772537c
AL
1215 register const char * const s = MgPV_nolen_const(mg);
1216 PERL_UNUSED_ARG(sv);
2d4fcd5e 1217 if (*s == '_') {
cbbf8932 1218 SV** svp = NULL;
2d4fcd5e
AJ
1219 if (strEQ(s,"__DIE__"))
1220 svp = &PL_diehook;
1221 else if (strEQ(s,"__WARN__"))
1222 svp = &PL_warnhook;
1223 else
1224 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1225 if (svp && *svp) {
8772537c 1226 SV * const to_dec = *svp;
cbbf8932 1227 *svp = NULL;
2d4fcd5e
AJ
1228 SvREFCNT_dec(to_dec);
1229 }
1230 }
1231 else {
2d4fcd5e 1232 /* Are we clearing a signal entry? */
8772537c 1233 const I32 i = whichsig(s);
e02bfb16 1234 if (i > 0) {
2d4fcd5e
AJ
1235#ifdef HAS_SIGPROCMASK
1236 sigset_t set, save;
1237 SV* save_sv;
1238 /* Avoid having the signal arrive at a bad time, if possible. */
1239 sigemptyset(&set);
1240 sigaddset(&set,i);
1241 sigprocmask(SIG_BLOCK, &set, &save);
1242 ENTER;
1243 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1244 SAVEFREESV(save_sv);
1245 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1246#endif
1247 PERL_ASYNC_CHECK();
1248#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1249 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1250#endif
1251#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1252 PL_sig_defaulting[i] = 1;
5c1546dc 1253 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1254#else
8aad04aa 1255 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1256#endif
1257 if(PL_psig_name[i]) {
1258 SvREFCNT_dec(PL_psig_name[i]);
1259 PL_psig_name[i]=0;
1260 }
1261 if(PL_psig_ptr[i]) {
6136c704 1262 SV * const to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1263 PL_psig_ptr[i]=0;
1264 LEAVE;
1265 SvREFCNT_dec(to_dec);
1266 }
1267 else
1268 LEAVE;
1269 }
88e89b8a
PP
1270 }
1271 return 0;
1272}
3d37d572 1273
dd374669
AL
1274static void
1275S_raise_signal(pTHX_ int sig)
0a8e0eff 1276{
97aff369 1277 dVAR;
0a8e0eff
NIS
1278 /* Set a flag to say this signal is pending */
1279 PL_psig_pend[sig]++;
1280 /* And one to say _a_ signal is pending */
1281 PL_sig_pending = 1;
1282}
1283
1284Signal_t
8aad04aa
JH
1285#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1286Perl_csighandler(int sig, ...)
1287#else
0a8e0eff 1288Perl_csighandler(int sig)
8aad04aa 1289#endif
0a8e0eff 1290{
1018e26f
NIS
1291#ifdef PERL_GET_SIG_CONTEXT
1292 dTHXa(PERL_GET_SIG_CONTEXT);
1293#else
85b332e2
CL
1294 dTHX;
1295#endif
23ada85b 1296#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1297 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1298 if (PL_sig_ignoring[sig]) return;
85b332e2 1299#endif
2e34cc90 1300#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1301 if (PL_sig_defaulting[sig])
2e34cc90
CL
1302#ifdef KILL_BY_SIGPRC
1303 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1304#else
1305 exit(1);
1306#endif
1307#endif
4ffa73a3
JH
1308 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1309 /* Call the perl level handler now--
1310 * with risk we may be in malloc() etc. */
1311 (*PL_sighandlerp)(sig);
1312 else
dd374669 1313 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1314}
1315
2e34cc90
CL
1316#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1317void
1318Perl_csighandler_init(void)
1319{
1320 int sig;
27da23d5 1321 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1322
1323 for (sig = 1; sig < SIG_SIZE; sig++) {
1324#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1325 dTHX;
27da23d5 1326 PL_sig_defaulting[sig] = 1;
5c1546dc 1327 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1328#endif
1329#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1330 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1331#endif
1332 }
27da23d5 1333 PL_sig_handlers_initted = 1;
2e34cc90
CL
1334}
1335#endif
1336
0a8e0eff
NIS
1337void
1338Perl_despatch_signals(pTHX)
1339{
97aff369 1340 dVAR;
0a8e0eff
NIS
1341 int sig;
1342 PL_sig_pending = 0;
1343 for (sig = 1; sig < SIG_SIZE; sig++) {
1344 if (PL_psig_pend[sig]) {
25da4428
JH
1345 PERL_BLOCKSIG_ADD(set, sig);
1346 PL_psig_pend[sig] = 0;
1347 PERL_BLOCKSIG_BLOCK(set);
f5203343 1348 (*PL_sighandlerp)(sig);
25da4428 1349 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1350 }
1351 }
1352}
1353
85e6fe83 1354int
864dbfa3 1355Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1356{
27da23d5 1357 dVAR;
79072805 1358 I32 i;
cbbf8932 1359 SV** svp = NULL;
2d4fcd5e
AJ
1360 /* Need to be careful with SvREFCNT_dec(), because that can have side
1361 * effects (due to closures). We must make sure that the new disposition
1362 * is in place before it is called.
1363 */
cbbf8932 1364 SV* to_dec = NULL;
e72dc28c 1365 STRLEN len;
2d4fcd5e
AJ
1366#ifdef HAS_SIGPROCMASK
1367 sigset_t set, save;
1368 SV* save_sv;
1369#endif
a0d0e21e 1370
d5263905 1371 register const char *s = MgPV_const(mg,len);
748a9306
LW
1372 if (*s == '_') {
1373 if (strEQ(s,"__DIE__"))
3280af22 1374 svp = &PL_diehook;
748a9306 1375 else if (strEQ(s,"__WARN__"))
3280af22 1376 svp = &PL_warnhook;
748a9306 1377 else
cea2e8a9 1378 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1379 i = 0;
4633a7c4 1380 if (*svp) {
2d4fcd5e 1381 to_dec = *svp;
cbbf8932 1382 *svp = NULL;
4633a7c4 1383 }
748a9306
LW
1384 }
1385 else {
1386 i = whichsig(s); /* ...no, a brick */
86d86cad 1387 if (i <= 0) {
e476b1b5 1388 if (ckWARN(WARN_SIGNAL))
9014280d 1389 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1390 return 0;
1391 }
2d4fcd5e
AJ
1392#ifdef HAS_SIGPROCMASK
1393 /* Avoid having the signal arrive at a bad time, if possible. */
1394 sigemptyset(&set);
1395 sigaddset(&set,i);
1396 sigprocmask(SIG_BLOCK, &set, &save);
1397 ENTER;
1398 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1399 SAVEFREESV(save_sv);
1400 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1401#endif
1402 PERL_ASYNC_CHECK();
2e34cc90 1403#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1404 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1405#endif
23ada85b 1406#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1407 PL_sig_ignoring[i] = 0;
85b332e2 1408#endif
2e34cc90 1409#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1410 PL_sig_defaulting[i] = 0;
2e34cc90 1411#endif
22c35a8c 1412 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1413 to_dec = PL_psig_ptr[i];
22c35a8c 1414 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1415 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1416 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1417 SvREADONLY_on(PL_psig_name[i]);
748a9306 1418 }
a0d0e21e 1419 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1420 if (i) {
5c1546dc 1421 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1422#ifdef HAS_SIGPROCMASK
1423 LEAVE;
1424#endif
1425 }
748a9306
LW
1426 else
1427 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1428 if(to_dec)
1429 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1430 return 0;
1431 }
e72dc28c 1432 s = SvPV_force(sv,len);
748a9306 1433 if (strEQ(s,"IGNORE")) {
85b332e2 1434 if (i) {
23ada85b 1435#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1436 PL_sig_ignoring[i] = 1;
5c1546dc 1437 (void)rsignal(i, PL_csighandlerp);
85b332e2 1438#else
8aad04aa 1439 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1440#endif
2d4fcd5e 1441 }
748a9306
LW
1442 }
1443 else if (strEQ(s,"DEFAULT") || !*s) {
1444 if (i)
2e34cc90
CL
1445#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1446 {
27da23d5 1447 PL_sig_defaulting[i] = 1;
5c1546dc 1448 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1449 }
1450#else
8aad04aa 1451 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1452#endif
748a9306 1453 }
79072805 1454 else {
5aabfad6
PP
1455 /*
1456 * We should warn if HINT_STRICT_REFS, but without
1457 * access to a known hint bit in a known OP, we can't
1458 * tell whether HINT_STRICT_REFS is in force or not.
1459 */
46fc3d4c 1460 if (!strchr(s,':') && !strchr(s,'\''))
89529cee 1461 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
748a9306 1462 if (i)
5c1546dc 1463 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1464 else
1465 *svp = SvREFCNT_inc(sv);
79072805 1466 }
2d4fcd5e
AJ
1467#ifdef HAS_SIGPROCMASK
1468 if(i)
1469 LEAVE;
1470#endif
1471 if(to_dec)
1472 SvREFCNT_dec(to_dec);
79072805
LW
1473 return 0;
1474}
64ca3a65 1475#endif /* !PERL_MICRO */
79072805
LW
1476
1477int
864dbfa3 1478Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1479{
97aff369 1480 dVAR;
8772537c
AL
1481 PERL_UNUSED_ARG(sv);
1482 PERL_UNUSED_ARG(mg);
3280af22 1483 PL_sub_generation++;
463ee0b2
LW
1484 return 0;
1485}
1486
1487int
864dbfa3 1488Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1489{
97aff369 1490 dVAR;
8772537c
AL
1491 PERL_UNUSED_ARG(sv);
1492 PERL_UNUSED_ARG(mg);
a0d0e21e 1493 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1494 PL_amagic_generation++;
463ee0b2 1495
a0d0e21e
LW
1496 return 0;
1497}
463ee0b2 1498
946ec16e 1499int
864dbfa3 1500Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1501{
dd374669 1502 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1503 I32 i = 0;
8772537c 1504 PERL_UNUSED_ARG(mg);
7719e241 1505
6ff81951 1506 if (hv) {
497b47a8
JH
1507 (void) hv_iterinit(hv);
1508 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1509 i = HvKEYS(hv);
1510 else {
1511 while (hv_iternext(hv))
1512 i++;
1513 }
6ff81951
GS
1514 }
1515
1516 sv_setiv(sv, (IV)i);
1517 return 0;
1518}
1519
1520int
864dbfa3 1521Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1522{
8772537c 1523 PERL_UNUSED_ARG(mg);
946ec16e
PP
1524 if (LvTARG(sv)) {
1525 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1526 }
1527 return 0;
ac27b0f5 1528}
946ec16e 1529
e336de0d 1530/* caller is responsible for stack switching/cleanup */
565764a8 1531STATIC int
e1ec3a88 1532S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1533{
97aff369 1534 dVAR;
a0d0e21e 1535 dSP;
463ee0b2 1536
924508f0
GS
1537 PUSHMARK(SP);
1538 EXTEND(SP, n);
33c27489 1539 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1540 if (n > 1) {
93965878 1541 if (mg->mg_ptr) {
565764a8 1542 if (mg->mg_len >= 0)
79cb57f6 1543 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1544 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1545 PUSHs((SV*)mg->mg_ptr);
1546 }
14befaf4 1547 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1548 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1549 }
1550 }
1551 if (n > 2) {
1552 PUSHs(val);
88e89b8a 1553 }
463ee0b2
LW
1554 PUTBACK;
1555
864dbfa3 1556 return call_method(meth, flags);
946ec16e
PP
1557}
1558
76e3520e 1559STATIC int
e1ec3a88 1560S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1561{
27da23d5 1562 dVAR; dSP;
463ee0b2 1563
a0d0e21e
LW
1564 ENTER;
1565 SAVETMPS;
e788e7d3 1566 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1567
33c27489 1568 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1569 sv_setsv(sv, *PL_stack_sp--);
93965878 1570 }
463ee0b2 1571
d3acc0f7 1572 POPSTACK;
a0d0e21e
LW
1573 FREETMPS;
1574 LEAVE;
1575 return 0;
1576}
463ee0b2 1577
a0d0e21e 1578int
864dbfa3 1579Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1580{
a0d0e21e
LW
1581 if (mg->mg_ptr)
1582 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1583 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1584 return 0;
1585}
1586
1587int
864dbfa3 1588Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1589{
27da23d5 1590 dVAR; dSP;
a60c0954 1591 ENTER;
e788e7d3 1592 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1593 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1594 POPSTACK;
a60c0954 1595 LEAVE;
463ee0b2
LW
1596 return 0;
1597}
1598
1599int
864dbfa3 1600Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1601{
a0d0e21e
LW
1602 return magic_methpack(sv,mg,"DELETE");
1603}
463ee0b2 1604
93965878
NIS
1605
1606U32
864dbfa3 1607Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1608{
27da23d5 1609 dVAR; dSP;
93965878
NIS
1610 U32 retval = 0;
1611
1612 ENTER;
1613 SAVETMPS;
e788e7d3 1614 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1615 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1616 sv = *PL_stack_sp--;
a60c0954 1617 retval = (U32) SvIV(sv)-1;
93965878 1618 }
d3acc0f7 1619 POPSTACK;
93965878
NIS
1620 FREETMPS;
1621 LEAVE;
1622 return retval;
1623}
1624
cea2e8a9
GS
1625int
1626Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1627{
27da23d5 1628 dVAR; dSP;
463ee0b2 1629
e336de0d 1630 ENTER;
e788e7d3 1631 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1632 PUSHMARK(SP);
33c27489 1633 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1634 PUTBACK;
864dbfa3 1635 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1636 POPSTACK;
a60c0954 1637 LEAVE;
a3bcc51e 1638
463ee0b2
LW
1639 return 0;
1640}
1641
1642int
864dbfa3 1643Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1644{
27da23d5 1645 dVAR; dSP;
35a4481c 1646 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1647
1648 ENTER;
a0d0e21e 1649 SAVETMPS;
e788e7d3 1650 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1651 PUSHMARK(SP);
1652 EXTEND(SP, 2);
33c27489 1653 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1654 if (SvOK(key))
1655 PUSHs(key);
1656 PUTBACK;
1657
864dbfa3 1658 if (call_method(meth, G_SCALAR))
3280af22 1659 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1660
d3acc0f7 1661 POPSTACK;
a0d0e21e
LW
1662 FREETMPS;
1663 LEAVE;
79072805
LW
1664 return 0;
1665}
1666
1667int
864dbfa3 1668Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1669{
1670 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1671}
a0d0e21e 1672
a3bcc51e
TP
1673SV *
1674Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1675{
27da23d5 1676 dVAR; dSP;
a3bcc51e 1677 SV *retval = &PL_sv_undef;
8772537c
AL
1678 SV * const tied = SvTIED_obj((SV*)hv, mg);
1679 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1680
1681 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1682 SV *key;
bfcb3514 1683 if (HvEITER_get(hv))
a3bcc51e
TP
1684 /* we are in an iteration so the hash cannot be empty */
1685 return &PL_sv_yes;
1686 /* no xhv_eiter so now use FIRSTKEY */
1687 key = sv_newmortal();
1688 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1689 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1690 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1691 }
1692
1693 /* there is a SCALAR method that we can call */
1694 ENTER;
1695 PUSHSTACKi(PERLSI_MAGIC);
1696 PUSHMARK(SP);
1697 EXTEND(SP, 1);
1698 PUSHs(tied);
1699 PUTBACK;
1700
1701 if (call_method("SCALAR", G_SCALAR))
1702 retval = *PL_stack_sp--;
1703 POPSTACK;
1704 LEAVE;
1705 return retval;
1706}
1707
a0d0e21e 1708int
864dbfa3 1709Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1710{
97aff369 1711 dVAR;
8772537c
AL
1712 GV * const gv = PL_DBline;
1713 const I32 i = SvTRUE(sv);
1714 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1715 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1716 if (svp && SvIOKp(*svp)) {
1717 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1718 if (o) {
1719 /* set or clear breakpoint in the relevant control op */
1720 if (i)
1721 o->op_flags |= OPf_SPECIAL;
1722 else
1723 o->op_flags &= ~OPf_SPECIAL;
1724 }
5df8de69 1725 }
79072805
LW
1726 return 0;
1727}
1728
1729int
8772537c 1730Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1731{
97aff369 1732 dVAR;
8772537c 1733 const AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1734 if (obj) {
1735 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1736 } else {
1737 SvOK_off(sv);
1738 }
79072805
LW
1739 return 0;
1740}
1741
1742int
864dbfa3 1743Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1744{
97aff369 1745 dVAR;
8772537c 1746 AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1747 if (obj) {
1748 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1749 } else {
1750 if (ckWARN(WARN_MISC))
1751 Perl_warner(aTHX_ packWARN(WARN_MISC),
1752 "Attempt to set length of freed array");
1753 }
1754 return 0;
1755}
1756
1757int
1758Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1759{
97aff369 1760 dVAR;
53c1dcc0 1761 PERL_UNUSED_ARG(sv);
94f3782b
DM
1762 /* during global destruction, mg_obj may already have been freed */
1763 if (PL_in_clean_all)
1ea47f64 1764 return 0;
94f3782b 1765
83bf042f
NC
1766 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1767
1768 if (mg) {
1769 /* arylen scalar holds a pointer back to the array, but doesn't own a
1770 reference. Hence the we (the array) are about to go away with it
1771 still pointing at us. Clear its pointer, else it would be pointing
1772 at free memory. See the comment in sv_magic about reference loops,
1773 and why it can't own a reference to us. */
1774 mg->mg_obj = 0;
1775 }
a0d0e21e
LW
1776 return 0;
1777}
1778
1779int
864dbfa3 1780Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1781{
97aff369 1782 dVAR;
8772537c 1783 SV* const lsv = LvTARG(sv);
ac27b0f5 1784
a0d0e21e 1785 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1786 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1787 if (mg && mg->mg_len >= 0) {
a0ed51b3 1788 I32 i = mg->mg_len;
7e2040f0 1789 if (DO_UTF8(lsv))
a0ed51b3
LW
1790 sv_pos_b2u(lsv, &i);
1791 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1792 return 0;
1793 }
1794 }
0c34ef67 1795 SvOK_off(sv);
a0d0e21e
LW
1796 return 0;
1797}
1798
1799int
864dbfa3 1800Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1801{
97aff369 1802 dVAR;
8772537c 1803 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1804 SSize_t pos;
1805 STRLEN len;
c00206c8 1806 STRLEN ulen = 0;
a0d0e21e
LW
1807
1808 mg = 0;
ac27b0f5 1809
a0d0e21e 1810 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1811 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1812 if (!mg) {
1813 if (!SvOK(sv))
1814 return 0;
fabdb6c0 1815 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
14befaf4 1816 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1817 }
1818 else if (!SvOK(sv)) {
565764a8 1819 mg->mg_len = -1;
a0d0e21e
LW
1820 return 0;
1821 }
1822 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1823
c485e607 1824 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1825
7e2040f0 1826 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1827 ulen = sv_len_utf8(lsv);
1828 if (ulen)
1829 len = ulen;
a0ed51b3
LW
1830 }
1831
a0d0e21e
LW
1832 if (pos < 0) {
1833 pos += len;
1834 if (pos < 0)
1835 pos = 0;
1836 }
eb160463 1837 else if (pos > (SSize_t)len)
a0d0e21e 1838 pos = len;
a0ed51b3
LW
1839
1840 if (ulen) {
1841 I32 p = pos;
1842 sv_pos_u2b(lsv, &p, 0);
1843 pos = p;
1844 }
727405f8 1845
565764a8 1846 mg->mg_len = pos;
71be2cbc 1847 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1848
79072805
LW
1849 return 0;
1850}
1851
1852int
864dbfa3 1853Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1854{
8772537c 1855 PERL_UNUSED_ARG(mg);
8646b087
PP
1856 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1857 SvFAKE_off(sv);
946ec16e 1858 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1859 SvFAKE_on(sv);
1860 }
1861 else
946ec16e 1862 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1863 return 0;
1864}
1865
1866int
864dbfa3 1867Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1868{
79072805 1869 GV* gv;
8772537c
AL
1870 PERL_UNUSED_ARG(mg);
1871
79072805
LW
1872 if (!SvOK(sv))
1873 return 0;
f776e3cd 1874 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
79072805
LW
1875 if (sv == (SV*)gv)
1876 return 0;
1877 if (GvGP(sv))
88e89b8a 1878 gp_free((GV*)sv);
79072805 1879 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1880 return 0;
1881}
1882
1883int
864dbfa3 1884Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1885{
1886 STRLEN len;
35a4481c 1887 SV * const lsv = LvTARG(sv);
b83604b4 1888 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1889 I32 offs = LvTARGOFF(sv);
1890 I32 rem = LvTARGLEN(sv);
8772537c 1891 PERL_UNUSED_ARG(mg);
6ff81951 1892
9aa983d2
JH
1893 if (SvUTF8(lsv))
1894 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1895 if (offs > (I32)len)
6ff81951 1896 offs = len;
eb160463 1897 if (rem + offs > (I32)len)
6ff81951
GS
1898 rem = len - offs;
1899 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1900 if (SvUTF8(lsv))
2ef4b674 1901 SvUTF8_on(sv);
6ff81951
GS
1902 return 0;
1903}
1904
1905int
864dbfa3 1906Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1907{
97aff369 1908 dVAR;
9aa983d2 1909 STRLEN len;
b83604b4 1910 const char *tmps = SvPV_const(sv, len);
dd374669 1911 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1912 I32 lvoff = LvTARGOFF(sv);
1913 I32 lvlen = LvTARGLEN(sv);
8772537c 1914 PERL_UNUSED_ARG(mg);
075a4a2b 1915
1aa99e6b 1916 if (DO_UTF8(sv)) {
9aa983d2
JH
1917 sv_utf8_upgrade(lsv);
1918 sv_pos_u2b(lsv, &lvoff, &lvlen);
1919 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1920 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1921 SvUTF8_on(lsv);
1922 }
9bf12eaf 1923 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1924 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1925 LvTARGLEN(sv) = len;
e95af362 1926 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1927 sv_insert(lsv, lvoff, lvlen, tmps, len);
1928 Safefree(tmps);
1aa99e6b 1929 }
b76f3ce2
GB
1930 else {
1931 sv_insert(lsv, lvoff, lvlen, tmps, len);
1932 LvTARGLEN(sv) = len;
1933 }
1934
1aa99e6b 1935
79072805
LW
1936 return 0;
1937}
1938
1939int
864dbfa3 1940Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1941{
97aff369 1942 dVAR;
8772537c 1943 PERL_UNUSED_ARG(sv);
27cc343c 1944 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1945 return 0;
1946}
1947
1948int
864dbfa3 1949Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1950{
97aff369 1951 dVAR;
8772537c 1952 PERL_UNUSED_ARG(sv);
0a9c116b
DM
1953 /* update taint status unless we're restoring at scope exit */
1954 if (PL_localizing != 2) {
1955 if (PL_tainted)
1956 mg->mg_len |= 1;
1957 else
1958 mg->mg_len &= ~1;
1959 }
463ee0b2
LW
1960 return 0;
1961}
1962
1963int
864dbfa3 1964Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1965{
35a4481c 1966 SV * const lsv = LvTARG(sv);
8772537c 1967 PERL_UNUSED_ARG(mg);
6ff81951 1968
6136c704
AL
1969 if (lsv)
1970 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1971 else
0c34ef67 1972 SvOK_off(sv);
6ff81951 1973
6ff81951
GS
1974 return 0;
1975}
1976
1977int
864dbfa3 1978Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1979{
8772537c 1980 PERL_UNUSED_ARG(mg);
79072805
LW
1981 do_vecset(sv); /* XXX slurp this routine */
1982 return 0;
1983}
1984
1985int
864dbfa3 1986Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1987{
97aff369 1988 dVAR;
71be2cbc 1989 SV *targ = Nullsv;
5f05dabc 1990 if (LvTARGLEN(sv)) {
68dc0745 1991 if (mg->mg_obj) {
8772537c
AL
1992 SV * const ahv = LvTARG(sv);
1993 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
1994 if (he)
1995 targ = HeVAL(he);
68dc0745
PP
1996 }
1997 else {
8772537c 1998 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
1999 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2000 targ = AvARRAY(av)[LvTARGOFF(sv)];
2001 }
3280af22 2002 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
2003 /* somebody else defined it for us */
2004 SvREFCNT_dec(LvTARG(sv));
2005 LvTARG(sv) = SvREFCNT_inc(targ);
2006 LvTARGLEN(sv) = 0;
2007 SvREFCNT_dec(mg->mg_obj);
2008 mg->mg_obj = Nullsv;
2009 mg->mg_flags &= ~MGf_REFCOUNTED;
2010 }
5f05dabc 2011 }
71be2cbc
PP
2012 else
2013 targ = LvTARG(sv);
3280af22 2014 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2015 return 0;
2016}
2017
2018int
864dbfa3 2019Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2020{
8772537c 2021 PERL_UNUSED_ARG(mg);
71be2cbc 2022 if (LvTARGLEN(sv))
68dc0745
PP
2023 vivify_defelem(sv);
2024 if (LvTARG(sv)) {
5f05dabc 2025 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2026 SvSETMAGIC(LvTARG(sv));
2027 }
5f05dabc
PP
2028 return 0;
2029}
2030
71be2cbc 2031void
864dbfa3 2032Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2033{
97aff369 2034 dVAR;
74e13ce4
GS
2035 MAGIC *mg;
2036 SV *value = Nullsv;
71be2cbc 2037
14befaf4 2038 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2039 return;
68dc0745 2040 if (mg->mg_obj) {
8772537c
AL
2041 SV * const ahv = LvTARG(sv);
2042 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2043 if (he)
2044 value = HeVAL(he);
3280af22 2045 if (!value || value == &PL_sv_undef)
ce5030a2 2046 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2047 }
68dc0745 2048 else {
8772537c 2049 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2050 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
2051 LvTARG(sv) = Nullsv; /* array can't be extended */
2052 else {
aec46f14 2053 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2054 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2055 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2056 }
2057 }
3e3baf6d 2058 (void)SvREFCNT_inc(value);
68dc0745
PP
2059 SvREFCNT_dec(LvTARG(sv));
2060 LvTARG(sv) = value;
71be2cbc 2061 LvTARGLEN(sv) = 0;
68dc0745
PP
2062 SvREFCNT_dec(mg->mg_obj);
2063 mg->mg_obj = Nullsv;
2064 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2065}
2066
2067int
864dbfa3 2068Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2069{
86f55936 2070 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
810b8aa5
GS
2071}
2072
2073int
864dbfa3 2074Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2075{
565764a8 2076 mg->mg_len = -1;
c6496cc7 2077 SvSCREAM_off(sv);
93a17b20
LW
2078 return 0;
2079}
2080
2081int
864dbfa3 2082Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2083{
8772537c 2084 PERL_UNUSED_ARG(mg);
14befaf4 2085 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2086 SvVALID_off(sv);
2087 return 0;
2088}
2089
2090int
864dbfa3 2091Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2092{
8772537c 2093 PERL_UNUSED_ARG(mg);
14befaf4 2094 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2095 SvCOMPILED_off(sv);
2096 return 0;
2097}
2098
2099int
864dbfa3 2100Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2101{
35a4481c 2102 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2103
2104 if (uf && uf->uf_set)
24f81a43 2105 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2106 return 0;
2107}
2108
c277df42 2109int
faf82a0b
AE
2110Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2111{
8772537c 2112 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2113 sv_unmagic(sv, PERL_MAGIC_qr);
2114 return 0;
2115}
2116
2117int
864dbfa3 2118Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2119{
97aff369 2120 dVAR;
8772537c
AL
2121 regexp * const re = (regexp *)mg->mg_obj;
2122 PERL_UNUSED_ARG(sv);
2123
c277df42
IZ
2124 ReREFCNT_dec(re);
2125 return 0;
2126}
2127
7a4c00b4 2128#ifdef USE_LOCALE_COLLATE
79072805 2129int
864dbfa3 2130Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2131{
2132 /*
838b5b74 2133 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2134 * and vanished with a faint plop.
2135 */
8772537c 2136 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2137 if (mg->mg_ptr) {
2138 Safefree(mg->mg_ptr);
2139 mg->mg_ptr = NULL;
565764a8 2140 mg->mg_len = -1;
7a4c00b4 2141 }
bbce6d69
PP
2142 return 0;
2143}
7a4c00b4 2144#endif /* USE_LOCALE_COLLATE */
bbce6d69 2145
7e8c5dac
HS
2146/* Just clear the UTF-8 cache data. */
2147int
2148Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2149{
8772537c 2150 PERL_UNUSED_ARG(sv);
7e8c5dac
HS
2151 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2152 mg->mg_ptr = 0;
2153 mg->mg_len = -1; /* The mg_len holds the len cache. */
2154 return 0;
2155}
2156
bbce6d69 2157int
864dbfa3 2158Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2159{
97aff369 2160 dVAR;
e1ec3a88 2161 register const char *s;
79072805 2162 I32 i;
8990e307 2163 STRLEN len;
79072805 2164 switch (*mg->mg_ptr) {
748a9306 2165 case '\001': /* ^A */
3280af22 2166 sv_setsv(PL_bodytarget, sv);
748a9306 2167 break;
49460fe6 2168 case '\003': /* ^C */
eb160463 2169 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2170 break;
2171
79072805 2172 case '\004': /* ^D */
b4ab917c 2173#ifdef DEBUGGING
b83604b4 2174 s = SvPV_nolen_const(sv);
ddcf8bc1 2175 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2176 DEBUG_x(dump_all());
b4ab917c
DM
2177#else
2178 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2179#endif
79072805 2180 break;
28f23441 2181 case '\005': /* ^E */
d0063567 2182 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2183#ifdef MACOS_TRADITIONAL
d0063567 2184 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2185#else
cd39f2b6 2186# ifdef VMS
d0063567 2187 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2188# else
cd39f2b6 2189# ifdef WIN32
d0063567 2190 SetLastError( SvIV(sv) );
cd39f2b6 2191# else
9fed8b87 2192# ifdef OS2
d0063567 2193 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2194# else
d0063567
DK
2195 /* will anyone ever use this? */
2196 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2197# endif
048c1ddf
IZ
2198# endif
2199# endif
22fae026 2200#endif
d0063567
DK
2201 }
2202 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2203 if (PL_encoding)
2204 SvREFCNT_dec(PL_encoding);
2205 if (SvOK(sv) || SvGMAGICAL(sv)) {
2206 PL_encoding = newSVsv(sv);
2207 }
2208 else {
2209 PL_encoding = Nullsv;
2210 }
2211 }
2212 break;
79072805 2213 case '\006': /* ^F */
3280af22 2214 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2215 break;
a0d0e21e 2216 case '\010': /* ^H */
3280af22 2217 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2218 break;
9d116dd7 2219 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d
NC
2220 Safefree(PL_inplace);
2221 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
da78da6e 2222 break;
28f23441 2223 case '\017': /* ^O */
ac27b0f5 2224 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d
NC
2225 Safefree(PL_osname);
2226 PL_osname = Nullch;
3511154c
DM
2227 if (SvOK(sv)) {
2228 TAINT_PROPER("assigning to $^O");
2e0de35c 2229 PL_osname = savesvpv(sv);
3511154c 2230 }
ac27b0f5
NIS
2231 }
2232 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2233 if (!PL_compiling.cop_io)
2234 PL_compiling.cop_io = newSVsv(sv);
2235 else
2236 sv_setsv(PL_compiling.cop_io,sv);
2237 }
28f23441 2238 break;
79072805 2239 case '\020': /* ^P */
3280af22 2240 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2241 if (PL_perldb && !PL_DBsingle)
1ee4443e 2242 init_debugger();
79072805
LW
2243 break;
2244 case '\024': /* ^T */
88e89b8a 2245#ifdef BIG_TIME
6b88bc9c 2246 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2247#else
3280af22 2248 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2249#endif
79072805 2250 break;
fde18df1 2251 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2252 if (*(mg->mg_ptr+1) == '\0') {
2253 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2254 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2255 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2256 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2257 }
599cee73 2258 }
0a378802 2259 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2260 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2261 if (!SvPOK(sv) && PL_localizing) {
2262 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2263 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2264 break;
2265 }
f4fc7782 2266 {
b5477537 2267 STRLEN len, i;
d3a7d8c7 2268 int accumulate = 0 ;
f4fc7782 2269 int any_fatals = 0 ;
b83604b4 2270 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2271 for (i = 0 ; i < len ; ++i) {
2272 accumulate |= ptr[i] ;
2273 any_fatals |= (ptr[i] & 0xAA) ;
2274 }
d3a7d8c7
GS
2275 if (!accumulate)
2276 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2277 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2278 PL_compiling.cop_warnings = pWARN_ALL;
2279 PL_dowarn |= G_WARN_ONCE ;
727405f8 2280 }
d3a7d8c7
GS
2281 else {
2282 if (specialWARN(PL_compiling.cop_warnings))
2283 PL_compiling.cop_warnings = newSVsv(sv) ;
2284 else
2285 sv_setsv(PL_compiling.cop_warnings, sv);
2286 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2287 PL_dowarn |= G_WARN_ONCE ;
2288 }
f4fc7782 2289
d3a7d8c7 2290 }
4438c4b7 2291 }
971a9dd3 2292 }
79072805
LW
2293 break;
2294 case '.':
3280af22
NIS
2295 if (PL_localizing) {
2296 if (PL_localizing == 1)
7766f137 2297 SAVESPTR(PL_last_in_gv);
748a9306 2298 }
3280af22 2299 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2300 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2301 break;
2302 case '^':
3280af22 2303 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2304 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2305 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2306 break;
2307 case '~':
3280af22 2308 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2309 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2310 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2311 break;
2312 case '=':
632db599 2313 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2314 break;
2315 case '-':
632db599 2316 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2317 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2318 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2319 break;
2320 case '%':
632db599 2321 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2322 break;
2323 case '|':
4b65379b 2324 {
8772537c 2325 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2326 if(!io)
2327 break;
4b65379b
CS
2328 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2329 IoFLAGS(io) &= ~IOf_FLUSH;
2330 else {
2331 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2332 PerlIO *ofp = IoOFP(io);
2333 if (ofp)
2334 (void)PerlIO_flush(ofp);
2335 IoFLAGS(io) |= IOf_FLUSH;
2336 }
2337 }
79072805
LW
2338 }
2339 break;
79072805 2340 case '/':
3280af22 2341 SvREFCNT_dec(PL_rs);
8bfdd7d9 2342 PL_rs = newSVsv(sv);
79072805
LW
2343 break;
2344 case '\\':
7889fe52
NIS
2345 if (PL_ors_sv)
2346 SvREFCNT_dec(PL_ors_sv);
009c130f 2347 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2348 PL_ors_sv = newSVsv(sv);
009c130f 2349 }
e3c19b7b 2350 else {
7889fe52 2351 PL_ors_sv = Nullsv;
e3c19b7b 2352 }
79072805
LW
2353 break;
2354 case ',':
7889fe52
NIS
2355 if (PL_ofs_sv)
2356 SvREFCNT_dec(PL_ofs_sv);
2357 if (SvOK(sv) || SvGMAGICAL(sv)) {
2358 PL_ofs_sv = newSVsv(sv);
2359 }
2360 else {
2361 PL_ofs_sv = Nullsv;
2362 }
79072805 2363 break;
79072805 2364 case '[':
3280af22 2365 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2366 break;
2367 case '?':
ff0cee69 2368#ifdef COMPLEX_STATUS
6b88bc9c
GS
2369 if (PL_localizing == 2) {
2370 PL_statusvalue = LvTARGOFF(sv);
2371 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2372 }
2373 else
2374#endif
2375#ifdef VMSISH_STATUS
2376 if (VMSISH_STATUS)
fb38d079 2377 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2378 else
2379#endif
fb38d079 2380 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2381 break;
2382 case '!':
93189314
JH
2383 {
2384#ifdef VMS
2385# define PERL_VMS_BANG vaxc$errno
2386#else
2387# define PERL_VMS_BANG 0
2388#endif
91487cfc 2389 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2390 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2391 }
79072805
LW
2392 break;
2393 case '<':
3280af22
NIS
2394 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2395 if (PL_delaymagic) {
2396 PL_delaymagic |= DM_RUID;
79072805
LW
2397 break; /* don't do magic till later */
2398 }
2399#ifdef HAS_SETRUID
b28d0864 2400 (void)setruid((Uid_t)PL_uid);
79072805
LW
2401#else
2402#ifdef HAS_SETREUID
3280af22 2403 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2404#else
85e6fe83 2405#ifdef HAS_SETRESUID
b28d0864 2406 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2407#else
75870ed3 2408 if (PL_uid == PL_euid) { /* special case $< = $> */
2409#ifdef PERL_DARWIN
2410 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2411 if (PL_uid != 0 && PerlProc_getuid() == 0)
2412 (void)PerlProc_setuid(0);
2413#endif
b28d0864 2414 (void)PerlProc_setuid(PL_uid);
75870ed3 2415 } else {
d8eceb89 2416 PL_uid = PerlProc_getuid();
cea2e8a9 2417 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2418 }
79072805
LW
2419#endif
2420#endif
85e6fe83 2421#endif
d8eceb89 2422 PL_uid = PerlProc_getuid();
3280af22 2423 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2424 break;
2425 case '>':
3280af22
NIS
2426 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2427 if (PL_delaymagic) {
2428 PL_delaymagic |= DM_EUID;
79072805
LW
2429 break; /* don't do magic till later */
2430 }
2431#ifdef HAS_SETEUID
3280af22 2432 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2433#else
2434#ifdef HAS_SETREUID
b28d0864 2435 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2436#else
2437#ifdef HAS_SETRESUID
6b88bc9c 2438 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2439#else
b28d0864
NIS
2440 if (PL_euid == PL_uid) /* special case $> = $< */
2441 PerlProc_setuid(PL_euid);
a0d0e21e 2442 else {
e8ee3774 2443 PL_euid = PerlProc_geteuid();
cea2e8a9 2444 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2445 }
79072805
LW
2446#endif
2447#endif
85e6fe83 2448#endif
d8eceb89 2449 PL_euid = PerlProc_geteuid();
3280af22 2450 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2451 break;
2452 case '(':
3280af22
NIS
2453 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2454 if (PL_delaymagic) {
2455 PL_delaymagic |= DM_RGID;
79072805
LW
2456 break; /* don't do magic till later */
2457 }
2458#ifdef HAS_SETRGID
b28d0864 2459 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2460#else
2461#ifdef HAS_SETREGID
3280af22 2462 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2463#else
2464#ifdef HAS_SETRESGID
b28d0864 2465 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2466#else
b28d0864
NIS
2467 if (PL_gid == PL_egid) /* special case $( = $) */
2468 (void)PerlProc_setgid(PL_gid);
748a9306 2469 else {
d8eceb89 2470 PL_gid = PerlProc_getgid();
cea2e8a9 2471 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2472 }
79072805
LW
2473#endif
2474#endif
85e6fe83 2475#endif
d8eceb89 2476 PL_gid = PerlProc_getgid();
3280af22 2477 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2478 break;
2479 case ')':
5cd24f17
PP
2480#ifdef HAS_SETGROUPS
2481 {
b83604b4 2482 const char *p = SvPV_const(sv, len);
757f63d8
SP
2483 Groups_t *gary = NULL;
2484
2485 while (isSPACE(*p))
2486 ++p;
2487 PL_egid = Atol(p);
2488 for (i = 0; i < NGROUPS; ++i) {
2489 while (*p && !isSPACE(*p))
2490 ++p;
2491 while (isSPACE(*p))
2492 ++p;
2493 if (!*p)
2494 break;
2495 if(!gary)
2496 Newx(gary, i + 1, Groups_t);
2497 else
2498 Renew(gary, i + 1, Groups_t);
2499 gary[i] = Atol(p);
2500 }
2501 if (i)
2502 (void)setgroups(i, gary);
2503 if (gary)
2504 Safefree(gary);
5cd24f17
PP
2505 }
2506#else /* HAS_SETGROUPS */
b28d0864 2507 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2508#endif /* HAS_SETGROUPS */
3280af22
NIS
2509 if (PL_delaymagic) {
2510 PL_delaymagic |= DM_EGID;
79072805
LW
2511 break; /* don't do magic till later */
2512 }
2513#ifdef HAS_SETEGID
3280af22 2514 (void)setegid((Gid_t)PL_egid);
79072805
LW
2515#else
2516#ifdef HAS_SETREGID
b28d0864 2517 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2518#else
2519#ifdef HAS_SETRESGID
b28d0864 2520 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2521#else
b28d0864
NIS
2522 if (PL_egid == PL_gid) /* special case $) = $( */
2523 (void)PerlProc_setgid(PL_egid);
748a9306 2524 else {
d8eceb89 2525 PL_egid = PerlProc_getegid();
cea2e8a9 2526 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2527 }
79072805
LW
2528#endif
2529#endif
85e6fe83 2530#endif
d8eceb89 2531 PL_egid = PerlProc_getegid();
3280af22 2532 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2533 break;
2534 case ':':
2d8e6c8d 2535 PL_chopset = SvPV_force(sv,len);
79072805 2536 break;
cd39f2b6 2537#ifndef MACOS_TRADITIONAL
79072805 2538 case '0':
e2975953 2539 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2540#ifdef HAS_SETPROCTITLE
2541 /* The BSDs don't show the argv[] in ps(1) output, they
2542 * show a string from the process struct and provide
2543 * the setproctitle() routine to manipulate that. */
a2722ac9 2544 if (PL_origalen != 1) {
b83604b4 2545 s = SvPV_const(sv, len);
98b76f99 2546# if __FreeBSD_version > 410001
9aad2c0e 2547 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2548 * but not the "(perl) suffix from the ps(1)
2549 * output, because that's what ps(1) shows if the
2550 * argv[] is modified. */
6f2ad931 2551 setproctitle("-%s", s);
9aad2c0e 2552# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2553 /* This doesn't really work if you assume that
2554 * $0 = 'foobar'; will wipe out 'perl' from the $0
2555 * because in ps(1) output the result will be like
2556 * sprintf("perl: %s (perl)", s)
2557 * I guess this is a security feature:
2558 * one (a user process) cannot get rid of the original name.
2559 * --jhi */
2560 setproctitle("%s", s);
2561# endif
2562 }
2563#endif
17aa7f3d 2564#if defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2565 if (PL_origalen != 1) {
17aa7f3d 2566 union pstun un;
b83604b4 2567 s = SvPV_const(sv, len);
6867be6d 2568 un.pst_command = (char *)s;
17aa7f3d
JH
2569 pstat(PSTAT_SETCMD, un, len, 0, 0);
2570 }
2571#endif
2d2af554
GA
2572 if (PL_origalen > 1) {
2573 /* PL_origalen is set in perl_parse(). */
2574 s = SvPV_force(sv,len);
2575 if (len >= (STRLEN)PL_origalen-1) {
2576 /* Longer than original, will be truncated. We assume that
2577 * PL_origalen bytes are available. */
2578 Copy(s, PL_origargv[0], PL_origalen-1, char);
2579 }
2580 else {
2581 /* Shorter than original, will be padded. */
2582 Copy(s, PL_origargv[0], len, char);
2583 PL_origargv[0][len] = 0;
2584 memset(PL_origargv[0] + len + 1,
2585 /* Is the space counterintuitive? Yes.
2586 * (You were expecting \0?)
2587 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2588 * --jhi */
2589 (int)' ',
2590 PL_origalen - len - 1);
2591 }
2592 PL_origargv[0][PL_origalen-1] = 0;
2593 for (i = 1; i < PL_origargc; i++)
2594 PL_origargv[i] = 0;
79072805 2595 }
e2975953 2596 UNLOCK_DOLLARZERO_MUTEX;
79072805 2597 break;
cd39f2b6 2598#endif
79072805
LW
2599 }
2600 return 0;
2601}
2602
2603I32
35a4481c 2604Perl_whichsig(pTHX_ const char *sig)
79072805 2605{
aadb217d 2606 register char* const* sigv;
79072805 2607
aadb217d 2608 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2609 if (strEQ(sig,*sigv))
aadb217d 2610 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2611#ifdef SIGCLD
2612 if (strEQ(sig,"CHLD"))
2613 return SIGCLD;
2614#endif
2615#ifdef SIGCHLD
2616 if (strEQ(sig,"CLD"))
2617 return SIGCHLD;
2618#endif
7f1236c0 2619 return -1;
79072805
LW
2620}
2621
ecfc5424 2622Signal_t
1e82f5a6 2623#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2624Perl_sighandler(int sig, ...)
1e82f5a6
SH
2625#else
2626Perl_sighandler(int sig)
2627#endif
79072805 2628{
1018e26f
NIS
2629#ifdef PERL_GET_SIG_CONTEXT
2630 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2631#else
cea2e8a9 2632 dTHX;
71d280e3 2633#endif
79072805 2634 dSP;
00d579c5 2635 GV *gv = Nullgv;
8772537c
AL
2636 SV *sv = Nullsv;
2637 SV * const tSv = PL_Sv;
00d579c5 2638 CV *cv = Nullcv;
533c011a 2639 OP *myop = PL_op;
84902520 2640 U32 flags = 0;
8772537c 2641 XPV * const tXpv = PL_Xpv;
71d280e3 2642
3280af22 2643 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2644 flags |= 1;
3280af22 2645 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2646 flags |= 4;
3280af22 2647 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2648 flags |= 16;
2649
727405f8 2650 if (!PL_psig_ptr[sig]) {
99ef548b 2651 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2652 PL_sig_name[sig]);
2653 exit(sig);
2654 }
ff0cee69 2655
84902520
TB
2656 /* Max number of items pushed there is 3*n or 4. We cannot fix
2657 infinity, so we fix 4 (in fact 5): */
2658 if (flags & 1) {
3280af22 2659 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2660 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2661 }
ac27b0f5 2662 if (flags & 4)
3280af22 2663 PL_markstack_ptr++; /* Protect mark. */
84902520 2664 if (flags & 16)
3280af22 2665 PL_scopestack_ix += 1;
84902520 2666 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2667 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2668 || SvTYPE(cv) != SVt_PVCV) {
2669 HV *st;
f2c0649b 2670 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 2671 }
84902520 2672
a0d0e21e 2673 if (!cv || !CvROOT(cv)) {
599cee73 2674 if (ckWARN(WARN_SIGNAL))
9014280d 2675 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2676 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2677 : ((cv && CvGV(cv))
2678 ? GvENAME(CvGV(cv))
2679 : "__ANON__")));
2680 goto cleanup;
79072805
LW
2681 }
2682
22c35a8c
GS
2683 if(PL_psig_name[sig]) {
2684 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2685 flags |= 64;
df3728a2 2686#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2687 PL_sig_sv = sv;
df3728a2 2688#endif
84902520 2689 } else {
ff0cee69 2690 sv = sv_newmortal();
22c35a8c 2691 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2692 }
e336de0d 2693
e788e7d3 2694 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2695 PUSHMARK(SP);
79072805 2696 PUSHs(sv);
8aad04aa
JH
2697#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2698 {
2699 struct sigaction oact;
2700
2701 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2702 siginfo_t *sip;
2703 va_list args;
2704
2705 va_start(args, sig);
2706 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2707 if (sip) {
2708 HV *sih = newHV();
2709 SV *rv = newRV_noinc((SV*)sih);
2710 /* The siginfo fields signo, code, errno, pid, uid,
2711 * addr, status, and band are defined by POSIX/SUSv3. */
2712 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2713 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2714#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
ea1bde16 2715 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2716 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2717 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2718 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2719 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2720 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2721#endif
8aad04aa
JH
2722 EXTEND(SP, 2);
2723 PUSHs((SV*)rv);
2724 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2725 }
b4552a27 2726
31427afe 2727 va_end(args);
8aad04aa
JH
2728 }
2729 }
2730#endif
79072805 2731 PUTBACK;
a0d0e21e 2732
1b266415 2733 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2734
d3acc0f7 2735 POPSTACK;
1b266415 2736 if (SvTRUE(ERRSV)) {
1d615522 2737#ifndef PERL_MICRO
983dbef6 2738#ifdef HAS_SIGPROCMASK
1b266415
NIS
2739 /* Handler "died", for example to get out of a restart-able read().
2740 * Before we re-do that on its behalf re-enable the signal which was
2741 * blocked by the system when we entered.
2742 */
2743 sigset_t set;
2744 sigemptyset(&set);
2745 sigaddset(&set,sig);
2746 sigprocmask(SIG_UNBLOCK, &set, NULL);
2747#else
2748 /* Not clear if this will work */
2749 (void)rsignal(sig, SIG_IGN);
5c1546dc 2750 (void)rsignal(sig, PL_csighandlerp);
1b266415 2751#endif
1d615522 2752#endif /* !PERL_MICRO */
c3bdd826 2753 Perl_die(aTHX_ Nullch);
1b266415 2754 }
00d579c5 2755cleanup:
84902520 2756 if (flags & 1)
3280af22 2757 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2758 if (flags & 4)
3280af22 2759 PL_markstack_ptr--;
84902520 2760 if (flags & 16)
3280af22 2761 PL_scopestack_ix -= 1;
84902520
TB
2762 if (flags & 64)
2763 SvREFCNT_dec(sv);
533c011a 2764 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2765
3280af22
NIS
2766 PL_Sv = tSv; /* Restore global temporaries. */
2767 PL_Xpv = tXpv;
53bb94e2 2768 return;
79072805 2769}
4e35701f
NIS
2770
2771
51371543 2772static void
8772537c 2773S_restore_magic(pTHX_ const void *p)
51371543 2774{
97aff369 2775 dVAR;
8772537c
AL
2776 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2777 SV* const sv = mgs->mgs_sv;
51371543
GS
2778
2779 if (!sv)
2780 return;
2781
2782 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2783 {
f8c7b90f 2784#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2785 /* While magic was saved (and off) sv_setsv may well have seen
2786 this SV as a prime candidate for COW. */
2787 if (SvIsCOW(sv))
e424a81e 2788 sv_force_normal_flags(sv, 0);
f9701176
NC
2789#endif
2790
51371543
GS
2791 if (mgs->mgs_flags)
2792 SvFLAGS(sv) |= mgs->mgs_flags;
2793 else
2794 mg_magical(sv);
2b77b520
YST
2795 if (SvGMAGICAL(sv)) {
2796 /* downgrade public flags to private,
2797 and discard any other private flags */
2798
2799 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2800 if (public) {
2801 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2802 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2803 }
2804 }
51371543
GS
2805 }
2806
2807 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2808
2809 /* If we're still on top of the stack, pop us off. (That condition
2810 * will be satisfied if restore_magic was called explicitly, but *not*
2811 * if it's being called via leave_scope.)
2812 * The reason for doing this is that otherwise, things like sv_2cv()
2813 * may leave alloc gunk on the savestack, and some code
2814 * (e.g. sighandler) doesn't expect that...
2815 */
2816 if (PL_savestack_ix == mgs->mgs_ss_ix)
2817 {
2818 I32 popval = SSPOPINT;
c76ac1ee 2819 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2820 PL_savestack_ix -= 2;
2821 popval = SSPOPINT;
2822 assert(popval == SAVEt_ALLOC);
2823 popval = SSPOPINT;
2824 PL_savestack_ix -= popval;
2825 }
2826
2827}
2828
2829static void
8772537c 2830S_unwind_handler_stack(pTHX_ const void *p)
51371543 2831{
27da23d5 2832 dVAR;
e1ec3a88 2833 const U32 flags = *(const U32*)p;
51371543
GS
2834
2835 if (flags & 1)
2836 PL_savestack_ix -= 5; /* Unprotect save in progress. */
df3728a2 2837#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2838 if (flags & 64)
27da23d5 2839 SvREFCNT_dec(PL_sig_sv);
df3728a2 2840#endif
51371543 2841}
1018e26f 2842
66610fdd
RGS
2843/*
2844 * Local variables:
2845 * c-indentation-style: bsd
2846 * c-basic-offset: 4
2847 * indent-tabs-mode: t
2848 * End:
2849 *
37442d52
RGS
2850 * ex: set ts=8 sts=4 sw=4 noet:
2851 */