3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
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.
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."
17 =head1 Magical Functions
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,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
56 Signal_t Perl_csighandler(int sig, ...);
58 Signal_t Perl_csighandler(int sig);
62 /* Missing protos on LynxOS */
63 void setruid(uid_t id);
64 void seteuid(uid_t id);
65 void setrgid(uid_t id);
66 void setegid(uid_t id);
70 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
78 /* MGS is typedef'ed to struct magic_state in perl.h */
81 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
84 assert(SvMAGICAL(sv));
85 #ifdef PERL_OLD_COPY_ON_WRITE
86 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
88 sv_force_normal_flags(sv, 0);
91 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
93 mgs = SSPTR(mgs_ix, MGS*);
95 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
96 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
100 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
104 =for apidoc mg_magical
106 Turns on the magical status of an SV. See C<sv_magic>.
112 Perl_mg_magical(pTHX_ SV *sv)
115 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
116 const MGVTBL* const vtbl = mg->mg_virtual;
118 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
122 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
131 Do magic after a value is retrieved from the SV. See C<sv_magic>.
137 Perl_mg_get(pTHX_ SV *sv)
139 const I32 mgs_ix = SSNEW(sizeof(MGS));
140 const bool was_temp = (bool)SvTEMP(sv);
142 MAGIC *newmg, *head, *cur, *mg;
143 /* guard against sv having being freed midway by holding a private
146 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
147 cause the SV's buffer to get stolen (and maybe other stuff).
150 sv_2mortal(SvREFCNT_inc(sv));
155 save_magic(mgs_ix, sv);
157 /* We must call svt_get(sv, mg) for each valid entry in the linked
158 list of magic. svt_get() may delete the current entry, add new
159 magic to the head of the list, or upgrade the SV. AMS 20010810 */
161 newmg = cur = head = mg = SvMAGIC(sv);
163 const MGVTBL * const vtbl = mg->mg_virtual;
165 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
166 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
168 /* guard against magic having been deleted - eg FETCH calling
173 /* Don't restore the flags for this entry if it was deleted. */
174 if (mg->mg_flags & MGf_GSKIP)
175 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
178 mg = mg->mg_moremagic;
181 /* Have we finished with the new entries we saw? Start again
182 where we left off (unless there are more new entries). */
190 /* Were any new entries added? */
191 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
198 restore_magic(INT2PTR(void *, (IV)mgs_ix));
200 if (SvREFCNT(sv) == 1) {
201 /* We hold the last reference to this SV, which implies that the
202 SV was deleted as a side effect of the routines we called. */
211 Do magic after a value is assigned to the SV. See C<sv_magic>.
217 Perl_mg_set(pTHX_ SV *sv)
219 const I32 mgs_ix = SSNEW(sizeof(MGS));
223 save_magic(mgs_ix, sv);
225 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
226 const MGVTBL* vtbl = mg->mg_virtual;
227 nextmg = mg->mg_moremagic; /* it may delete itself */
228 if (mg->mg_flags & MGf_GSKIP) {
229 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
230 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
232 if (vtbl && vtbl->svt_set)
233 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
236 restore_magic(INT2PTR(void*, (IV)mgs_ix));
241 =for apidoc mg_length
243 Report on the SV's length. See C<sv_magic>.
249 Perl_mg_length(pTHX_ SV *sv)
254 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
255 const MGVTBL * const vtbl = mg->mg_virtual;
256 if (vtbl && vtbl->svt_len) {
257 const I32 mgs_ix = SSNEW(sizeof(MGS));
258 save_magic(mgs_ix, sv);
259 /* omit MGf_GSKIP -- not changed here */
260 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
261 restore_magic(INT2PTR(void*, (IV)mgs_ix));
267 const U8 *s = (U8*)SvPV_const(sv, len);
268 len = Perl_utf8_length(aTHX_ s, s + len);
271 (void)SvPV_const(sv, len);
276 Perl_mg_size(pTHX_ SV *sv)
280 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
281 const MGVTBL* const vtbl = mg->mg_virtual;
282 if (vtbl && vtbl->svt_len) {
283 const I32 mgs_ix = SSNEW(sizeof(MGS));
285 save_magic(mgs_ix, sv);
286 /* omit MGf_GSKIP -- not changed here */
287 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
288 restore_magic(INT2PTR(void*, (IV)mgs_ix));
295 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
299 Perl_croak(aTHX_ "Size magic not implemented");
308 Clear something magical that the SV represents. See C<sv_magic>.
314 Perl_mg_clear(pTHX_ SV *sv)
316 const I32 mgs_ix = SSNEW(sizeof(MGS));
319 save_magic(mgs_ix, sv);
321 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
322 const MGVTBL* const vtbl = mg->mg_virtual;
323 /* omit GSKIP -- never set here */
325 if (vtbl && vtbl->svt_clear)
326 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
329 restore_magic(INT2PTR(void*, (IV)mgs_ix));
336 Finds the magic pointer for type matching the SV. See C<sv_magic>.
342 Perl_mg_find(pTHX_ const SV *sv, int type)
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 if (mg->mg_type == type)
357 Copies the magic from one SV to another. See C<sv_magic>.
363 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
367 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
368 const MGVTBL* const vtbl = mg->mg_virtual;
369 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
370 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
373 const char type = mg->mg_type;
376 (type == PERL_MAGIC_tied)
378 : (type == PERL_MAGIC_regdata && mg->mg_obj)
381 toLOWER(type), key, klen);
390 =for apidoc mg_localize
392 Copy some of the magic from an existing SV to new localized version of
393 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
394 doesn't (eg taint, pos).
400 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
403 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
404 const MGVTBL* const vtbl = mg->mg_virtual;
405 switch (mg->mg_type) {
406 /* value magic types: don't copy */
409 case PERL_MAGIC_regex_global:
410 case PERL_MAGIC_nkeys:
411 #ifdef USE_LOCALE_COLLATE
412 case PERL_MAGIC_collxfrm:
415 case PERL_MAGIC_taint:
417 case PERL_MAGIC_vstring:
418 case PERL_MAGIC_utf8:
419 case PERL_MAGIC_substr:
420 case PERL_MAGIC_defelem:
421 case PERL_MAGIC_arylen:
423 case PERL_MAGIC_backref:
424 case PERL_MAGIC_arylen_p:
425 case PERL_MAGIC_rhash:
426 case PERL_MAGIC_symtab:
430 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
431 /* XXX calling the copy method is probably not correct. DAPM */
432 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
433 mg->mg_ptr, mg->mg_len);
436 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
437 mg->mg_ptr, mg->mg_len);
439 /* container types should remain read-only across localization */
440 SvFLAGS(nsv) |= SvREADONLY(sv);
443 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
444 SvFLAGS(nsv) |= SvMAGICAL(sv);
454 Free any magic storage used by the SV. See C<sv_magic>.
460 Perl_mg_free(pTHX_ SV *sv)
464 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
465 const MGVTBL* const vtbl = mg->mg_virtual;
466 moremagic = mg->mg_moremagic;
467 if (vtbl && vtbl->svt_free)
468 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
469 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
470 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
471 Safefree(mg->mg_ptr);
472 else if (mg->mg_len == HEf_SVKEY)
473 SvREFCNT_dec((SV*)mg->mg_ptr);
475 if (mg->mg_flags & MGf_REFCOUNTED)
476 SvREFCNT_dec(mg->mg_obj);
479 SvMAGIC_set(sv, NULL);
486 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
488 register const REGEXP *rx;
491 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
492 if (mg->mg_obj) /* @+ */
495 return rx->lastparen;
502 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
506 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
507 register const I32 paren = mg->mg_len;
512 if (paren <= (I32)rx->nparens &&
513 (s = rx->startp[paren]) != -1 &&
514 (t = rx->endp[paren]) != -1)
517 if (mg->mg_obj) /* @+ */
522 if (i > 0 && RX_MATCH_UTF8(rx)) {
523 const char * const b = rx->subbeg;
525 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
535 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
537 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
538 Perl_croak(aTHX_ PL_no_modify);
539 NORETURN_FUNCTION_END;
543 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
547 register const REGEXP *rx;
550 switch (*mg->mg_ptr) {
551 case '1': case '2': case '3': case '4':
552 case '5': case '6': case '7': case '8': case '9': case '&':
553 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
555 paren = atoi(mg->mg_ptr); /* $& is in [0] */
557 if (paren <= (I32)rx->nparens &&
558 (s1 = rx->startp[paren]) != -1 &&
559 (t1 = rx->endp[paren]) != -1)
563 if (i > 0 && RX_MATCH_UTF8(rx)) {
564 const char * const s = rx->subbeg + s1;
569 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
573 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
577 if (ckWARN(WARN_UNINITIALIZED))
582 if (ckWARN(WARN_UNINITIALIZED))
587 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
588 paren = rx->lastparen;
593 case '\016': /* ^N */
594 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
595 paren = rx->lastcloseparen;
601 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
602 if (rx->startp[0] != -1) {
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->endp[0] != -1) {
615 i = rx->sublen - rx->endp[0];
626 if (!SvPOK(sv) && SvNIOK(sv)) {
634 #define SvRTRIM(sv) STMT_START { \
635 STRLEN len = SvCUR(sv); \
636 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
638 SvCUR_set(sv, len); \
642 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
646 register char *s = NULL;
649 const char * const remaining = mg->mg_ptr + 1;
650 const char nextchar = *remaining;
652 switch (*mg->mg_ptr) {
653 case '\001': /* ^A */
654 sv_setsv(sv, PL_bodytarget);
656 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
657 if (nextchar == '\0') {
658 sv_setiv(sv, (IV)PL_minus_c);
660 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
661 sv_setiv(sv, (IV)STATUS_NATIVE);
665 case '\004': /* ^D */
666 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
668 case '\005': /* ^E */
669 if (nextchar == '\0') {
670 #ifdef MACOS_TRADITIONAL
674 sv_setnv(sv,(double)gMacPerl_OSErr);
675 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
680 # include <descrip.h>
681 # include <starlet.h>
683 $DESCRIPTOR(msgdsc,msg);
684 sv_setnv(sv,(NV) vaxc$errno);
685 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
686 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
692 if (!(_emx_env & 0x200)) { /* Under DOS */
693 sv_setnv(sv, (NV)errno);
694 sv_setpv(sv, errno ? Strerror(errno) : "");
696 if (errno != errno_isOS2) {
697 const int tmp = _syserrno();
698 if (tmp) /* 2nd call to _syserrno() makes it 0 */
701 sv_setnv(sv, (NV)Perl_rc);
702 sv_setpv(sv, os2error(Perl_rc));
707 DWORD dwErr = GetLastError();
708 sv_setnv(sv, (NV)dwErr);
710 PerlProc_GetOSError(sv, dwErr);
713 sv_setpvn(sv, "", 0);
718 const int saveerrno = errno;
719 sv_setnv(sv, (NV)errno);
720 sv_setpv(sv, errno ? Strerror(errno) : "");
728 SvNOK_on(sv); /* what a wonderful hack! */
730 else if (strEQ(remaining, "NCODING"))
731 sv_setsv(sv, PL_encoding);
733 case '\006': /* ^F */
734 sv_setiv(sv, (IV)PL_maxsysfd);
736 case '\010': /* ^H */
737 sv_setiv(sv, (IV)PL_hints);
739 case '\011': /* ^I */ /* NOT \t in EBCDIC */
741 sv_setpv(sv, PL_inplace);
743 sv_setsv(sv, &PL_sv_undef);
745 case '\017': /* ^O & ^OPEN */
746 if (nextchar == '\0') {
747 sv_setpv(sv, PL_osname);
750 else if (strEQ(remaining, "PEN")) {
751 if (!PL_compiling.cop_io)
752 sv_setsv(sv, &PL_sv_undef);
754 sv_setsv(sv, PL_compiling.cop_io);
758 case '\020': /* ^P */
759 sv_setiv(sv, (IV)PL_perldb);
761 case '\023': /* ^S */
762 if (nextchar == '\0') {
763 if (PL_lex_state != LEX_NOTPARSING)
766 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
771 case '\024': /* ^T */
772 if (nextchar == '\0') {
774 sv_setnv(sv, PL_basetime);
776 sv_setiv(sv, (IV)PL_basetime);
779 else if (strEQ(remaining, "AINT"))
780 sv_setiv(sv, PL_tainting
781 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
784 case '\025': /* $^UNICODE, $^UTF8LOCALE */
785 if (strEQ(remaining, "NICODE"))
786 sv_setuv(sv, (UV) PL_unicode);
787 else if (strEQ(remaining, "TF8LOCALE"))
788 sv_setuv(sv, (UV) PL_utf8locale);
790 case '\027': /* ^W & $^WARNING_BITS */
791 if (nextchar == '\0')
792 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
793 else if (strEQ(remaining, "ARNING_BITS")) {
794 if (PL_compiling.cop_warnings == pWARN_NONE) {
795 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
797 else if (PL_compiling.cop_warnings == pWARN_STD) {
800 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
804 else if (PL_compiling.cop_warnings == pWARN_ALL) {
805 /* Get the bit mask for $warnings::Bits{all}, because
806 * it could have been extended by warnings::register */
808 HV * const bits=get_hv("warnings::Bits", FALSE);
809 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
810 sv_setsv(sv, *bits_all);
813 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
817 sv_setsv(sv, PL_compiling.cop_warnings);
822 case '1': case '2': case '3': case '4':
823 case '5': case '6': case '7': case '8': case '9': case '&':
824 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
828 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
829 * XXX Does the new way break anything?
831 paren = atoi(mg->mg_ptr); /* $& is in [0] */
833 if (paren <= (I32)rx->nparens &&
834 (s1 = rx->startp[paren]) != -1 &&
835 (t1 = rx->endp[paren]) != -1)
844 int oldtainted = PL_tainted;
847 PL_tainted = oldtainted;
848 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
853 if (RX_MATCH_TAINTED(rx)) {
854 MAGIC* const mg = SvMAGIC(sv);
857 SvMAGIC_set(sv, mg->mg_moremagic);
859 if ((mgt = SvMAGIC(sv))) {
860 mg->mg_moremagic = mgt;
870 sv_setsv(sv,&PL_sv_undef);
873 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
874 paren = rx->lastparen;
878 sv_setsv(sv,&PL_sv_undef);
880 case '\016': /* ^N */
881 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
882 paren = rx->lastcloseparen;
886 sv_setsv(sv,&PL_sv_undef);
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 if ((s = rx->subbeg) && rx->startp[0] != -1) {
895 sv_setsv(sv,&PL_sv_undef);
898 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
899 if (rx->subbeg && rx->endp[0] != -1) {
900 s = rx->subbeg + rx->endp[0];
901 i = rx->sublen - rx->endp[0];
905 sv_setsv(sv,&PL_sv_undef);
908 if (GvIO(PL_last_in_gv)) {
909 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
914 sv_setiv(sv, (IV)STATUS_CURRENT);
915 #ifdef COMPLEX_STATUS
916 LvTARGOFF(sv) = PL_statusvalue;
917 LvTARGLEN(sv) = PL_statusvalue_vms;
922 if (GvIOp(PL_defoutgv))
923 s = IoTOP_NAME(GvIOp(PL_defoutgv));
927 sv_setpv(sv,GvENAME(PL_defoutgv));
932 if (GvIOp(PL_defoutgv))
933 s = IoFMT_NAME(GvIOp(PL_defoutgv));
935 s = GvENAME(PL_defoutgv);
939 if (GvIOp(PL_defoutgv))
940 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
943 if (GvIOp(PL_defoutgv))
944 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
947 if (GvIOp(PL_defoutgv))
948 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
955 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
965 sv_copypv(sv, PL_ors_sv);
969 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
970 sv_setpv(sv, errno ? Strerror(errno) : "");
973 const int saveerrno = errno;
974 sv_setnv(sv, (NV)errno);
976 if (errno == errno_isOS2 || errno == errno_isOS2_set)
977 sv_setpv(sv, os2error(Perl_rc));
980 sv_setpv(sv, errno ? Strerror(errno) : "");
985 SvNOK_on(sv); /* what a wonderful hack! */
988 sv_setiv(sv, (IV)PL_uid);
991 sv_setiv(sv, (IV)PL_euid);
994 sv_setiv(sv, (IV)PL_gid);
996 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1000 sv_setiv(sv, (IV)PL_egid);
1001 #ifdef HAS_GETGROUPS
1002 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1005 #ifdef HAS_GETGROUPS
1007 Groups_t gary[NGROUPS];
1008 I32 j = getgroups(NGROUPS,gary);
1010 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1013 (void)SvIOK_on(sv); /* what a wonderful hack! */
1015 #ifndef MACOS_TRADITIONAL
1024 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1026 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1028 if (uf && uf->uf_val)
1029 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1034 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1041 s = SvPV_const(sv,len);
1042 ptr = MgPV_const(mg,klen);
1045 #ifdef DYNAMIC_ENV_FETCH
1046 /* We just undefd an environment var. Is a replacement */
1047 /* waiting in the wings? */
1050 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1051 s = SvPV_const(*valp, len);
1055 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1056 /* And you'll never guess what the dog had */
1057 /* in its mouth... */
1059 MgTAINTEDDIR_off(mg);
1061 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1062 char pathbuf[256], eltbuf[256], *cp, *elt;
1066 strncpy(eltbuf, s, 255);
1069 do { /* DCL$PATH may be a search list */
1070 while (1) { /* as may dev portion of any element */
1071 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1072 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1073 cando_by_name(S_IWUSR,0,elt) ) {
1074 MgTAINTEDDIR_on(mg);
1078 if ((cp = strchr(elt, ':')) != Nullch)
1080 if (my_trnlnm(elt, eltbuf, j++))
1086 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1089 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1090 const char * const strend = s + len;
1092 while (s < strend) {
1096 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1097 s, strend, ':', &i);
1099 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1101 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1102 MgTAINTEDDIR_on(mg);
1108 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1114 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1116 PERL_UNUSED_ARG(sv);
1117 my_setenv(MgPV_nolen_const(mg),Nullch);
1122 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1124 PERL_UNUSED_ARG(mg);
1126 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1128 if (PL_localizing) {
1131 hv_iterinit((HV*)sv);
1132 while ((entry = hv_iternext((HV*)sv))) {
1134 my_setenv(hv_iterkey(entry, &keylen),
1135 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1143 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1146 PERL_UNUSED_ARG(sv);
1147 PERL_UNUSED_ARG(mg);
1149 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1157 #ifdef HAS_SIGPROCMASK
1159 restore_sigmask(pTHX_ SV *save_sv)
1161 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1162 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1166 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1168 /* Are we fetching a signal entry? */
1169 const I32 i = whichsig(MgPV_nolen_const(mg));
1172 sv_setsv(sv,PL_psig_ptr[i]);
1174 Sighandler_t sigstate;
1175 sigstate = rsignal_state(i);
1176 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1177 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1179 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1180 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1182 /* cache state so we don't fetch it again */
1183 if(sigstate == (Sighandler_t) SIG_IGN)
1184 sv_setpv(sv,"IGNORE");
1186 sv_setsv(sv,&PL_sv_undef);
1187 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1194 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1196 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1197 * refactoring might be in order.
1200 register const char * const s = MgPV_nolen_const(mg);
1201 PERL_UNUSED_ARG(sv);
1204 if (strEQ(s,"__DIE__"))
1206 else if (strEQ(s,"__WARN__"))
1209 Perl_croak(aTHX_ "No such hook: %s", s);
1211 SV * const to_dec = *svp;
1213 SvREFCNT_dec(to_dec);
1217 /* Are we clearing a signal entry? */
1218 const I32 i = whichsig(s);
1220 #ifdef HAS_SIGPROCMASK
1223 /* Avoid having the signal arrive at a bad time, if possible. */
1226 sigprocmask(SIG_BLOCK, &set, &save);
1228 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1229 SAVEFREESV(save_sv);
1230 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1233 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1234 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1236 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1237 PL_sig_defaulting[i] = 1;
1238 (void)rsignal(i, PL_csighandlerp);
1240 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1242 if(PL_psig_name[i]) {
1243 SvREFCNT_dec(PL_psig_name[i]);
1246 if(PL_psig_ptr[i]) {
1247 SV *to_dec=PL_psig_ptr[i];
1250 SvREFCNT_dec(to_dec);
1260 S_raise_signal(pTHX_ int sig)
1262 /* Set a flag to say this signal is pending */
1263 PL_psig_pend[sig]++;
1264 /* And one to say _a_ signal is pending */
1269 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1270 Perl_csighandler(int sig, ...)
1272 Perl_csighandler(int sig)
1275 #ifdef PERL_GET_SIG_CONTEXT
1276 dTHXa(PERL_GET_SIG_CONTEXT);
1280 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1281 (void) rsignal(sig, PL_csighandlerp);
1282 if (PL_sig_ignoring[sig]) return;
1284 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1285 if (PL_sig_defaulting[sig])
1286 #ifdef KILL_BY_SIGPRC
1287 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1292 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1293 /* Call the perl level handler now--
1294 * with risk we may be in malloc() etc. */
1295 (*PL_sighandlerp)(sig);
1297 S_raise_signal(aTHX_ sig);
1300 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1302 Perl_csighandler_init(void)
1305 if (PL_sig_handlers_initted) return;
1307 for (sig = 1; sig < SIG_SIZE; sig++) {
1308 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1310 PL_sig_defaulting[sig] = 1;
1311 (void) rsignal(sig, PL_csighandlerp);
1313 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1314 PL_sig_ignoring[sig] = 0;
1317 PL_sig_handlers_initted = 1;
1322 Perl_despatch_signals(pTHX)
1326 for (sig = 1; sig < SIG_SIZE; sig++) {
1327 if (PL_psig_pend[sig]) {
1328 PERL_BLOCKSIG_ADD(set, sig);
1329 PL_psig_pend[sig] = 0;
1330 PERL_BLOCKSIG_BLOCK(set);
1331 (*PL_sighandlerp)(sig);
1332 PERL_BLOCKSIG_UNBLOCK(set);
1338 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1343 /* Need to be careful with SvREFCNT_dec(), because that can have side
1344 * effects (due to closures). We must make sure that the new disposition
1345 * is in place before it is called.
1349 #ifdef HAS_SIGPROCMASK
1354 register const char *s = MgPV_const(mg,len);
1356 if (strEQ(s,"__DIE__"))
1358 else if (strEQ(s,"__WARN__"))
1361 Perl_croak(aTHX_ "No such hook: %s", s);
1369 i = whichsig(s); /* ...no, a brick */
1371 if (ckWARN(WARN_SIGNAL))
1372 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1375 #ifdef HAS_SIGPROCMASK
1376 /* Avoid having the signal arrive at a bad time, if possible. */
1379 sigprocmask(SIG_BLOCK, &set, &save);
1381 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1382 SAVEFREESV(save_sv);
1383 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1386 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1387 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1389 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1390 PL_sig_ignoring[i] = 0;
1392 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1393 PL_sig_defaulting[i] = 0;
1395 SvREFCNT_dec(PL_psig_name[i]);
1396 to_dec = PL_psig_ptr[i];
1397 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1398 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1399 PL_psig_name[i] = newSVpvn(s, len);
1400 SvREADONLY_on(PL_psig_name[i]);
1402 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1404 (void)rsignal(i, PL_csighandlerp);
1405 #ifdef HAS_SIGPROCMASK
1410 *svp = SvREFCNT_inc(sv);
1412 SvREFCNT_dec(to_dec);
1415 s = SvPV_force(sv,len);
1416 if (strEQ(s,"IGNORE")) {
1418 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1419 PL_sig_ignoring[i] = 1;
1420 (void)rsignal(i, PL_csighandlerp);
1422 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1426 else if (strEQ(s,"DEFAULT") || !*s) {
1428 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1430 PL_sig_defaulting[i] = 1;
1431 (void)rsignal(i, PL_csighandlerp);
1434 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1439 * We should warn if HINT_STRICT_REFS, but without
1440 * access to a known hint bit in a known OP, we can't
1441 * tell whether HINT_STRICT_REFS is in force or not.
1443 if (!strchr(s,':') && !strchr(s,'\''))
1444 sv_insert(sv, 0, 0, "main::", 6);
1446 (void)rsignal(i, PL_csighandlerp);
1448 *svp = SvREFCNT_inc(sv);
1450 #ifdef HAS_SIGPROCMASK
1455 SvREFCNT_dec(to_dec);
1458 #endif /* !PERL_MICRO */
1461 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1463 PERL_UNUSED_ARG(sv);
1464 PERL_UNUSED_ARG(mg);
1465 PL_sub_generation++;
1470 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1472 PERL_UNUSED_ARG(sv);
1473 PERL_UNUSED_ARG(mg);
1474 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1475 PL_amagic_generation++;
1481 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1483 HV * const hv = (HV*)LvTARG(sv);
1485 PERL_UNUSED_ARG(mg);
1488 (void) hv_iterinit(hv);
1489 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1492 while (hv_iternext(hv))
1497 sv_setiv(sv, (IV)i);
1502 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1504 PERL_UNUSED_ARG(mg);
1506 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1511 /* caller is responsible for stack switching/cleanup */
1513 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1519 PUSHs(SvTIED_obj(sv, mg));
1522 if (mg->mg_len >= 0)
1523 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1524 else if (mg->mg_len == HEf_SVKEY)
1525 PUSHs((SV*)mg->mg_ptr);
1527 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1528 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1536 return call_method(meth, flags);
1540 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1546 PUSHSTACKi(PERLSI_MAGIC);
1548 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1549 sv_setsv(sv, *PL_stack_sp--);
1559 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1562 mg->mg_flags |= MGf_GSKIP;
1563 magic_methpack(sv,mg,"FETCH");
1568 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1572 PUSHSTACKi(PERLSI_MAGIC);
1573 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1580 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1582 return magic_methpack(sv,mg,"DELETE");
1587 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1594 PUSHSTACKi(PERLSI_MAGIC);
1595 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1596 sv = *PL_stack_sp--;
1597 retval = (U32) SvIV(sv)-1;
1606 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1611 PUSHSTACKi(PERLSI_MAGIC);
1613 XPUSHs(SvTIED_obj(sv, mg));
1615 call_method("CLEAR", G_SCALAR|G_DISCARD);
1623 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1626 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1630 PUSHSTACKi(PERLSI_MAGIC);
1633 PUSHs(SvTIED_obj(sv, mg));
1638 if (call_method(meth, G_SCALAR))
1639 sv_setsv(key, *PL_stack_sp--);
1648 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1650 return magic_methpack(sv,mg,"EXISTS");
1654 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1657 SV *retval = &PL_sv_undef;
1658 SV * const tied = SvTIED_obj((SV*)hv, mg);
1659 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1661 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1663 if (HvEITER_get(hv))
1664 /* we are in an iteration so the hash cannot be empty */
1666 /* no xhv_eiter so now use FIRSTKEY */
1667 key = sv_newmortal();
1668 magic_nextpack((SV*)hv, mg, key);
1669 HvEITER_set(hv, NULL); /* need to reset iterator */
1670 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1673 /* there is a SCALAR method that we can call */
1675 PUSHSTACKi(PERLSI_MAGIC);
1681 if (call_method("SCALAR", G_SCALAR))
1682 retval = *PL_stack_sp--;
1689 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1691 GV * const gv = PL_DBline;
1692 const I32 i = SvTRUE(sv);
1693 SV ** const svp = av_fetch(GvAV(gv),
1694 atoi(MgPV_nolen_const(mg)), FALSE);
1695 if (svp && SvIOKp(*svp)) {
1696 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1698 /* set or clear breakpoint in the relevant control op */
1700 o->op_flags |= OPf_SPECIAL;
1702 o->op_flags &= ~OPf_SPECIAL;
1709 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1711 const AV * const obj = (AV*)mg->mg_obj;
1713 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1721 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1723 AV * const obj = (AV*)mg->mg_obj;
1725 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1727 if (ckWARN(WARN_MISC))
1728 Perl_warner(aTHX_ packWARN(WARN_MISC),
1729 "Attempt to set length of freed array");
1735 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1737 PERL_UNUSED_ARG(sv);
1738 /* during global destruction, mg_obj may already have been freed */
1739 if (PL_in_clean_all)
1742 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1745 /* arylen scalar holds a pointer back to the array, but doesn't own a
1746 reference. Hence the we (the array) are about to go away with it
1747 still pointing at us. Clear its pointer, else it would be pointing
1748 at free memory. See the comment in sv_magic about reference loops,
1749 and why it can't own a reference to us. */
1756 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1758 SV* const lsv = LvTARG(sv);
1760 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1761 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1762 if (mg && mg->mg_len >= 0) {
1765 sv_pos_b2u(lsv, &i);
1766 sv_setiv(sv, i + PL_curcop->cop_arybase);
1775 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1777 SV* const lsv = LvTARG(sv);
1784 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1785 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1789 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1790 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1792 else if (!SvOK(sv)) {
1796 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1798 pos = SvIV(sv) - PL_curcop->cop_arybase;
1801 ulen = sv_len_utf8(lsv);
1811 else if (pos > (SSize_t)len)
1816 sv_pos_u2b(lsv, &p, 0);
1821 mg->mg_flags &= ~MGf_MINMATCH;
1827 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1829 PERL_UNUSED_ARG(mg);
1830 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1832 gv_efullname3(sv,((GV*)sv), "*");
1836 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1841 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1844 PERL_UNUSED_ARG(mg);
1848 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1853 GvGP(sv) = gp_ref(GvGP(gv));
1858 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1861 SV * const lsv = LvTARG(sv);
1862 const char * const tmps = SvPV_const(lsv,len);
1863 I32 offs = LvTARGOFF(sv);
1864 I32 rem = LvTARGLEN(sv);
1865 PERL_UNUSED_ARG(mg);
1868 sv_pos_u2b(lsv, &offs, &rem);
1869 if (offs > (I32)len)
1871 if (rem + offs > (I32)len)
1873 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1880 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1883 const char *tmps = SvPV_const(sv, len);
1884 SV * const lsv = LvTARG(sv);
1885 I32 lvoff = LvTARGOFF(sv);
1886 I32 lvlen = LvTARGLEN(sv);
1887 PERL_UNUSED_ARG(mg);
1890 sv_utf8_upgrade(lsv);
1891 sv_pos_u2b(lsv, &lvoff, &lvlen);
1892 sv_insert(lsv, lvoff, lvlen, tmps, len);
1893 LvTARGLEN(sv) = sv_len_utf8(sv);
1896 else if (lsv && SvUTF8(lsv)) {
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 LvTARGLEN(sv) = len;
1899 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1900 sv_insert(lsv, lvoff, lvlen, tmps, len);
1904 sv_insert(lsv, lvoff, lvlen, tmps, len);
1905 LvTARGLEN(sv) = len;
1913 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1915 PERL_UNUSED_ARG(sv);
1916 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1921 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1923 PERL_UNUSED_ARG(sv);
1924 /* update taint status unless we're restoring at scope exit */
1925 if (PL_localizing != 2) {
1935 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1937 SV * const lsv = LvTARG(sv);
1938 PERL_UNUSED_ARG(mg);
1945 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1950 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1952 PERL_UNUSED_ARG(mg);
1953 do_vecset(sv); /* XXX slurp this routine */
1958 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1961 if (LvTARGLEN(sv)) {
1963 SV * const ahv = LvTARG(sv);
1964 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1969 AV* const av = (AV*)LvTARG(sv);
1970 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1971 targ = AvARRAY(av)[LvTARGOFF(sv)];
1973 if (targ && targ != &PL_sv_undef) {
1974 /* somebody else defined it for us */
1975 SvREFCNT_dec(LvTARG(sv));
1976 LvTARG(sv) = SvREFCNT_inc(targ);
1978 SvREFCNT_dec(mg->mg_obj);
1979 mg->mg_obj = Nullsv;
1980 mg->mg_flags &= ~MGf_REFCOUNTED;
1985 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1990 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1992 PERL_UNUSED_ARG(mg);
1996 sv_setsv(LvTARG(sv), sv);
1997 SvSETMAGIC(LvTARG(sv));
2003 Perl_vivify_defelem(pTHX_ SV *sv)
2008 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2011 SV * const ahv = LvTARG(sv);
2012 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2015 if (!value || value == &PL_sv_undef)
2016 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2019 AV* const av = (AV*)LvTARG(sv);
2020 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2021 LvTARG(sv) = Nullsv; /* array can't be extended */
2023 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2024 if (!svp || (value = *svp) == &PL_sv_undef)
2025 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2028 (void)SvREFCNT_inc(value);
2029 SvREFCNT_dec(LvTARG(sv));
2032 SvREFCNT_dec(mg->mg_obj);
2033 mg->mg_obj = Nullsv;
2034 mg->mg_flags &= ~MGf_REFCOUNTED;
2038 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2040 AV *const av = (AV*)mg->mg_obj;
2041 SV **svp = AvARRAY(av);
2042 PERL_UNUSED_ARG(sv);
2044 /* Not sure why the av can get freed ahead of its sv, but somehow it does
2045 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
2046 if (svp && !SvIS_FREED(av)) {
2047 SV *const *const last = svp + AvFILLp(av);
2049 while (svp <= last) {
2051 SV *const referrer = *svp;
2052 if (SvWEAKREF(referrer)) {
2053 /* XXX Should we check that it hasn't changed? */
2054 SvRV_set(referrer, 0);
2056 SvWEAKREF_off(referrer);
2057 } else if (SvTYPE(referrer) == SVt_PVGV ||
2058 SvTYPE(referrer) == SVt_PVLV) {
2059 /* You lookin' at me? */
2060 assert(GvSTASH(referrer));
2061 assert(GvSTASH(referrer) == (HV*)sv);
2062 GvSTASH(referrer) = 0;
2065 "panic: magic_killbackrefs (flags=%"UVxf")",
2066 (UV)SvFLAGS(referrer));
2074 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2079 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2087 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2089 PERL_UNUSED_ARG(mg);
2090 sv_unmagic(sv, PERL_MAGIC_bm);
2096 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2098 PERL_UNUSED_ARG(mg);
2099 sv_unmagic(sv, PERL_MAGIC_fm);
2105 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2107 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2109 if (uf && uf->uf_set)
2110 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2115 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2117 PERL_UNUSED_ARG(mg);
2118 sv_unmagic(sv, PERL_MAGIC_qr);
2123 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2125 regexp * const re = (regexp *)mg->mg_obj;
2126 PERL_UNUSED_ARG(sv);
2132 #ifdef USE_LOCALE_COLLATE
2134 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2137 * RenE<eacute> Descartes said "I think not."
2138 * and vanished with a faint plop.
2140 PERL_UNUSED_ARG(sv);
2142 Safefree(mg->mg_ptr);
2148 #endif /* USE_LOCALE_COLLATE */
2150 /* Just clear the UTF-8 cache data. */
2152 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2154 PERL_UNUSED_ARG(sv);
2155 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2157 mg->mg_len = -1; /* The mg_len holds the len cache. */
2162 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2164 register const char *s;
2167 switch (*mg->mg_ptr) {
2168 case '\001': /* ^A */
2169 sv_setsv(PL_bodytarget, sv);
2171 case '\003': /* ^C */
2172 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2175 case '\004': /* ^D */
2177 s = SvPV_nolen_const(sv);
2178 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2179 DEBUG_x(dump_all());
2181 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2184 case '\005': /* ^E */
2185 if (*(mg->mg_ptr+1) == '\0') {
2186 #ifdef MACOS_TRADITIONAL
2187 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2190 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2193 SetLastError( SvIV(sv) );
2196 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2198 /* will anyone ever use this? */
2199 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2205 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2207 SvREFCNT_dec(PL_encoding);
2208 if (SvOK(sv) || SvGMAGICAL(sv)) {
2209 PL_encoding = newSVsv(sv);
2212 PL_encoding = Nullsv;
2216 case '\006': /* ^F */
2217 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2219 case '\010': /* ^H */
2220 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2222 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2223 Safefree(PL_inplace);
2224 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2226 case '\017': /* ^O */
2227 if (*(mg->mg_ptr+1) == '\0') {
2228 Safefree(PL_osname);
2231 TAINT_PROPER("assigning to $^O");
2232 PL_osname = savesvpv(sv);
2235 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2236 if (!PL_compiling.cop_io)
2237 PL_compiling.cop_io = newSVsv(sv);
2239 sv_setsv(PL_compiling.cop_io,sv);
2242 case '\020': /* ^P */
2243 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2244 if (PL_perldb && !PL_DBsingle)
2247 case '\024': /* ^T */
2249 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2251 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2254 case '\027': /* ^W & $^WARNING_BITS */
2255 if (*(mg->mg_ptr+1) == '\0') {
2256 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2257 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2258 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2259 | (i ? G_WARN_ON : G_WARN_OFF) ;
2262 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2263 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2264 if (!SvPOK(sv) && PL_localizing) {
2265 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2266 PL_compiling.cop_warnings = pWARN_NONE;
2271 int accumulate = 0 ;
2272 int any_fatals = 0 ;
2273 const char * const ptr = SvPV_const(sv, len) ;
2274 for (i = 0 ; i < len ; ++i) {
2275 accumulate |= ptr[i] ;
2276 any_fatals |= (ptr[i] & 0xAA) ;
2279 PL_compiling.cop_warnings = pWARN_NONE;
2280 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2281 PL_compiling.cop_warnings = pWARN_ALL;
2282 PL_dowarn |= G_WARN_ONCE ;
2285 if (specialWARN(PL_compiling.cop_warnings))
2286 PL_compiling.cop_warnings = newSVsv(sv) ;
2288 sv_setsv(PL_compiling.cop_warnings, sv);
2289 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2290 PL_dowarn |= G_WARN_ONCE ;
2298 if (PL_localizing) {
2299 if (PL_localizing == 1)
2300 SAVESPTR(PL_last_in_gv);
2302 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2303 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2306 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2307 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2308 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2311 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2312 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2313 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2316 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2319 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2320 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2321 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2324 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2328 IO * const io = GvIOp(PL_defoutgv);
2331 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2332 IoFLAGS(io) &= ~IOf_FLUSH;
2334 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2335 PerlIO *ofp = IoOFP(io);
2337 (void)PerlIO_flush(ofp);
2338 IoFLAGS(io) |= IOf_FLUSH;
2344 SvREFCNT_dec(PL_rs);
2345 PL_rs = newSVsv(sv);
2349 SvREFCNT_dec(PL_ors_sv);
2350 if (SvOK(sv) || SvGMAGICAL(sv)) {
2351 PL_ors_sv = newSVsv(sv);
2359 SvREFCNT_dec(PL_ofs_sv);
2360 if (SvOK(sv) || SvGMAGICAL(sv)) {
2361 PL_ofs_sv = newSVsv(sv);
2368 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2371 #ifdef COMPLEX_STATUS
2372 if (PL_localizing == 2) {
2373 PL_statusvalue = LvTARGOFF(sv);
2374 PL_statusvalue_vms = LvTARGLEN(sv);
2378 #ifdef VMSISH_STATUS
2380 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2383 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2388 # define PERL_VMS_BANG vaxc$errno
2390 # define PERL_VMS_BANG 0
2392 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2393 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2397 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2398 if (PL_delaymagic) {
2399 PL_delaymagic |= DM_RUID;
2400 break; /* don't do magic till later */
2403 (void)setruid((Uid_t)PL_uid);
2406 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2408 #ifdef HAS_SETRESUID
2409 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2411 if (PL_uid == PL_euid) { /* special case $< = $> */
2413 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2414 if (PL_uid != 0 && PerlProc_getuid() == 0)
2415 (void)PerlProc_setuid(0);
2417 (void)PerlProc_setuid(PL_uid);
2419 PL_uid = PerlProc_getuid();
2420 Perl_croak(aTHX_ "setruid() not implemented");
2425 PL_uid = PerlProc_getuid();
2426 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2429 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2430 if (PL_delaymagic) {
2431 PL_delaymagic |= DM_EUID;
2432 break; /* don't do magic till later */
2435 (void)seteuid((Uid_t)PL_euid);
2438 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2440 #ifdef HAS_SETRESUID
2441 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2443 if (PL_euid == PL_uid) /* special case $> = $< */
2444 PerlProc_setuid(PL_euid);
2446 PL_euid = PerlProc_geteuid();
2447 Perl_croak(aTHX_ "seteuid() not implemented");
2452 PL_euid = PerlProc_geteuid();
2453 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2456 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2457 if (PL_delaymagic) {
2458 PL_delaymagic |= DM_RGID;
2459 break; /* don't do magic till later */
2462 (void)setrgid((Gid_t)PL_gid);
2465 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2467 #ifdef HAS_SETRESGID
2468 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2470 if (PL_gid == PL_egid) /* special case $( = $) */
2471 (void)PerlProc_setgid(PL_gid);
2473 PL_gid = PerlProc_getgid();
2474 Perl_croak(aTHX_ "setrgid() not implemented");
2479 PL_gid = PerlProc_getgid();
2480 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2483 #ifdef HAS_SETGROUPS
2485 const char *p = SvPV_const(sv, len);
2486 Groups_t gary[NGROUPS];
2491 for (i = 0; i < NGROUPS; ++i) {
2492 while (*p && !isSPACE(*p))
2501 (void)setgroups(i, gary);
2503 #else /* HAS_SETGROUPS */
2504 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2505 #endif /* HAS_SETGROUPS */
2506 if (PL_delaymagic) {
2507 PL_delaymagic |= DM_EGID;
2508 break; /* don't do magic till later */
2511 (void)setegid((Gid_t)PL_egid);
2514 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2516 #ifdef HAS_SETRESGID
2517 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2519 if (PL_egid == PL_gid) /* special case $) = $( */
2520 (void)PerlProc_setgid(PL_egid);
2522 PL_egid = PerlProc_getegid();
2523 Perl_croak(aTHX_ "setegid() not implemented");
2528 PL_egid = PerlProc_getegid();
2529 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2532 PL_chopset = SvPV_force(sv,len);
2534 #ifndef MACOS_TRADITIONAL
2536 LOCK_DOLLARZERO_MUTEX;
2537 #ifdef HAS_SETPROCTITLE
2538 /* The BSDs don't show the argv[] in ps(1) output, they
2539 * show a string from the process struct and provide
2540 * the setproctitle() routine to manipulate that. */
2542 s = SvPV_const(sv, len);
2543 # if __FreeBSD_version > 410001
2544 /* The leading "-" removes the "perl: " prefix,
2545 * but not the "(perl) suffix from the ps(1)
2546 * output, because that's what ps(1) shows if the
2547 * argv[] is modified. */
2548 setproctitle("-%s", s);
2549 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2550 /* This doesn't really work if you assume that
2551 * $0 = 'foobar'; will wipe out 'perl' from the $0
2552 * because in ps(1) output the result will be like
2553 * sprintf("perl: %s (perl)", s)
2554 * I guess this is a security feature:
2555 * one (a user process) cannot get rid of the original name.
2557 setproctitle("%s", s);
2561 #if defined(__hpux) && defined(PSTAT_SETCMD)
2564 s = SvPV_const(sv, len);
2565 un.pst_command = (char *)s;
2566 pstat(PSTAT_SETCMD, un, len, 0, 0);
2569 /* PL_origalen is set in perl_parse(). */
2570 s = SvPV_force(sv,len);
2571 if (len >= (STRLEN)PL_origalen-1) {
2572 /* Longer than original, will be truncated. We assume that
2573 * PL_origalen bytes are available. */
2574 Copy(s, PL_origargv[0], PL_origalen-1, char);
2577 /* Shorter than original, will be padded. */
2578 Copy(s, PL_origargv[0], len, char);
2579 PL_origargv[0][len] = 0;
2580 memset(PL_origargv[0] + len + 1,
2581 /* Is the space counterintuitive? Yes.
2582 * (You were expecting \0?)
2583 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2586 PL_origalen - len - 1);
2588 PL_origargv[0][PL_origalen-1] = 0;
2589 for (i = 1; i < PL_origargc; i++)
2591 UNLOCK_DOLLARZERO_MUTEX;
2599 Perl_whichsig(pTHX_ const char *sig)
2601 register char* const* sigv;
2603 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2604 if (strEQ(sig,*sigv))
2605 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2607 if (strEQ(sig,"CHLD"))
2611 if (strEQ(sig,"CLD"))
2618 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2619 Perl_sighandler(int sig, ...)
2621 Perl_sighandler(int sig)
2624 #ifdef PERL_GET_SIG_CONTEXT
2625 dTHXa(PERL_GET_SIG_CONTEXT);
2632 SV * const tSv = PL_Sv;
2636 XPV * const tXpv = PL_Xpv;
2638 if (PL_savestack_ix + 15 <= PL_savestack_max)
2640 if (PL_markstack_ptr < PL_markstack_max - 2)
2642 if (PL_scopestack_ix < PL_scopestack_max - 3)
2645 if (!PL_psig_ptr[sig]) {
2646 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2651 /* Max number of items pushed there is 3*n or 4. We cannot fix
2652 infinity, so we fix 4 (in fact 5): */
2654 PL_savestack_ix += 5; /* Protect save in progress. */
2655 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2658 PL_markstack_ptr++; /* Protect mark. */
2660 PL_scopestack_ix += 1;
2661 /* sv_2cv is too complicated, try a simpler variant first: */
2662 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2663 || SvTYPE(cv) != SVt_PVCV) {
2665 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2668 if (!cv || !CvROOT(cv)) {
2669 if (ckWARN(WARN_SIGNAL))
2670 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2671 PL_sig_name[sig], (gv ? GvENAME(gv)
2678 if(PL_psig_name[sig]) {
2679 sv = SvREFCNT_inc(PL_psig_name[sig]);
2681 #if !defined(PERL_IMPLICIT_CONTEXT)
2685 sv = sv_newmortal();
2686 sv_setpv(sv,PL_sig_name[sig]);
2689 PUSHSTACKi(PERLSI_SIGNAL);
2692 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2694 struct sigaction oact;
2696 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2700 va_start(args, sig);
2701 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2704 SV *rv = newRV_noinc((SV*)sih);
2705 /* The siginfo fields signo, code, errno, pid, uid,
2706 * addr, status, and band are defined by POSIX/SUSv3. */
2707 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2708 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2709 #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. */
2710 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2711 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2712 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2713 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2714 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2715 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2719 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2728 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2731 if (SvTRUE(ERRSV)) {
2733 #ifdef HAS_SIGPROCMASK
2734 /* Handler "died", for example to get out of a restart-able read().
2735 * Before we re-do that on its behalf re-enable the signal which was
2736 * blocked by the system when we entered.
2740 sigaddset(&set,sig);
2741 sigprocmask(SIG_UNBLOCK, &set, NULL);
2743 /* Not clear if this will work */
2744 (void)rsignal(sig, SIG_IGN);
2745 (void)rsignal(sig, PL_csighandlerp);
2747 #endif /* !PERL_MICRO */
2748 Perl_die(aTHX_ Nullch);
2752 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2756 PL_scopestack_ix -= 1;
2759 PL_op = myop; /* Apparently not needed... */
2761 PL_Sv = tSv; /* Restore global temporaries. */
2768 S_restore_magic(pTHX_ const void *p)
2770 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2771 SV* const sv = mgs->mgs_sv;
2776 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2778 #ifdef PERL_OLD_COPY_ON_WRITE
2779 /* While magic was saved (and off) sv_setsv may well have seen
2780 this SV as a prime candidate for COW. */
2782 sv_force_normal_flags(sv, 0);
2786 SvFLAGS(sv) |= mgs->mgs_flags;
2789 if (SvGMAGICAL(sv)) {
2790 /* downgrade public flags to private,
2791 and discard any other private flags */
2793 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2795 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2796 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2801 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2803 /* If we're still on top of the stack, pop us off. (That condition
2804 * will be satisfied if restore_magic was called explicitly, but *not*
2805 * if it's being called via leave_scope.)
2806 * The reason for doing this is that otherwise, things like sv_2cv()
2807 * may leave alloc gunk on the savestack, and some code
2808 * (e.g. sighandler) doesn't expect that...
2810 if (PL_savestack_ix == mgs->mgs_ss_ix)
2812 I32 popval = SSPOPINT;
2813 assert(popval == SAVEt_DESTRUCTOR_X);
2814 PL_savestack_ix -= 2;
2816 assert(popval == SAVEt_ALLOC);
2818 PL_savestack_ix -= popval;
2824 S_unwind_handler_stack(pTHX_ const void *p)
2827 const U32 flags = *(const U32*)p;
2830 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2831 /* cxstack_ix-- Not needed, die already unwound it. */
2832 #if !defined(PERL_IMPLICIT_CONTEXT)
2834 SvREFCNT_dec(PL_sig_sv);
2840 * c-indentation-style: bsd
2842 * indent-tabs-mode: t
2845 * ex: set ts=8 sts=4 sw=4 noet: