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 Signal_t Perl_csighandler(int sig);
58 /* Missing protos on LynxOS */
59 void setruid(uid_t id);
60 void seteuid(uid_t id);
61 void setrgid(uid_t id);
62 void setegid(uid_t id);
66 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
74 /* MGS is typedef'ed to struct magic_state in perl.h */
77 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
80 assert(SvMAGICAL(sv));
81 #ifdef PERL_OLD_COPY_ON_WRITE
82 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
87 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
89 mgs = SSPTR(mgs_ix, MGS*);
91 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
92 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
96 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
100 =for apidoc mg_magical
102 Turns on the magical status of an SV. See C<sv_magic>.
108 Perl_mg_magical(pTHX_ SV *sv)
111 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
112 const MGVTBL* const vtbl = mg->mg_virtual;
114 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
118 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
127 Do magic after a value is retrieved from the SV. See C<sv_magic>.
133 Perl_mg_get(pTHX_ SV *sv)
135 const I32 mgs_ix = SSNEW(sizeof(MGS));
136 const bool was_temp = (bool)SvTEMP(sv);
138 MAGIC *newmg, *head, *cur, *mg;
139 /* guard against sv having being freed midway by holding a private
142 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
143 cause the SV's buffer to get stolen (and maybe other stuff).
146 sv_2mortal(SvREFCNT_inc(sv));
151 save_magic(mgs_ix, sv);
153 /* We must call svt_get(sv, mg) for each valid entry in the linked
154 list of magic. svt_get() may delete the current entry, add new
155 magic to the head of the list, or upgrade the SV. AMS 20010810 */
157 newmg = cur = head = mg = SvMAGIC(sv);
159 const MGVTBL * const vtbl = mg->mg_virtual;
161 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
162 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
164 /* guard against magic having been deleted - eg FETCH calling
169 /* Don't restore the flags for this entry if it was deleted. */
170 if (mg->mg_flags & MGf_GSKIP)
171 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
174 mg = mg->mg_moremagic;
177 /* Have we finished with the new entries we saw? Start again
178 where we left off (unless there are more new entries). */
186 /* Were any new entries added? */
187 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
194 restore_magic(INT2PTR(void *, (IV)mgs_ix));
196 if (SvREFCNT(sv) == 1) {
197 /* We hold the last reference to this SV, which implies that the
198 SV was deleted as a side effect of the routines we called. */
207 Do magic after a value is assigned to the SV. See C<sv_magic>.
213 Perl_mg_set(pTHX_ SV *sv)
215 const I32 mgs_ix = SSNEW(sizeof(MGS));
219 save_magic(mgs_ix, sv);
221 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
222 const MGVTBL* vtbl = mg->mg_virtual;
223 nextmg = mg->mg_moremagic; /* it may delete itself */
224 if (mg->mg_flags & MGf_GSKIP) {
225 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
226 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
228 if (vtbl && vtbl->svt_set)
229 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
232 restore_magic(INT2PTR(void*, (IV)mgs_ix));
237 =for apidoc mg_length
239 Report on the SV's length. See C<sv_magic>.
245 Perl_mg_length(pTHX_ SV *sv)
250 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
251 const MGVTBL * const vtbl = mg->mg_virtual;
252 if (vtbl && vtbl->svt_len) {
253 const I32 mgs_ix = SSNEW(sizeof(MGS));
254 save_magic(mgs_ix, sv);
255 /* omit MGf_GSKIP -- not changed here */
256 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
257 restore_magic(INT2PTR(void*, (IV)mgs_ix));
263 const U8 *s = (U8*)SvPV_const(sv, len);
264 len = Perl_utf8_length(aTHX_ s, s + len);
267 (void)SvPV_const(sv, len);
272 Perl_mg_size(pTHX_ SV *sv)
276 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
277 const MGVTBL* const vtbl = mg->mg_virtual;
278 if (vtbl && vtbl->svt_len) {
279 const I32 mgs_ix = SSNEW(sizeof(MGS));
281 save_magic(mgs_ix, sv);
282 /* omit MGf_GSKIP -- not changed here */
283 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
284 restore_magic(INT2PTR(void*, (IV)mgs_ix));
291 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
295 Perl_croak(aTHX_ "Size magic not implemented");
304 Clear something magical that the SV represents. See C<sv_magic>.
310 Perl_mg_clear(pTHX_ SV *sv)
312 const I32 mgs_ix = SSNEW(sizeof(MGS));
315 save_magic(mgs_ix, sv);
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 const MGVTBL* const vtbl = mg->mg_virtual;
319 /* omit GSKIP -- never set here */
321 if (vtbl && vtbl->svt_clear)
322 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
325 restore_magic(INT2PTR(void*, (IV)mgs_ix));
332 Finds the magic pointer for type matching the SV. See C<sv_magic>.
338 Perl_mg_find(pTHX_ const SV *sv, int type)
342 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
343 if (mg->mg_type == type)
353 Copies the magic from one SV to another. See C<sv_magic>.
359 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
363 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
364 const MGVTBL* const vtbl = mg->mg_virtual;
365 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
366 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
368 else if (isUPPER(mg->mg_type)) {
370 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
371 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
373 toLOWER(mg->mg_type), key, klen);
381 =for apidoc mg_localize
383 Copy some of the magic from an existing SV to new localized version of
384 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
385 doesn't (eg taint, pos).
391 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
394 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
395 const MGVTBL* const vtbl = mg->mg_virtual;
396 switch (mg->mg_type) {
397 /* value magic types: don't copy */
400 case PERL_MAGIC_regex_global:
401 case PERL_MAGIC_nkeys:
402 #ifdef USE_LOCALE_COLLATE
403 case PERL_MAGIC_collxfrm:
406 case PERL_MAGIC_taint:
408 case PERL_MAGIC_vstring:
409 case PERL_MAGIC_utf8:
410 case PERL_MAGIC_substr:
411 case PERL_MAGIC_defelem:
412 case PERL_MAGIC_arylen:
414 case PERL_MAGIC_backref:
415 case PERL_MAGIC_arylen_p:
416 case PERL_MAGIC_rhash:
417 case PERL_MAGIC_symtab:
421 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
422 /* XXX calling the copy method is probably not correct. DAPM */
423 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
424 mg->mg_ptr, mg->mg_len);
427 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
428 mg->mg_ptr, mg->mg_len);
430 /* container types should remain read-only across localization */
431 SvFLAGS(nsv) |= SvREADONLY(sv);
434 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
435 SvFLAGS(nsv) |= SvMAGICAL(sv);
445 Free any magic storage used by the SV. See C<sv_magic>.
451 Perl_mg_free(pTHX_ SV *sv)
455 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
456 const MGVTBL* const vtbl = mg->mg_virtual;
457 moremagic = mg->mg_moremagic;
458 if (vtbl && vtbl->svt_free)
459 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
460 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
461 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
462 Safefree(mg->mg_ptr);
463 else if (mg->mg_len == HEf_SVKEY)
464 SvREFCNT_dec((SV*)mg->mg_ptr);
466 if (mg->mg_flags & MGf_REFCOUNTED)
467 SvREFCNT_dec(mg->mg_obj);
470 SvMAGIC_set(sv, NULL);
477 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
479 register const REGEXP *rx;
482 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
483 if (mg->mg_obj) /* @+ */
486 return rx->lastparen;
493 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
497 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
498 register const I32 paren = mg->mg_len;
503 if (paren <= (I32)rx->nparens &&
504 (s = rx->startp[paren]) != -1 &&
505 (t = rx->endp[paren]) != -1)
508 if (mg->mg_obj) /* @+ */
513 if (i > 0 && RX_MATCH_UTF8(rx)) {
514 const char * const b = rx->subbeg;
516 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
526 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
528 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
529 Perl_croak(aTHX_ PL_no_modify);
530 NORETURN_FUNCTION_END;
534 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
538 register const REGEXP *rx;
541 switch (*mg->mg_ptr) {
542 case '1': case '2': case '3': case '4':
543 case '5': case '6': case '7': case '8': case '9': case '&':
544 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
546 paren = atoi(mg->mg_ptr); /* $& is in [0] */
548 if (paren <= (I32)rx->nparens &&
549 (s1 = rx->startp[paren]) != -1 &&
550 (t1 = rx->endp[paren]) != -1)
554 if (i > 0 && RX_MATCH_UTF8(rx)) {
555 const char * const s = rx->subbeg + s1;
560 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
564 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
568 if (ckWARN(WARN_UNINITIALIZED))
573 if (ckWARN(WARN_UNINITIALIZED))
578 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
579 paren = rx->lastparen;
584 case '\016': /* ^N */
585 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
586 paren = rx->lastcloseparen;
592 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 if (rx->startp[0] != -1) {
604 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
605 if (rx->endp[0] != -1) {
606 i = rx->sublen - rx->endp[0];
617 if (!SvPOK(sv) && SvNIOK(sv)) {
625 #define SvRTRIM(sv) STMT_START { \
626 STRLEN len = SvCUR(sv); \
627 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
629 SvCUR_set(sv, len); \
633 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
637 register char *s = NULL;
641 switch (*mg->mg_ptr) {
642 case '\001': /* ^A */
643 sv_setsv(sv, PL_bodytarget);
645 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
646 if (*(mg->mg_ptr+1) == '\0') {
647 sv_setiv(sv, (IV)PL_minus_c);
649 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
650 sv_setiv(sv, (IV)STATUS_NATIVE);
654 case '\004': /* ^D */
655 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
657 case '\005': /* ^E */
658 if (*(mg->mg_ptr+1) == '\0') {
659 #ifdef MACOS_TRADITIONAL
663 sv_setnv(sv,(double)gMacPerl_OSErr);
664 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
669 # include <descrip.h>
670 # include <starlet.h>
672 $DESCRIPTOR(msgdsc,msg);
673 sv_setnv(sv,(NV) vaxc$errno);
674 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
675 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
681 if (!(_emx_env & 0x200)) { /* Under DOS */
682 sv_setnv(sv, (NV)errno);
683 sv_setpv(sv, errno ? Strerror(errno) : "");
685 if (errno != errno_isOS2) {
686 int tmp = _syserrno();
687 if (tmp) /* 2nd call to _syserrno() makes it 0 */
690 sv_setnv(sv, (NV)Perl_rc);
691 sv_setpv(sv, os2error(Perl_rc));
696 DWORD dwErr = GetLastError();
697 sv_setnv(sv, (NV)dwErr);
700 PerlProc_GetOSError(sv, dwErr);
703 sv_setpvn(sv, "", 0);
708 const int saveerrno = errno;
709 sv_setnv(sv, (NV)errno);
710 sv_setpv(sv, errno ? Strerror(errno) : "");
718 SvNOK_on(sv); /* what a wonderful hack! */
720 else if (strEQ(mg->mg_ptr+1, "NCODING"))
721 sv_setsv(sv, PL_encoding);
723 case '\006': /* ^F */
724 sv_setiv(sv, (IV)PL_maxsysfd);
726 case '\010': /* ^H */
727 sv_setiv(sv, (IV)PL_hints);
729 case '\011': /* ^I */ /* NOT \t in EBCDIC */
731 sv_setpv(sv, PL_inplace);
733 sv_setsv(sv, &PL_sv_undef);
735 case '\017': /* ^O & ^OPEN */
736 if (*(mg->mg_ptr+1) == '\0') {
737 sv_setpv(sv, PL_osname);
740 else if (strEQ(mg->mg_ptr, "\017PEN")) {
741 if (!PL_compiling.cop_io)
742 sv_setsv(sv, &PL_sv_undef);
744 sv_setsv(sv, PL_compiling.cop_io);
748 case '\020': /* ^P */
749 sv_setiv(sv, (IV)PL_perldb);
751 case '\023': /* ^S */
752 if (*(mg->mg_ptr+1) == '\0') {
753 if (PL_lex_state != LEX_NOTPARSING)
756 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
761 case '\024': /* ^T */
762 if (*(mg->mg_ptr+1) == '\0') {
764 sv_setnv(sv, PL_basetime);
766 sv_setiv(sv, (IV)PL_basetime);
769 else if (strEQ(mg->mg_ptr, "\024AINT"))
770 sv_setiv(sv, PL_tainting
771 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
774 case '\025': /* $^UNICODE, $^UTF8LOCALE */
775 if (strEQ(mg->mg_ptr, "\025NICODE"))
776 sv_setuv(sv, (UV) PL_unicode);
777 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
778 sv_setuv(sv, (UV) PL_utf8locale);
780 case '\027': /* ^W & $^WARNING_BITS */
781 if (*(mg->mg_ptr+1) == '\0')
782 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
783 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
784 if (PL_compiling.cop_warnings == pWARN_NONE ||
785 PL_compiling.cop_warnings == pWARN_STD)
787 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
789 else if (PL_compiling.cop_warnings == pWARN_ALL) {
790 /* Get the bit mask for $warnings::Bits{all}, because
791 * it could have been extended by warnings::register */
793 HV *bits=get_hv("warnings::Bits", FALSE);
794 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
795 sv_setsv(sv, *bits_all);
798 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
802 sv_setsv(sv, PL_compiling.cop_warnings);
807 case '1': case '2': case '3': case '4':
808 case '5': case '6': case '7': case '8': case '9': case '&':
809 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
813 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
814 * XXX Does the new way break anything?
816 paren = atoi(mg->mg_ptr); /* $& is in [0] */
818 if (paren <= (I32)rx->nparens &&
819 (s1 = rx->startp[paren]) != -1 &&
820 (t1 = rx->endp[paren]) != -1)
830 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
835 if (RX_MATCH_TAINTED(rx)) {
836 MAGIC* mg = SvMAGIC(sv);
839 SvMAGIC_set(sv, mg->mg_moremagic);
841 if ((mgt = SvMAGIC(sv))) {
842 mg->mg_moremagic = mgt;
852 sv_setsv(sv,&PL_sv_undef);
855 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
856 paren = rx->lastparen;
860 sv_setsv(sv,&PL_sv_undef);
862 case '\016': /* ^N */
863 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
864 paren = rx->lastcloseparen;
868 sv_setsv(sv,&PL_sv_undef);
871 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
872 if ((s = rx->subbeg) && rx->startp[0] != -1) {
877 sv_setsv(sv,&PL_sv_undef);
880 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
881 if (rx->subbeg && rx->endp[0] != -1) {
882 s = rx->subbeg + rx->endp[0];
883 i = rx->sublen - rx->endp[0];
887 sv_setsv(sv,&PL_sv_undef);
890 if (GvIO(PL_last_in_gv)) {
891 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
896 sv_setiv(sv, (IV)STATUS_CURRENT);
897 #ifdef COMPLEX_STATUS
898 LvTARGOFF(sv) = PL_statusvalue;
899 LvTARGLEN(sv) = PL_statusvalue_vms;
904 if (GvIOp(PL_defoutgv))
905 s = IoTOP_NAME(GvIOp(PL_defoutgv));
909 sv_setpv(sv,GvENAME(PL_defoutgv));
914 if (GvIOp(PL_defoutgv))
915 s = IoFMT_NAME(GvIOp(PL_defoutgv));
917 s = GvENAME(PL_defoutgv);
921 if (GvIOp(PL_defoutgv))
922 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
925 if (GvIOp(PL_defoutgv))
926 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
929 if (GvIOp(PL_defoutgv))
930 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
937 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
940 if (GvIOp(PL_defoutgv))
941 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
947 sv_copypv(sv, PL_ors_sv);
951 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
952 sv_setpv(sv, errno ? Strerror(errno) : "");
955 const int saveerrno = errno;
956 sv_setnv(sv, (NV)errno);
958 if (errno == errno_isOS2 || errno == errno_isOS2_set)
959 sv_setpv(sv, os2error(Perl_rc));
962 sv_setpv(sv, errno ? Strerror(errno) : "");
967 SvNOK_on(sv); /* what a wonderful hack! */
970 sv_setiv(sv, (IV)PL_uid);
973 sv_setiv(sv, (IV)PL_euid);
976 sv_setiv(sv, (IV)PL_gid);
978 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
982 sv_setiv(sv, (IV)PL_egid);
984 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
989 Groups_t gary[NGROUPS];
990 I32 j = getgroups(NGROUPS,gary);
992 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
995 (void)SvIOK_on(sv); /* what a wonderful hack! */
997 #ifndef MACOS_TRADITIONAL
1006 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1008 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1010 if (uf && uf->uf_val)
1011 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1016 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1023 s = SvPV_const(sv,len);
1024 ptr = MgPV_const(mg,klen);
1027 #ifdef DYNAMIC_ENV_FETCH
1028 /* We just undefd an environment var. Is a replacement */
1029 /* waiting in the wings? */
1032 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1033 s = SvPV_const(*valp, len);
1037 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1038 /* And you'll never guess what the dog had */
1039 /* in its mouth... */
1041 MgTAINTEDDIR_off(mg);
1043 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1044 char pathbuf[256], eltbuf[256], *cp, *elt = s;
1048 do { /* DCL$PATH may be a search list */
1049 while (1) { /* as may dev portion of any element */
1050 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1051 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1052 cando_by_name(S_IWUSR,0,elt) ) {
1053 MgTAINTEDDIR_on(mg);
1057 if ((cp = strchr(elt, ':')) != Nullch)
1059 if (my_trnlnm(elt, eltbuf, j++))
1065 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1068 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1069 const char * const strend = s + len;
1071 while (s < strend) {
1075 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1076 s, strend, ':', &i);
1078 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1080 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1081 MgTAINTEDDIR_on(mg);
1087 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1093 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1095 PERL_UNUSED_ARG(sv);
1096 my_setenv(MgPV_nolen_const(mg),Nullch);
1101 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1103 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1104 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1106 if (PL_localizing) {
1108 magic_clear_all_env(sv,mg);
1109 hv_iterinit((HV*)sv);
1110 while ((entry = hv_iternext((HV*)sv))) {
1112 my_setenv(hv_iterkey(entry, &keylen),
1113 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1121 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1126 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1128 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1131 # ifdef USE_ENVIRON_ARRAY
1132 # if defined(USE_ITHREADS)
1133 /* only the parent thread can clobber the process environment */
1134 if (PL_curinterp == aTHX)
1137 # ifndef PERL_USE_SAFE_PUTENV
1138 if (!PL_use_safe_putenv) {
1141 if (environ == PL_origenviron)
1142 environ = (char**)safesysmalloc(sizeof(char*));
1144 for (i = 0; environ[i]; i++)
1145 safesysfree(environ[i]);
1147 # endif /* PERL_USE_SAFE_PUTENV */
1149 environ[0] = Nullch;
1151 # endif /* USE_ENVIRON_ARRAY */
1152 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1153 #endif /* VMS || EPOC */
1154 #endif /* !PERL_MICRO */
1155 PERL_UNUSED_ARG(sv);
1156 PERL_UNUSED_ARG(mg);
1161 #ifdef HAS_SIGPROCMASK
1163 restore_sigmask(pTHX_ SV *save_sv)
1165 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1166 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1170 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1172 /* Are we fetching a signal entry? */
1173 const I32 i = whichsig(MgPV_nolen_const(mg));
1176 sv_setsv(sv,PL_psig_ptr[i]);
1178 Sighandler_t sigstate;
1179 sigstate = rsignal_state(i);
1180 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1181 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1186 /* cache state so we don't fetch it again */
1187 if(sigstate == SIG_IGN)
1188 sv_setpv(sv,"IGNORE");
1190 sv_setsv(sv,&PL_sv_undef);
1191 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1198 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1200 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1201 * refactoring might be in order.
1204 register const char * const s = MgPV_nolen_const(mg);
1205 PERL_UNUSED_ARG(sv);
1208 if (strEQ(s,"__DIE__"))
1210 else if (strEQ(s,"__WARN__"))
1213 Perl_croak(aTHX_ "No such hook: %s", s);
1215 SV * const to_dec = *svp;
1217 SvREFCNT_dec(to_dec);
1221 /* Are we clearing a signal entry? */
1222 const I32 i = whichsig(s);
1224 #ifdef HAS_SIGPROCMASK
1227 /* Avoid having the signal arrive at a bad time, if possible. */
1230 sigprocmask(SIG_BLOCK, &set, &save);
1232 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1233 SAVEFREESV(save_sv);
1234 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1238 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1240 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1241 PL_sig_defaulting[i] = 1;
1242 (void)rsignal(i, PL_csighandlerp);
1244 (void)rsignal(i, SIG_DFL);
1246 if(PL_psig_name[i]) {
1247 SvREFCNT_dec(PL_psig_name[i]);
1250 if(PL_psig_ptr[i]) {
1251 SV *to_dec=PL_psig_ptr[i];
1254 SvREFCNT_dec(to_dec);
1264 S_raise_signal(pTHX_ int sig)
1266 /* Set a flag to say this signal is pending */
1267 PL_psig_pend[sig]++;
1268 /* And one to say _a_ signal is pending */
1273 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, 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, 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** 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);
2045 SV *const *const last = svp + AvFILLp(av);
2047 while (svp <= last) {
2049 SV *const referrer = *svp;
2050 if (SvWEAKREF(referrer)) {
2051 /* XXX Should we check that it hasn't changed? */
2052 SvRV_set(referrer, 0);
2054 SvWEAKREF_off(referrer);
2055 } else if (SvTYPE(referrer) == SVt_PVGV ||
2056 SvTYPE(referrer) == SVt_PVLV) {
2057 /* You lookin' at me? */
2058 assert(GvSTASH(referrer));
2059 assert(GvSTASH(referrer) == (HV*)sv);
2060 GvSTASH(referrer) = 0;
2063 "panic: magic_killbackrefs (flags=%"UVxf")",
2072 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2077 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2085 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2087 PERL_UNUSED_ARG(mg);
2088 sv_unmagic(sv, PERL_MAGIC_bm);
2094 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2096 PERL_UNUSED_ARG(mg);
2097 sv_unmagic(sv, PERL_MAGIC_fm);
2103 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2105 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2107 if (uf && uf->uf_set)
2108 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2113 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2115 PERL_UNUSED_ARG(mg);
2116 sv_unmagic(sv, PERL_MAGIC_qr);
2121 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2123 regexp * const re = (regexp *)mg->mg_obj;
2124 PERL_UNUSED_ARG(sv);
2130 #ifdef USE_LOCALE_COLLATE
2132 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2135 * RenE<eacute> Descartes said "I think not."
2136 * and vanished with a faint plop.
2138 PERL_UNUSED_ARG(sv);
2140 Safefree(mg->mg_ptr);
2146 #endif /* USE_LOCALE_COLLATE */
2148 /* Just clear the UTF-8 cache data. */
2150 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2152 PERL_UNUSED_ARG(sv);
2153 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2155 mg->mg_len = -1; /* The mg_len holds the len cache. */
2160 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2162 register const char *s;
2165 switch (*mg->mg_ptr) {
2166 case '\001': /* ^A */
2167 sv_setsv(PL_bodytarget, sv);
2169 case '\003': /* ^C */
2170 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2173 case '\004': /* ^D */
2175 s = SvPV_nolen_const(sv);
2176 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2177 DEBUG_x(dump_all());
2179 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2182 case '\005': /* ^E */
2183 if (*(mg->mg_ptr+1) == '\0') {
2184 #ifdef MACOS_TRADITIONAL
2185 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2188 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2191 SetLastError( SvIV(sv) );
2194 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2196 /* will anyone ever use this? */
2197 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2203 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2205 SvREFCNT_dec(PL_encoding);
2206 if (SvOK(sv) || SvGMAGICAL(sv)) {
2207 PL_encoding = newSVsv(sv);
2210 PL_encoding = Nullsv;
2214 case '\006': /* ^F */
2215 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2217 case '\010': /* ^H */
2218 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2220 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2221 Safefree(PL_inplace);
2222 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2224 case '\017': /* ^O */
2225 if (*(mg->mg_ptr+1) == '\0') {
2226 Safefree(PL_osname);
2229 TAINT_PROPER("assigning to $^O");
2230 PL_osname = savesvpv(sv);
2233 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2234 if (!PL_compiling.cop_io)
2235 PL_compiling.cop_io = newSVsv(sv);
2237 sv_setsv(PL_compiling.cop_io,sv);
2240 case '\020': /* ^P */
2241 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2242 if (PL_perldb && !PL_DBsingle)
2245 case '\024': /* ^T */
2247 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2249 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2252 case '\027': /* ^W & $^WARNING_BITS */
2253 if (*(mg->mg_ptr+1) == '\0') {
2254 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2255 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2256 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2257 | (i ? G_WARN_ON : G_WARN_OFF) ;
2260 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2261 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2262 if (!SvPOK(sv) && PL_localizing) {
2263 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2264 PL_compiling.cop_warnings = pWARN_NONE;
2269 int accumulate = 0 ;
2270 int any_fatals = 0 ;
2271 const char * const ptr = SvPV_const(sv, len) ;
2272 for (i = 0 ; i < len ; ++i) {
2273 accumulate |= ptr[i] ;
2274 any_fatals |= (ptr[i] & 0xAA) ;
2277 PL_compiling.cop_warnings = pWARN_NONE;
2278 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2279 PL_compiling.cop_warnings = pWARN_ALL;
2280 PL_dowarn |= G_WARN_ONCE ;
2283 if (specialWARN(PL_compiling.cop_warnings))
2284 PL_compiling.cop_warnings = newSVsv(sv) ;
2286 sv_setsv(PL_compiling.cop_warnings, sv);
2287 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2288 PL_dowarn |= G_WARN_ONCE ;
2296 if (PL_localizing) {
2297 if (PL_localizing == 1)
2298 SAVESPTR(PL_last_in_gv);
2300 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2301 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2304 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2305 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2306 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2309 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2310 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2311 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2314 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2317 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2318 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2319 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2322 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2326 IO * const io = GvIOp(PL_defoutgv);
2329 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2330 IoFLAGS(io) &= ~IOf_FLUSH;
2332 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2333 PerlIO *ofp = IoOFP(io);
2335 (void)PerlIO_flush(ofp);
2336 IoFLAGS(io) |= IOf_FLUSH;
2342 SvREFCNT_dec(PL_rs);
2343 PL_rs = newSVsv(sv);
2347 SvREFCNT_dec(PL_ors_sv);
2348 if (SvOK(sv) || SvGMAGICAL(sv)) {
2349 PL_ors_sv = newSVsv(sv);
2357 SvREFCNT_dec(PL_ofs_sv);
2358 if (SvOK(sv) || SvGMAGICAL(sv)) {
2359 PL_ofs_sv = newSVsv(sv);
2366 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2369 #ifdef COMPLEX_STATUS
2370 if (PL_localizing == 2) {
2371 PL_statusvalue = LvTARGOFF(sv);
2372 PL_statusvalue_vms = LvTARGLEN(sv);
2376 #ifdef VMSISH_STATUS
2378 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2381 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2386 # define PERL_VMS_BANG vaxc$errno
2388 # define PERL_VMS_BANG 0
2390 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2391 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2395 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2396 if (PL_delaymagic) {
2397 PL_delaymagic |= DM_RUID;
2398 break; /* don't do magic till later */
2401 (void)setruid((Uid_t)PL_uid);
2404 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2406 #ifdef HAS_SETRESUID
2407 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2409 if (PL_uid == PL_euid) { /* special case $< = $> */
2411 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2412 if (PL_uid != 0 && PerlProc_getuid() == 0)
2413 (void)PerlProc_setuid(0);
2415 (void)PerlProc_setuid(PL_uid);
2417 PL_uid = PerlProc_getuid();
2418 Perl_croak(aTHX_ "setruid() not implemented");
2423 PL_uid = PerlProc_getuid();
2424 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2427 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2428 if (PL_delaymagic) {
2429 PL_delaymagic |= DM_EUID;
2430 break; /* don't do magic till later */
2433 (void)seteuid((Uid_t)PL_euid);
2436 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2438 #ifdef HAS_SETRESUID
2439 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2441 if (PL_euid == PL_uid) /* special case $> = $< */
2442 PerlProc_setuid(PL_euid);
2444 PL_euid = PerlProc_geteuid();
2445 Perl_croak(aTHX_ "seteuid() not implemented");
2450 PL_euid = PerlProc_geteuid();
2451 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2454 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2455 if (PL_delaymagic) {
2456 PL_delaymagic |= DM_RGID;
2457 break; /* don't do magic till later */
2460 (void)setrgid((Gid_t)PL_gid);
2463 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2465 #ifdef HAS_SETRESGID
2466 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2468 if (PL_gid == PL_egid) /* special case $( = $) */
2469 (void)PerlProc_setgid(PL_gid);
2471 PL_gid = PerlProc_getgid();
2472 Perl_croak(aTHX_ "setrgid() not implemented");
2477 PL_gid = PerlProc_getgid();
2478 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2481 #ifdef HAS_SETGROUPS
2483 const char *p = SvPV_const(sv, len);
2484 Groups_t gary[NGROUPS];
2489 for (i = 0; i < NGROUPS; ++i) {
2490 while (*p && !isSPACE(*p))
2499 (void)setgroups(i, gary);
2501 #else /* HAS_SETGROUPS */
2502 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2503 #endif /* HAS_SETGROUPS */
2504 if (PL_delaymagic) {
2505 PL_delaymagic |= DM_EGID;
2506 break; /* don't do magic till later */
2509 (void)setegid((Gid_t)PL_egid);
2512 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2514 #ifdef HAS_SETRESGID
2515 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2517 if (PL_egid == PL_gid) /* special case $) = $( */
2518 (void)PerlProc_setgid(PL_egid);
2520 PL_egid = PerlProc_getegid();
2521 Perl_croak(aTHX_ "setegid() not implemented");
2526 PL_egid = PerlProc_getegid();
2527 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530 PL_chopset = SvPV_force(sv,len);
2532 #ifndef MACOS_TRADITIONAL
2534 LOCK_DOLLARZERO_MUTEX;
2535 #ifdef HAS_SETPROCTITLE
2536 /* The BSDs don't show the argv[] in ps(1) output, they
2537 * show a string from the process struct and provide
2538 * the setproctitle() routine to manipulate that. */
2540 s = SvPV_const(sv, len);
2541 # if __FreeBSD_version > 410001
2542 /* The leading "-" removes the "perl: " prefix,
2543 * but not the "(perl) suffix from the ps(1)
2544 * output, because that's what ps(1) shows if the
2545 * argv[] is modified. */
2546 setproctitle("-%s", s);
2547 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2548 /* This doesn't really work if you assume that
2549 * $0 = 'foobar'; will wipe out 'perl' from the $0
2550 * because in ps(1) output the result will be like
2551 * sprintf("perl: %s (perl)", s)
2552 * I guess this is a security feature:
2553 * one (a user process) cannot get rid of the original name.
2555 setproctitle("%s", s);
2559 #if defined(__hpux) && defined(PSTAT_SETCMD)
2562 s = SvPV_const(sv, len);
2563 un.pst_command = (char *)s;
2564 pstat(PSTAT_SETCMD, un, len, 0, 0);
2567 /* PL_origalen is set in perl_parse(). */
2568 s = SvPV_force(sv,len);
2569 if (len >= (STRLEN)PL_origalen-1) {
2570 /* Longer than original, will be truncated. We assume that
2571 * PL_origalen bytes are available. */
2572 Copy(s, PL_origargv[0], PL_origalen-1, char);
2575 /* Shorter than original, will be padded. */
2576 Copy(s, PL_origargv[0], len, char);
2577 PL_origargv[0][len] = 0;
2578 memset(PL_origargv[0] + len + 1,
2579 /* Is the space counterintuitive? Yes.
2580 * (You were expecting \0?)
2581 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2584 PL_origalen - len - 1);
2586 PL_origargv[0][PL_origalen-1] = 0;
2587 for (i = 1; i < PL_origargc; i++)
2589 UNLOCK_DOLLARZERO_MUTEX;
2597 Perl_whichsig(pTHX_ const char *sig)
2599 register char* const* sigv;
2601 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2602 if (strEQ(sig,*sigv))
2603 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2605 if (strEQ(sig,"CHLD"))
2609 if (strEQ(sig,"CLD"))
2616 Perl_sighandler(int sig)
2618 #ifdef PERL_GET_SIG_CONTEXT
2619 dTHXa(PERL_GET_SIG_CONTEXT);
2626 SV * const tSv = PL_Sv;
2630 XPV * const tXpv = PL_Xpv;
2632 if (PL_savestack_ix + 15 <= PL_savestack_max)
2634 if (PL_markstack_ptr < PL_markstack_max - 2)
2636 if (PL_scopestack_ix < PL_scopestack_max - 3)
2639 if (!PL_psig_ptr[sig]) {
2640 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2645 /* Max number of items pushed there is 3*n or 4. We cannot fix
2646 infinity, so we fix 4 (in fact 5): */
2648 PL_savestack_ix += 5; /* Protect save in progress. */
2649 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2652 PL_markstack_ptr++; /* Protect mark. */
2654 PL_scopestack_ix += 1;
2655 /* sv_2cv is too complicated, try a simpler variant first: */
2656 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2657 || SvTYPE(cv) != SVt_PVCV) {
2659 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2662 if (!cv || !CvROOT(cv)) {
2663 if (ckWARN(WARN_SIGNAL))
2664 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2665 PL_sig_name[sig], (gv ? GvENAME(gv)
2672 if(PL_psig_name[sig]) {
2673 sv = SvREFCNT_inc(PL_psig_name[sig]);
2675 #if !defined(PERL_IMPLICIT_CONTEXT)
2679 sv = sv_newmortal();
2680 sv_setpv(sv,PL_sig_name[sig]);
2683 PUSHSTACKi(PERLSI_SIGNAL);
2688 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2691 if (SvTRUE(ERRSV)) {
2693 #ifdef HAS_SIGPROCMASK
2694 /* Handler "died", for example to get out of a restart-able read().
2695 * Before we re-do that on its behalf re-enable the signal which was
2696 * blocked by the system when we entered.
2700 sigaddset(&set,sig);
2701 sigprocmask(SIG_UNBLOCK, &set, NULL);
2703 /* Not clear if this will work */
2704 (void)rsignal(sig, SIG_IGN);
2705 (void)rsignal(sig, PL_csighandlerp);
2707 #endif /* !PERL_MICRO */
2712 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2716 PL_scopestack_ix -= 1;
2719 PL_op = myop; /* Apparently not needed... */
2721 PL_Sv = tSv; /* Restore global temporaries. */
2728 S_restore_magic(pTHX_ const void *p)
2730 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2731 SV* const sv = mgs->mgs_sv;
2736 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2738 #ifdef PERL_OLD_COPY_ON_WRITE
2739 /* While magic was saved (and off) sv_setsv may well have seen
2740 this SV as a prime candidate for COW. */
2742 sv_force_normal(sv);
2746 SvFLAGS(sv) |= mgs->mgs_flags;
2750 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2753 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2755 /* If we're still on top of the stack, pop us off. (That condition
2756 * will be satisfied if restore_magic was called explicitly, but *not*
2757 * if it's being called via leave_scope.)
2758 * The reason for doing this is that otherwise, things like sv_2cv()
2759 * may leave alloc gunk on the savestack, and some code
2760 * (e.g. sighandler) doesn't expect that...
2762 if (PL_savestack_ix == mgs->mgs_ss_ix)
2764 I32 popval = SSPOPINT;
2765 assert(popval == SAVEt_DESTRUCTOR_X);
2766 PL_savestack_ix -= 2;
2768 assert(popval == SAVEt_ALLOC);
2770 PL_savestack_ix -= popval;
2776 S_unwind_handler_stack(pTHX_ const void *p)
2779 const U32 flags = *(const U32*)p;
2782 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2783 /* cxstack_ix-- Not needed, die already unwound it. */
2784 #if !defined(PERL_IMPLICIT_CONTEXT)
2786 SvREFCNT_dec(PL_sig_sv);
2792 * c-indentation-style: bsd
2794 * indent-tabs-mode: t
2797 * ex: set ts=8 sts=4 sw=4 noet: