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