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)
1125 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1127 if (PL_localizing) {
1130 hv_iterinit((HV*)sv);
1131 while ((entry = hv_iternext((HV*)sv))) {
1133 my_setenv(hv_iterkey(entry, &keylen),
1134 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1142 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1145 PERL_UNUSED_ARG(sv);
1146 PERL_UNUSED_ARG(mg);
1148 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1156 #ifdef HAS_SIGPROCMASK
1158 restore_sigmask(pTHX_ SV *save_sv)
1160 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1161 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1165 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1167 /* Are we fetching a signal entry? */
1168 const I32 i = whichsig(MgPV_nolen_const(mg));
1171 sv_setsv(sv,PL_psig_ptr[i]);
1173 Sighandler_t sigstate;
1174 sigstate = rsignal_state(i);
1175 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1176 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1178 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1179 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1181 /* cache state so we don't fetch it again */
1182 if(sigstate == (Sighandler_t) SIG_IGN)
1183 sv_setpv(sv,"IGNORE");
1185 sv_setsv(sv,&PL_sv_undef);
1186 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1193 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1195 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1196 * refactoring might be in order.
1199 register const char * const s = MgPV_nolen_const(mg);
1200 PERL_UNUSED_ARG(sv);
1203 if (strEQ(s,"__DIE__"))
1205 else if (strEQ(s,"__WARN__"))
1208 Perl_croak(aTHX_ "No such hook: %s", s);
1210 SV * const to_dec = *svp;
1212 SvREFCNT_dec(to_dec);
1216 /* Are we clearing a signal entry? */
1217 const I32 i = whichsig(s);
1219 #ifdef HAS_SIGPROCMASK
1222 /* Avoid having the signal arrive at a bad time, if possible. */
1225 sigprocmask(SIG_BLOCK, &set, &save);
1227 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1228 SAVEFREESV(save_sv);
1229 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1232 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1233 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1235 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1236 PL_sig_defaulting[i] = 1;
1237 (void)rsignal(i, PL_csighandlerp);
1239 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1241 if(PL_psig_name[i]) {
1242 SvREFCNT_dec(PL_psig_name[i]);
1245 if(PL_psig_ptr[i]) {
1246 SV *to_dec=PL_psig_ptr[i];
1249 SvREFCNT_dec(to_dec);
1259 S_raise_signal(pTHX_ int sig)
1261 /* Set a flag to say this signal is pending */
1262 PL_psig_pend[sig]++;
1263 /* And one to say _a_ signal is pending */
1268 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1269 Perl_csighandler(int sig, ...)
1271 Perl_csighandler(int sig)
1274 #ifdef PERL_GET_SIG_CONTEXT
1275 dTHXa(PERL_GET_SIG_CONTEXT);
1279 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1280 (void) rsignal(sig, PL_csighandlerp);
1281 if (PL_sig_ignoring[sig]) return;
1283 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1284 if (PL_sig_defaulting[sig])
1285 #ifdef KILL_BY_SIGPRC
1286 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1291 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1292 /* Call the perl level handler now--
1293 * with risk we may be in malloc() etc. */
1294 (*PL_sighandlerp)(sig);
1296 S_raise_signal(aTHX_ sig);
1299 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1301 Perl_csighandler_init(void)
1304 if (PL_sig_handlers_initted) return;
1306 for (sig = 1; sig < SIG_SIZE; sig++) {
1307 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1309 PL_sig_defaulting[sig] = 1;
1310 (void) rsignal(sig, PL_csighandlerp);
1312 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1313 PL_sig_ignoring[sig] = 0;
1316 PL_sig_handlers_initted = 1;
1321 Perl_despatch_signals(pTHX)
1325 for (sig = 1; sig < SIG_SIZE; sig++) {
1326 if (PL_psig_pend[sig]) {
1327 PERL_BLOCKSIG_ADD(set, sig);
1328 PL_psig_pend[sig] = 0;
1329 PERL_BLOCKSIG_BLOCK(set);
1330 (*PL_sighandlerp)(sig);
1331 PERL_BLOCKSIG_UNBLOCK(set);
1337 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1342 /* Need to be careful with SvREFCNT_dec(), because that can have side
1343 * effects (due to closures). We must make sure that the new disposition
1344 * is in place before it is called.
1348 #ifdef HAS_SIGPROCMASK
1353 register const char *s = MgPV_const(mg,len);
1355 if (strEQ(s,"__DIE__"))
1357 else if (strEQ(s,"__WARN__"))
1360 Perl_croak(aTHX_ "No such hook: %s", s);
1368 i = whichsig(s); /* ...no, a brick */
1370 if (ckWARN(WARN_SIGNAL))
1371 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1374 #ifdef HAS_SIGPROCMASK
1375 /* Avoid having the signal arrive at a bad time, if possible. */
1378 sigprocmask(SIG_BLOCK, &set, &save);
1380 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1381 SAVEFREESV(save_sv);
1382 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1385 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1386 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1388 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1389 PL_sig_ignoring[i] = 0;
1391 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1392 PL_sig_defaulting[i] = 0;
1394 SvREFCNT_dec(PL_psig_name[i]);
1395 to_dec = PL_psig_ptr[i];
1396 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1397 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1398 PL_psig_name[i] = newSVpvn(s, len);
1399 SvREADONLY_on(PL_psig_name[i]);
1401 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1403 (void)rsignal(i, PL_csighandlerp);
1404 #ifdef HAS_SIGPROCMASK
1409 *svp = SvREFCNT_inc(sv);
1411 SvREFCNT_dec(to_dec);
1414 s = SvPV_force(sv,len);
1415 if (strEQ(s,"IGNORE")) {
1417 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1418 PL_sig_ignoring[i] = 1;
1419 (void)rsignal(i, PL_csighandlerp);
1421 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1425 else if (strEQ(s,"DEFAULT") || !*s) {
1427 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1429 PL_sig_defaulting[i] = 1;
1430 (void)rsignal(i, PL_csighandlerp);
1433 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1438 * We should warn if HINT_STRICT_REFS, but without
1439 * access to a known hint bit in a known OP, we can't
1440 * tell whether HINT_STRICT_REFS is in force or not.
1442 if (!strchr(s,':') && !strchr(s,'\''))
1443 sv_insert(sv, 0, 0, "main::", 6);
1445 (void)rsignal(i, PL_csighandlerp);
1447 *svp = SvREFCNT_inc(sv);
1449 #ifdef HAS_SIGPROCMASK
1454 SvREFCNT_dec(to_dec);
1457 #endif /* !PERL_MICRO */
1460 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1462 PERL_UNUSED_ARG(sv);
1463 PERL_UNUSED_ARG(mg);
1464 PL_sub_generation++;
1469 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1471 PERL_UNUSED_ARG(sv);
1472 PERL_UNUSED_ARG(mg);
1473 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1474 PL_amagic_generation++;
1480 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1482 HV * const hv = (HV*)LvTARG(sv);
1484 PERL_UNUSED_ARG(mg);
1487 (void) hv_iterinit(hv);
1488 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1491 while (hv_iternext(hv))
1496 sv_setiv(sv, (IV)i);
1501 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1503 PERL_UNUSED_ARG(mg);
1505 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1510 /* caller is responsible for stack switching/cleanup */
1512 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1518 PUSHs(SvTIED_obj(sv, mg));
1521 if (mg->mg_len >= 0)
1522 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1523 else if (mg->mg_len == HEf_SVKEY)
1524 PUSHs((SV*)mg->mg_ptr);
1526 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1527 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1535 return call_method(meth, flags);
1539 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1545 PUSHSTACKi(PERLSI_MAGIC);
1547 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1548 sv_setsv(sv, *PL_stack_sp--);
1558 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1561 mg->mg_flags |= MGf_GSKIP;
1562 magic_methpack(sv,mg,"FETCH");
1567 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1571 PUSHSTACKi(PERLSI_MAGIC);
1572 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1579 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1581 return magic_methpack(sv,mg,"DELETE");
1586 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1593 PUSHSTACKi(PERLSI_MAGIC);
1594 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1595 sv = *PL_stack_sp--;
1596 retval = (U32) SvIV(sv)-1;
1605 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1610 PUSHSTACKi(PERLSI_MAGIC);
1612 XPUSHs(SvTIED_obj(sv, mg));
1614 call_method("CLEAR", G_SCALAR|G_DISCARD);
1622 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1625 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1629 PUSHSTACKi(PERLSI_MAGIC);
1632 PUSHs(SvTIED_obj(sv, mg));
1637 if (call_method(meth, G_SCALAR))
1638 sv_setsv(key, *PL_stack_sp--);
1647 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1649 return magic_methpack(sv,mg,"EXISTS");
1653 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1656 SV *retval = &PL_sv_undef;
1657 SV * const tied = SvTIED_obj((SV*)hv, mg);
1658 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1660 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1662 if (HvEITER_get(hv))
1663 /* we are in an iteration so the hash cannot be empty */
1665 /* no xhv_eiter so now use FIRSTKEY */
1666 key = sv_newmortal();
1667 magic_nextpack((SV*)hv, mg, key);
1668 HvEITER_set(hv, NULL); /* need to reset iterator */
1669 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1672 /* there is a SCALAR method that we can call */
1674 PUSHSTACKi(PERLSI_MAGIC);
1680 if (call_method("SCALAR", G_SCALAR))
1681 retval = *PL_stack_sp--;
1688 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1690 GV * const gv = PL_DBline;
1691 const I32 i = SvTRUE(sv);
1692 SV ** const svp = av_fetch(GvAV(gv),
1693 atoi(MgPV_nolen_const(mg)), FALSE);
1694 if (svp && SvIOKp(*svp)) {
1695 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1697 /* set or clear breakpoint in the relevant control op */
1699 o->op_flags |= OPf_SPECIAL;
1701 o->op_flags &= ~OPf_SPECIAL;
1708 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1710 const AV * const obj = (AV*)mg->mg_obj;
1712 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1720 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1722 AV * const obj = (AV*)mg->mg_obj;
1724 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1726 if (ckWARN(WARN_MISC))
1727 Perl_warner(aTHX_ packWARN(WARN_MISC),
1728 "Attempt to set length of freed array");
1734 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1736 PERL_UNUSED_ARG(sv);
1737 /* during global destruction, mg_obj may already have been freed */
1738 if (PL_in_clean_all)
1741 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1744 /* arylen scalar holds a pointer back to the array, but doesn't own a
1745 reference. Hence the we (the array) are about to go away with it
1746 still pointing at us. Clear its pointer, else it would be pointing
1747 at free memory. See the comment in sv_magic about reference loops,
1748 and why it can't own a reference to us. */
1755 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1757 SV* const lsv = LvTARG(sv);
1759 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1760 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1761 if (mg && mg->mg_len >= 0) {
1764 sv_pos_b2u(lsv, &i);
1765 sv_setiv(sv, i + PL_curcop->cop_arybase);
1774 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1776 SV* const lsv = LvTARG(sv);
1783 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1784 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1788 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1789 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1791 else if (!SvOK(sv)) {
1795 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1797 pos = SvIV(sv) - PL_curcop->cop_arybase;
1800 ulen = sv_len_utf8(lsv);
1810 else if (pos > (SSize_t)len)
1815 sv_pos_u2b(lsv, &p, 0);
1820 mg->mg_flags &= ~MGf_MINMATCH;
1826 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1828 PERL_UNUSED_ARG(mg);
1829 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1831 gv_efullname3(sv,((GV*)sv), "*");
1835 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1840 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1843 PERL_UNUSED_ARG(mg);
1847 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1852 GvGP(sv) = gp_ref(GvGP(gv));
1857 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1860 SV * const lsv = LvTARG(sv);
1861 const char * const tmps = SvPV_const(lsv,len);
1862 I32 offs = LvTARGOFF(sv);
1863 I32 rem = LvTARGLEN(sv);
1864 PERL_UNUSED_ARG(mg);
1867 sv_pos_u2b(lsv, &offs, &rem);
1868 if (offs > (I32)len)
1870 if (rem + offs > (I32)len)
1872 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1879 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1882 const char *tmps = SvPV_const(sv, len);
1883 SV * const lsv = LvTARG(sv);
1884 I32 lvoff = LvTARGOFF(sv);
1885 I32 lvlen = LvTARGLEN(sv);
1886 PERL_UNUSED_ARG(mg);
1889 sv_utf8_upgrade(lsv);
1890 sv_pos_u2b(lsv, &lvoff, &lvlen);
1891 sv_insert(lsv, lvoff, lvlen, tmps, len);
1892 LvTARGLEN(sv) = sv_len_utf8(sv);
1895 else if (lsv && SvUTF8(lsv)) {
1896 sv_pos_u2b(lsv, &lvoff, &lvlen);
1897 LvTARGLEN(sv) = len;
1898 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1899 sv_insert(lsv, lvoff, lvlen, tmps, len);
1903 sv_insert(lsv, lvoff, lvlen, tmps, len);
1904 LvTARGLEN(sv) = len;
1912 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1914 PERL_UNUSED_ARG(sv);
1915 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1920 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1922 PERL_UNUSED_ARG(sv);
1923 /* update taint status unless we're restoring at scope exit */
1924 if (PL_localizing != 2) {
1934 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1936 SV * const lsv = LvTARG(sv);
1937 PERL_UNUSED_ARG(mg);
1944 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1949 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1951 PERL_UNUSED_ARG(mg);
1952 do_vecset(sv); /* XXX slurp this routine */
1957 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1960 if (LvTARGLEN(sv)) {
1962 SV * const ahv = LvTARG(sv);
1963 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1968 AV* const av = (AV*)LvTARG(sv);
1969 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1970 targ = AvARRAY(av)[LvTARGOFF(sv)];
1972 if (targ && targ != &PL_sv_undef) {
1973 /* somebody else defined it for us */
1974 SvREFCNT_dec(LvTARG(sv));
1975 LvTARG(sv) = SvREFCNT_inc(targ);
1977 SvREFCNT_dec(mg->mg_obj);
1978 mg->mg_obj = Nullsv;
1979 mg->mg_flags &= ~MGf_REFCOUNTED;
1984 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1989 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1991 PERL_UNUSED_ARG(mg);
1995 sv_setsv(LvTARG(sv), sv);
1996 SvSETMAGIC(LvTARG(sv));
2002 Perl_vivify_defelem(pTHX_ SV *sv)
2007 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2010 SV * const ahv = LvTARG(sv);
2011 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2014 if (!value || value == &PL_sv_undef)
2015 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2018 AV* const av = (AV*)LvTARG(sv);
2019 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2020 LvTARG(sv) = Nullsv; /* array can't be extended */
2022 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2023 if (!svp || (value = *svp) == &PL_sv_undef)
2024 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2027 (void)SvREFCNT_inc(value);
2028 SvREFCNT_dec(LvTARG(sv));
2031 SvREFCNT_dec(mg->mg_obj);
2032 mg->mg_obj = Nullsv;
2033 mg->mg_flags &= ~MGf_REFCOUNTED;
2037 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2039 AV *const av = (AV*)mg->mg_obj;
2040 SV **svp = AvARRAY(av);
2041 PERL_UNUSED_ARG(sv);
2044 SV *const *const last = svp + AvFILLp(av);
2046 while (svp <= last) {
2048 SV *const referrer = *svp;
2049 if (SvWEAKREF(referrer)) {
2050 /* XXX Should we check that it hasn't changed? */
2051 SvRV_set(referrer, 0);
2053 SvWEAKREF_off(referrer);
2054 } else if (SvTYPE(referrer) == SVt_PVGV ||
2055 SvTYPE(referrer) == SVt_PVLV) {
2056 /* You lookin' at me? */
2057 assert(GvSTASH(referrer));
2058 assert(GvSTASH(referrer) == (HV*)sv);
2059 GvSTASH(referrer) = 0;
2062 "panic: magic_killbackrefs (flags=%"UVxf")",
2063 (UV)SvFLAGS(referrer));
2071 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2076 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2084 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2086 PERL_UNUSED_ARG(mg);
2087 sv_unmagic(sv, PERL_MAGIC_bm);
2093 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2095 PERL_UNUSED_ARG(mg);
2096 sv_unmagic(sv, PERL_MAGIC_fm);
2102 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2104 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2106 if (uf && uf->uf_set)
2107 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2112 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2114 PERL_UNUSED_ARG(mg);
2115 sv_unmagic(sv, PERL_MAGIC_qr);
2120 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2122 regexp * const re = (regexp *)mg->mg_obj;
2123 PERL_UNUSED_ARG(sv);
2129 #ifdef USE_LOCALE_COLLATE
2131 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2134 * RenE<eacute> Descartes said "I think not."
2135 * and vanished with a faint plop.
2137 PERL_UNUSED_ARG(sv);
2139 Safefree(mg->mg_ptr);
2145 #endif /* USE_LOCALE_COLLATE */
2147 /* Just clear the UTF-8 cache data. */
2149 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2151 PERL_UNUSED_ARG(sv);
2152 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2154 mg->mg_len = -1; /* The mg_len holds the len cache. */
2159 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2161 register const char *s;
2164 switch (*mg->mg_ptr) {
2165 case '\001': /* ^A */
2166 sv_setsv(PL_bodytarget, sv);
2168 case '\003': /* ^C */
2169 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2172 case '\004': /* ^D */
2174 s = SvPV_nolen_const(sv);
2175 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2176 DEBUG_x(dump_all());
2178 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2181 case '\005': /* ^E */
2182 if (*(mg->mg_ptr+1) == '\0') {
2183 #ifdef MACOS_TRADITIONAL
2184 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2187 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2190 SetLastError( SvIV(sv) );
2193 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2195 /* will anyone ever use this? */
2196 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2202 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2204 SvREFCNT_dec(PL_encoding);
2205 if (SvOK(sv) || SvGMAGICAL(sv)) {
2206 PL_encoding = newSVsv(sv);
2209 PL_encoding = Nullsv;
2213 case '\006': /* ^F */
2214 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2216 case '\010': /* ^H */
2217 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2219 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2220 Safefree(PL_inplace);
2221 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2223 case '\017': /* ^O */
2224 if (*(mg->mg_ptr+1) == '\0') {
2225 Safefree(PL_osname);
2228 TAINT_PROPER("assigning to $^O");
2229 PL_osname = savesvpv(sv);
2232 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2233 if (!PL_compiling.cop_io)
2234 PL_compiling.cop_io = newSVsv(sv);
2236 sv_setsv(PL_compiling.cop_io,sv);
2239 case '\020': /* ^P */
2240 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2241 if (PL_perldb && !PL_DBsingle)
2244 case '\024': /* ^T */
2246 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2248 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2251 case '\027': /* ^W & $^WARNING_BITS */
2252 if (*(mg->mg_ptr+1) == '\0') {
2253 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2254 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2255 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2256 | (i ? G_WARN_ON : G_WARN_OFF) ;
2259 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2260 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2261 if (!SvPOK(sv) && PL_localizing) {
2262 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2263 PL_compiling.cop_warnings = pWARN_NONE;
2268 int accumulate = 0 ;
2269 int any_fatals = 0 ;
2270 const char * const ptr = SvPV_const(sv, len) ;
2271 for (i = 0 ; i < len ; ++i) {
2272 accumulate |= ptr[i] ;
2273 any_fatals |= (ptr[i] & 0xAA) ;
2276 PL_compiling.cop_warnings = pWARN_NONE;
2277 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2278 PL_compiling.cop_warnings = pWARN_ALL;
2279 PL_dowarn |= G_WARN_ONCE ;
2282 if (specialWARN(PL_compiling.cop_warnings))
2283 PL_compiling.cop_warnings = newSVsv(sv) ;
2285 sv_setsv(PL_compiling.cop_warnings, sv);
2286 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2287 PL_dowarn |= G_WARN_ONCE ;
2295 if (PL_localizing) {
2296 if (PL_localizing == 1)
2297 SAVESPTR(PL_last_in_gv);
2299 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2300 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2303 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2304 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2305 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2308 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2309 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2310 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2313 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2316 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2317 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2318 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2321 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2325 IO * const io = GvIOp(PL_defoutgv);
2328 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2329 IoFLAGS(io) &= ~IOf_FLUSH;
2331 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2332 PerlIO *ofp = IoOFP(io);
2334 (void)PerlIO_flush(ofp);
2335 IoFLAGS(io) |= IOf_FLUSH;
2341 SvREFCNT_dec(PL_rs);
2342 PL_rs = newSVsv(sv);
2346 SvREFCNT_dec(PL_ors_sv);
2347 if (SvOK(sv) || SvGMAGICAL(sv)) {
2348 PL_ors_sv = newSVsv(sv);
2356 SvREFCNT_dec(PL_ofs_sv);
2357 if (SvOK(sv) || SvGMAGICAL(sv)) {
2358 PL_ofs_sv = newSVsv(sv);
2365 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2368 #ifdef COMPLEX_STATUS
2369 if (PL_localizing == 2) {
2370 PL_statusvalue = LvTARGOFF(sv);
2371 PL_statusvalue_vms = LvTARGLEN(sv);
2375 #ifdef VMSISH_STATUS
2377 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2380 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2385 # define PERL_VMS_BANG vaxc$errno
2387 # define PERL_VMS_BANG 0
2389 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2390 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2394 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2395 if (PL_delaymagic) {
2396 PL_delaymagic |= DM_RUID;
2397 break; /* don't do magic till later */
2400 (void)setruid((Uid_t)PL_uid);
2403 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2405 #ifdef HAS_SETRESUID
2406 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2408 if (PL_uid == PL_euid) { /* special case $< = $> */
2410 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2411 if (PL_uid != 0 && PerlProc_getuid() == 0)
2412 (void)PerlProc_setuid(0);
2414 (void)PerlProc_setuid(PL_uid);
2416 PL_uid = PerlProc_getuid();
2417 Perl_croak(aTHX_ "setruid() not implemented");
2422 PL_uid = PerlProc_getuid();
2423 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2426 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2427 if (PL_delaymagic) {
2428 PL_delaymagic |= DM_EUID;
2429 break; /* don't do magic till later */
2432 (void)seteuid((Uid_t)PL_euid);
2435 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2437 #ifdef HAS_SETRESUID
2438 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2440 if (PL_euid == PL_uid) /* special case $> = $< */
2441 PerlProc_setuid(PL_euid);
2443 PL_euid = PerlProc_geteuid();
2444 Perl_croak(aTHX_ "seteuid() not implemented");
2449 PL_euid = PerlProc_geteuid();
2450 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2453 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2454 if (PL_delaymagic) {
2455 PL_delaymagic |= DM_RGID;
2456 break; /* don't do magic till later */
2459 (void)setrgid((Gid_t)PL_gid);
2462 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2464 #ifdef HAS_SETRESGID
2465 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2467 if (PL_gid == PL_egid) /* special case $( = $) */
2468 (void)PerlProc_setgid(PL_gid);
2470 PL_gid = PerlProc_getgid();
2471 Perl_croak(aTHX_ "setrgid() not implemented");
2476 PL_gid = PerlProc_getgid();
2477 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2480 #ifdef HAS_SETGROUPS
2482 const char *p = SvPV_const(sv, len);
2483 Groups_t gary[NGROUPS];
2488 for (i = 0; i < NGROUPS; ++i) {
2489 while (*p && !isSPACE(*p))
2498 (void)setgroups(i, gary);
2500 #else /* HAS_SETGROUPS */
2501 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2502 #endif /* HAS_SETGROUPS */
2503 if (PL_delaymagic) {
2504 PL_delaymagic |= DM_EGID;
2505 break; /* don't do magic till later */
2508 (void)setegid((Gid_t)PL_egid);
2511 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2513 #ifdef HAS_SETRESGID
2514 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2516 if (PL_egid == PL_gid) /* special case $) = $( */
2517 (void)PerlProc_setgid(PL_egid);
2519 PL_egid = PerlProc_getegid();
2520 Perl_croak(aTHX_ "setegid() not implemented");
2525 PL_egid = PerlProc_getegid();
2526 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2529 PL_chopset = SvPV_force(sv,len);
2531 #ifndef MACOS_TRADITIONAL
2533 LOCK_DOLLARZERO_MUTEX;
2534 #ifdef HAS_SETPROCTITLE
2535 /* The BSDs don't show the argv[] in ps(1) output, they
2536 * show a string from the process struct and provide
2537 * the setproctitle() routine to manipulate that. */
2539 s = SvPV_const(sv, len);
2540 # if __FreeBSD_version > 410001
2541 /* The leading "-" removes the "perl: " prefix,
2542 * but not the "(perl) suffix from the ps(1)
2543 * output, because that's what ps(1) shows if the
2544 * argv[] is modified. */
2545 setproctitle("-%s", s);
2546 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2547 /* This doesn't really work if you assume that
2548 * $0 = 'foobar'; will wipe out 'perl' from the $0
2549 * because in ps(1) output the result will be like
2550 * sprintf("perl: %s (perl)", s)
2551 * I guess this is a security feature:
2552 * one (a user process) cannot get rid of the original name.
2554 setproctitle("%s", s);
2558 #if defined(__hpux) && defined(PSTAT_SETCMD)
2561 s = SvPV_const(sv, len);
2562 un.pst_command = (char *)s;
2563 pstat(PSTAT_SETCMD, un, len, 0, 0);
2566 /* PL_origalen is set in perl_parse(). */
2567 s = SvPV_force(sv,len);
2568 if (len >= (STRLEN)PL_origalen-1) {
2569 /* Longer than original, will be truncated. We assume that
2570 * PL_origalen bytes are available. */
2571 Copy(s, PL_origargv[0], PL_origalen-1, char);
2574 /* Shorter than original, will be padded. */
2575 Copy(s, PL_origargv[0], len, char);
2576 PL_origargv[0][len] = 0;
2577 memset(PL_origargv[0] + len + 1,
2578 /* Is the space counterintuitive? Yes.
2579 * (You were expecting \0?)
2580 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2583 PL_origalen - len - 1);
2585 PL_origargv[0][PL_origalen-1] = 0;
2586 for (i = 1; i < PL_origargc; i++)
2588 UNLOCK_DOLLARZERO_MUTEX;
2596 Perl_whichsig(pTHX_ const char *sig)
2598 register char* const* sigv;
2600 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2601 if (strEQ(sig,*sigv))
2602 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2604 if (strEQ(sig,"CHLD"))
2608 if (strEQ(sig,"CLD"))
2615 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2616 Perl_sighandler(int sig, ...)
2618 Perl_sighandler(int sig)
2621 #ifdef PERL_GET_SIG_CONTEXT
2622 dTHXa(PERL_GET_SIG_CONTEXT);
2629 SV * const tSv = PL_Sv;
2633 XPV * const tXpv = PL_Xpv;
2635 if (PL_savestack_ix + 15 <= PL_savestack_max)
2637 if (PL_markstack_ptr < PL_markstack_max - 2)
2639 if (PL_scopestack_ix < PL_scopestack_max - 3)
2642 if (!PL_psig_ptr[sig]) {
2643 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2648 /* Max number of items pushed there is 3*n or 4. We cannot fix
2649 infinity, so we fix 4 (in fact 5): */
2651 PL_savestack_ix += 5; /* Protect save in progress. */
2652 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2655 PL_markstack_ptr++; /* Protect mark. */
2657 PL_scopestack_ix += 1;
2658 /* sv_2cv is too complicated, try a simpler variant first: */
2659 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2660 || SvTYPE(cv) != SVt_PVCV) {
2662 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2665 if (!cv || !CvROOT(cv)) {
2666 if (ckWARN(WARN_SIGNAL))
2667 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2668 PL_sig_name[sig], (gv ? GvENAME(gv)
2675 if(PL_psig_name[sig]) {
2676 sv = SvREFCNT_inc(PL_psig_name[sig]);
2678 #if !defined(PERL_IMPLICIT_CONTEXT)
2682 sv = sv_newmortal();
2683 sv_setpv(sv,PL_sig_name[sig]);
2686 PUSHSTACKi(PERLSI_SIGNAL);
2689 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2691 struct sigaction oact;
2693 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2697 va_start(args, sig);
2698 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2701 SV *rv = newRV_noinc((SV*)sih);
2702 /* The siginfo fields signo, code, errno, pid, uid,
2703 * addr, status, and band are defined by POSIX/SUSv3. */
2704 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2705 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2706 #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. */
2707 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2708 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2709 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2710 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2711 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2712 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2716 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2725 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2728 if (SvTRUE(ERRSV)) {
2730 #ifdef HAS_SIGPROCMASK
2731 /* Handler "died", for example to get out of a restart-able read().
2732 * Before we re-do that on its behalf re-enable the signal which was
2733 * blocked by the system when we entered.
2737 sigaddset(&set,sig);
2738 sigprocmask(SIG_UNBLOCK, &set, NULL);
2740 /* Not clear if this will work */
2741 (void)rsignal(sig, SIG_IGN);
2742 (void)rsignal(sig, PL_csighandlerp);
2744 #endif /* !PERL_MICRO */
2745 Perl_die(aTHX_ Nullch);
2749 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2753 PL_scopestack_ix -= 1;
2756 PL_op = myop; /* Apparently not needed... */
2758 PL_Sv = tSv; /* Restore global temporaries. */
2765 S_restore_magic(pTHX_ const void *p)
2767 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2768 SV* const sv = mgs->mgs_sv;
2773 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2775 #ifdef PERL_OLD_COPY_ON_WRITE
2776 /* While magic was saved (and off) sv_setsv may well have seen
2777 this SV as a prime candidate for COW. */
2779 sv_force_normal_flags(sv, 0);
2783 SvFLAGS(sv) |= mgs->mgs_flags;
2786 if (SvGMAGICAL(sv)) {
2787 /* downgrade public flags to private,
2788 and discard any other private flags */
2790 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2792 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2793 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2798 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2800 /* If we're still on top of the stack, pop us off. (That condition
2801 * will be satisfied if restore_magic was called explicitly, but *not*
2802 * if it's being called via leave_scope.)
2803 * The reason for doing this is that otherwise, things like sv_2cv()
2804 * may leave alloc gunk on the savestack, and some code
2805 * (e.g. sighandler) doesn't expect that...
2807 if (PL_savestack_ix == mgs->mgs_ss_ix)
2809 I32 popval = SSPOPINT;
2810 assert(popval == SAVEt_DESTRUCTOR_X);
2811 PL_savestack_ix -= 2;
2813 assert(popval == SAVEt_ALLOC);
2815 PL_savestack_ix -= popval;
2821 S_unwind_handler_stack(pTHX_ const void *p)
2824 const U32 flags = *(const U32*)p;
2827 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2828 /* cxstack_ix-- Not needed, die already unwound it. */
2829 #if !defined(PERL_IMPLICIT_CONTEXT)
2831 SvREFCNT_dec(PL_sig_sv);
2837 * c-indentation-style: bsd
2839 * indent-tabs-mode: t
2842 * ex: set ts=8 sts=4 sw=4 noet: