3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
118 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
119 const MGVTBL* const vtbl = mg->mg_virtual;
121 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
125 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
134 Do magic after a value is retrieved from the SV. See C<sv_magic>.
140 Perl_mg_get(pTHX_ SV *sv)
143 const I32 mgs_ix = SSNEW(sizeof(MGS));
144 const bool was_temp = (bool)SvTEMP(sv);
146 MAGIC *newmg, *head, *cur, *mg;
147 /* guard against sv having being freed midway by holding a private
150 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
151 cause the SV's buffer to get stolen (and maybe other stuff).
154 sv_2mortal(SvREFCNT_inc(sv));
159 save_magic(mgs_ix, sv);
161 /* We must call svt_get(sv, mg) for each valid entry in the linked
162 list of magic. svt_get() may delete the current entry, add new
163 magic to the head of the list, or upgrade the SV. AMS 20010810 */
165 newmg = cur = head = mg = SvMAGIC(sv);
167 const MGVTBL * const vtbl = mg->mg_virtual;
169 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
170 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
172 /* guard against magic having been deleted - eg FETCH calling
177 /* Don't restore the flags for this entry if it was deleted. */
178 if (mg->mg_flags & MGf_GSKIP)
179 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
182 mg = mg->mg_moremagic;
185 /* Have we finished with the new entries we saw? Start again
186 where we left off (unless there are more new entries). */
194 /* Were any new entries added? */
195 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
202 restore_magic(INT2PTR(void *, (IV)mgs_ix));
204 if (SvREFCNT(sv) == 1) {
205 /* We hold the last reference to this SV, which implies that the
206 SV was deleted as a side effect of the routines we called. */
215 Do magic after a value is assigned to the SV. See C<sv_magic>.
221 Perl_mg_set(pTHX_ SV *sv)
224 const I32 mgs_ix = SSNEW(sizeof(MGS));
228 save_magic(mgs_ix, sv);
230 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
231 const MGVTBL* vtbl = mg->mg_virtual;
232 nextmg = mg->mg_moremagic; /* it may delete itself */
233 if (mg->mg_flags & MGf_GSKIP) {
234 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
235 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
237 if (vtbl && vtbl->svt_set)
238 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
241 restore_magic(INT2PTR(void*, (IV)mgs_ix));
246 =for apidoc mg_length
248 Report on the SV's length. See C<sv_magic>.
254 Perl_mg_length(pTHX_ SV *sv)
260 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
261 const MGVTBL * const vtbl = mg->mg_virtual;
262 if (vtbl && vtbl->svt_len) {
263 const I32 mgs_ix = SSNEW(sizeof(MGS));
264 save_magic(mgs_ix, sv);
265 /* omit MGf_GSKIP -- not changed here */
266 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
267 restore_magic(INT2PTR(void*, (IV)mgs_ix));
273 const U8 *s = (U8*)SvPV_const(sv, len);
274 len = Perl_utf8_length(aTHX_ s, s + len);
277 (void)SvPV_const(sv, len);
282 Perl_mg_size(pTHX_ SV *sv)
286 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
287 const MGVTBL* const vtbl = mg->mg_virtual;
288 if (vtbl && vtbl->svt_len) {
289 const I32 mgs_ix = SSNEW(sizeof(MGS));
291 save_magic(mgs_ix, sv);
292 /* omit MGf_GSKIP -- not changed here */
293 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
294 restore_magic(INT2PTR(void*, (IV)mgs_ix));
301 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
305 Perl_croak(aTHX_ "Size magic not implemented");
314 Clear something magical that the SV represents. See C<sv_magic>.
320 Perl_mg_clear(pTHX_ SV *sv)
322 const I32 mgs_ix = SSNEW(sizeof(MGS));
325 save_magic(mgs_ix, sv);
327 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
328 const MGVTBL* const vtbl = mg->mg_virtual;
329 /* omit GSKIP -- never set here */
331 if (vtbl && vtbl->svt_clear)
332 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
335 restore_magic(INT2PTR(void*, (IV)mgs_ix));
342 Finds the magic pointer for type matching the SV. See C<sv_magic>.
348 Perl_mg_find(pTHX_ const SV *sv, int type)
352 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
353 if (mg->mg_type == type)
363 Copies the magic from one SV to another. See C<sv_magic>.
369 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
373 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
374 const MGVTBL* const vtbl = mg->mg_virtual;
375 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
376 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
379 const char type = mg->mg_type;
382 (type == PERL_MAGIC_tied)
384 : (type == PERL_MAGIC_regdata && mg->mg_obj)
387 toLOWER(type), key, klen);
396 =for apidoc mg_localize
398 Copy some of the magic from an existing SV to new localized version of
399 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
400 doesn't (eg taint, pos).
406 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
410 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
411 MGVTBL* const vtbl = mg->mg_virtual;
412 switch (mg->mg_type) {
413 /* value magic types: don't copy */
416 case PERL_MAGIC_regex_global:
417 case PERL_MAGIC_nkeys:
418 #ifdef USE_LOCALE_COLLATE
419 case PERL_MAGIC_collxfrm:
422 case PERL_MAGIC_taint:
424 case PERL_MAGIC_vstring:
425 case PERL_MAGIC_utf8:
426 case PERL_MAGIC_substr:
427 case PERL_MAGIC_defelem:
428 case PERL_MAGIC_arylen:
430 case PERL_MAGIC_backref:
431 case PERL_MAGIC_arylen_p:
432 case PERL_MAGIC_rhash:
433 case PERL_MAGIC_symtab:
437 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
438 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
440 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
441 mg->mg_ptr, mg->mg_len);
443 /* container types should remain read-only across localization */
444 SvFLAGS(nsv) |= SvREADONLY(sv);
447 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
448 SvFLAGS(nsv) |= SvMAGICAL(sv);
458 Free any magic storage used by the SV. See C<sv_magic>.
464 Perl_mg_free(pTHX_ SV *sv)
468 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
469 const MGVTBL* const vtbl = mg->mg_virtual;
470 moremagic = mg->mg_moremagic;
471 if (vtbl && vtbl->svt_free)
472 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
473 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
474 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
475 Safefree(mg->mg_ptr);
476 else if (mg->mg_len == HEf_SVKEY)
477 SvREFCNT_dec((SV*)mg->mg_ptr);
479 if (mg->mg_flags & MGf_REFCOUNTED)
480 SvREFCNT_dec(mg->mg_obj);
483 SvMAGIC_set(sv, NULL);
490 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
496 register const REGEXP * const rx = PM_GETRE(PL_curpm);
499 ? rx->nparens /* @+ */
500 : rx->lastparen; /* @- */
508 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
512 register const REGEXP * const rx = PM_GETRE(PL_curpm);
514 register const I32 paren = mg->mg_len;
519 if (paren <= (I32)rx->nparens &&
520 (s = rx->startp[paren]) != -1 &&
521 (t = rx->endp[paren]) != -1)
524 if (mg->mg_obj) /* @+ */
529 if (i > 0 && RX_MATCH_UTF8(rx)) {
530 const char * const b = rx->subbeg;
532 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
543 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
545 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
546 Perl_croak(aTHX_ PL_no_modify);
547 NORETURN_FUNCTION_END;
551 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
556 register const REGEXP *rx;
559 switch (*mg->mg_ptr) {
560 case '1': case '2': case '3': case '4':
561 case '5': case '6': case '7': case '8': case '9': case '&':
562 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
564 paren = atoi(mg->mg_ptr); /* $& is in [0] */
566 if (paren <= (I32)rx->nparens &&
567 (s1 = rx->startp[paren]) != -1 &&
568 (t1 = rx->endp[paren]) != -1)
572 if (i > 0 && RX_MATCH_UTF8(rx)) {
573 const char * const s = rx->subbeg + s1;
578 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
582 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
586 if (ckWARN(WARN_UNINITIALIZED))
591 if (ckWARN(WARN_UNINITIALIZED))
596 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
597 paren = rx->lastparen;
602 case '\016': /* ^N */
603 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
604 paren = rx->lastcloseparen;
610 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
611 if (rx->startp[0] != -1) {
622 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
623 if (rx->endp[0] != -1) {
624 i = rx->sublen - rx->endp[0];
635 if (!SvPOK(sv) && SvNIOK(sv)) {
643 #define SvRTRIM(sv) STMT_START { \
645 STRLEN len = SvCUR(sv); \
646 char * const p = SvPVX(sv); \
647 while (len > 0 && isSPACE(p[len-1])) \
649 SvCUR_set(sv, len); \
655 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
659 register char *s = NULL;
662 const char * const remaining = mg->mg_ptr + 1;
663 const char nextchar = *remaining;
665 switch (*mg->mg_ptr) {
666 case '\001': /* ^A */
667 sv_setsv(sv, PL_bodytarget);
669 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
670 if (nextchar == '\0') {
671 sv_setiv(sv, (IV)PL_minus_c);
673 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
674 sv_setiv(sv, (IV)STATUS_NATIVE);
678 case '\004': /* ^D */
679 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
681 case '\005': /* ^E */
682 if (nextchar == '\0') {
683 #if defined(MACOS_TRADITIONAL)
687 sv_setnv(sv,(double)gMacPerl_OSErr);
688 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
692 # include <descrip.h>
693 # include <starlet.h>
695 $DESCRIPTOR(msgdsc,msg);
696 sv_setnv(sv,(NV) vaxc$errno);
697 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
698 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
703 if (!(_emx_env & 0x200)) { /* Under DOS */
704 sv_setnv(sv, (NV)errno);
705 sv_setpv(sv, errno ? Strerror(errno) : "");
707 if (errno != errno_isOS2) {
708 const int tmp = _syserrno();
709 if (tmp) /* 2nd call to _syserrno() makes it 0 */
712 sv_setnv(sv, (NV)Perl_rc);
713 sv_setpv(sv, os2error(Perl_rc));
717 DWORD dwErr = GetLastError();
718 sv_setnv(sv, (NV)dwErr);
720 PerlProc_GetOSError(sv, dwErr);
723 sv_setpvn(sv, "", 0);
728 const int saveerrno = errno;
729 sv_setnv(sv, (NV)errno);
730 sv_setpv(sv, errno ? Strerror(errno) : "");
735 SvNOK_on(sv); /* what a wonderful hack! */
737 else if (strEQ(remaining, "NCODING"))
738 sv_setsv(sv, PL_encoding);
740 case '\006': /* ^F */
741 sv_setiv(sv, (IV)PL_maxsysfd);
743 case '\010': /* ^H */
744 sv_setiv(sv, (IV)PL_hints);
746 case '\011': /* ^I */ /* NOT \t in EBCDIC */
748 sv_setpv(sv, PL_inplace);
750 sv_setsv(sv, &PL_sv_undef);
752 case '\017': /* ^O & ^OPEN */
753 if (nextchar == '\0') {
754 sv_setpv(sv, PL_osname);
757 else if (strEQ(remaining, "PEN")) {
758 if (!PL_compiling.cop_io)
759 sv_setsv(sv, &PL_sv_undef);
761 sv_setsv(sv, PL_compiling.cop_io);
765 case '\020': /* ^P */
766 sv_setiv(sv, (IV)PL_perldb);
768 case '\023': /* ^S */
769 if (nextchar == '\0') {
770 if (PL_lex_state != LEX_NOTPARSING)
773 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
778 case '\024': /* ^T */
779 if (nextchar == '\0') {
781 sv_setnv(sv, PL_basetime);
783 sv_setiv(sv, (IV)PL_basetime);
786 else if (strEQ(remaining, "AINT"))
787 sv_setiv(sv, PL_tainting
788 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
791 case '\025': /* $^UNICODE, $^UTF8LOCALE */
792 if (strEQ(remaining, "NICODE"))
793 sv_setuv(sv, (UV) PL_unicode);
794 else if (strEQ(remaining, "TF8LOCALE"))
795 sv_setuv(sv, (UV) PL_utf8locale);
797 case '\027': /* ^W & $^WARNING_BITS */
798 if (nextchar == '\0')
799 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
800 else if (strEQ(remaining, "ARNING_BITS")) {
801 if (PL_compiling.cop_warnings == pWARN_NONE) {
802 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
804 else if (PL_compiling.cop_warnings == pWARN_STD) {
807 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
811 else if (PL_compiling.cop_warnings == pWARN_ALL) {
812 /* Get the bit mask for $warnings::Bits{all}, because
813 * it could have been extended by warnings::register */
815 HV * const bits=get_hv("warnings::Bits", FALSE);
816 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
817 sv_setsv(sv, *bits_all);
820 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
824 sv_setsv(sv, PL_compiling.cop_warnings);
829 case '1': case '2': case '3': case '4':
830 case '5': case '6': case '7': case '8': case '9': case '&':
831 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
835 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
836 * XXX Does the new way break anything?
838 paren = atoi(mg->mg_ptr); /* $& is in [0] */
840 if (paren <= (I32)rx->nparens &&
841 (s1 = rx->startp[paren]) != -1 &&
842 (t1 = rx->endp[paren]) != -1)
850 const int oldtainted = PL_tainted;
853 PL_tainted = oldtainted;
854 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
859 if (RX_MATCH_TAINTED(rx)) {
860 MAGIC* const mg = SvMAGIC(sv);
863 SvMAGIC_set(sv, mg->mg_moremagic);
865 if ((mgt = SvMAGIC(sv))) {
866 mg->mg_moremagic = mgt;
876 sv_setsv(sv,&PL_sv_undef);
879 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
880 paren = rx->lastparen;
884 sv_setsv(sv,&PL_sv_undef);
886 case '\016': /* ^N */
887 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
888 paren = rx->lastcloseparen;
892 sv_setsv(sv,&PL_sv_undef);
895 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
896 if ((s = rx->subbeg) && rx->startp[0] != -1) {
901 sv_setsv(sv,&PL_sv_undef);
904 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
905 if (rx->subbeg && rx->endp[0] != -1) {
906 s = rx->subbeg + rx->endp[0];
907 i = rx->sublen - rx->endp[0];
911 sv_setsv(sv,&PL_sv_undef);
914 if (GvIO(PL_last_in_gv)) {
915 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
920 sv_setiv(sv, (IV)STATUS_CURRENT);
921 #ifdef COMPLEX_STATUS
922 LvTARGOFF(sv) = PL_statusvalue;
923 LvTARGLEN(sv) = PL_statusvalue_vms;
928 if (GvIOp(PL_defoutgv))
929 s = IoTOP_NAME(GvIOp(PL_defoutgv));
933 sv_setpv(sv,GvENAME(PL_defoutgv));
938 if (GvIOp(PL_defoutgv))
939 s = IoFMT_NAME(GvIOp(PL_defoutgv));
941 s = GvENAME(PL_defoutgv);
945 if (GvIOp(PL_defoutgv))
946 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
949 if (GvIOp(PL_defoutgv))
950 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
953 if (GvIOp(PL_defoutgv))
954 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
961 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
964 if (GvIOp(PL_defoutgv))
965 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
971 sv_copypv(sv, PL_ors_sv);
975 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
976 sv_setpv(sv, errno ? Strerror(errno) : "");
979 const int saveerrno = errno;
980 sv_setnv(sv, (NV)errno);
982 if (errno == errno_isOS2 || errno == errno_isOS2_set)
983 sv_setpv(sv, os2error(Perl_rc));
986 sv_setpv(sv, errno ? Strerror(errno) : "");
991 SvNOK_on(sv); /* what a wonderful hack! */
994 sv_setiv(sv, (IV)PL_uid);
997 sv_setiv(sv, (IV)PL_euid);
1000 sv_setiv(sv, (IV)PL_gid);
1003 sv_setiv(sv, (IV)PL_egid);
1005 #ifdef HAS_GETGROUPS
1007 Groups_t *gary = NULL;
1008 I32 i, num_groups = getgroups(0, gary);
1009 Newx(gary, num_groups, Groups_t);
1010 num_groups = getgroups(num_groups, gary);
1011 for (i = 0; i < num_groups; i++)
1012 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1015 (void)SvIOK_on(sv); /* what a wonderful hack! */
1018 #ifndef MACOS_TRADITIONAL
1027 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1029 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1031 if (uf && uf->uf_val)
1032 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1037 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1041 const char *s = SvPV_const(sv,len);
1042 const char * const 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? */
1049 SV ** const 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, ':')) != NULL)
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),NULL);
1122 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 PERL_UNUSED_ARG(mg);
1127 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1129 if (PL_localizing) {
1132 hv_iterinit((HV*)sv);
1133 while ((entry = hv_iternext((HV*)sv))) {
1135 my_setenv(hv_iterkey(entry, &keylen),
1136 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1144 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1147 PERL_UNUSED_ARG(sv);
1148 PERL_UNUSED_ARG(mg);
1150 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1158 #ifdef HAS_SIGPROCMASK
1160 restore_sigmask(pTHX_ SV *save_sv)
1162 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1163 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1167 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1170 /* Are we fetching a signal entry? */
1171 const I32 i = whichsig(MgPV_nolen_const(mg));
1174 sv_setsv(sv,PL_psig_ptr[i]);
1176 Sighandler_t sigstate;
1177 sigstate = rsignal_state(i);
1178 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1179 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1181 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1182 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1184 /* cache state so we don't fetch it again */
1185 if(sigstate == (Sighandler_t) SIG_IGN)
1186 sv_setpv(sv,"IGNORE");
1188 sv_setsv(sv,&PL_sv_undef);
1189 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1196 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1198 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1199 * refactoring might be in order.
1202 register const char * const s = MgPV_nolen_const(mg);
1203 PERL_UNUSED_ARG(sv);
1206 if (strEQ(s,"__DIE__"))
1208 else if (strEQ(s,"__WARN__"))
1211 Perl_croak(aTHX_ "No such hook: %s", s);
1213 SV * const to_dec = *svp;
1215 SvREFCNT_dec(to_dec);
1219 /* Are we clearing a signal entry? */
1220 const I32 i = whichsig(s);
1222 #ifdef HAS_SIGPROCMASK
1225 /* Avoid having the signal arrive at a bad time, if possible. */
1228 sigprocmask(SIG_BLOCK, &set, &save);
1230 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1231 SAVEFREESV(save_sv);
1232 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1235 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1236 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1238 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1239 PL_sig_defaulting[i] = 1;
1240 (void)rsignal(i, PL_csighandlerp);
1242 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1244 if(PL_psig_name[i]) {
1245 SvREFCNT_dec(PL_psig_name[i]);
1248 if(PL_psig_ptr[i]) {
1249 SV * const to_dec=PL_psig_ptr[i];
1252 SvREFCNT_dec(to_dec);
1262 S_raise_signal(pTHX_ int sig)
1265 /* Set a flag to say this signal is pending */
1266 PL_psig_pend[sig]++;
1267 /* And one to say _a_ signal is pending */
1272 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1273 Perl_csighandler(int sig, ...)
1275 Perl_csighandler(int sig)
1278 #ifdef PERL_GET_SIG_CONTEXT
1279 dTHXa(PERL_GET_SIG_CONTEXT);
1283 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1284 (void) rsignal(sig, PL_csighandlerp);
1285 if (PL_sig_ignoring[sig]) return;
1287 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1288 if (PL_sig_defaulting[sig])
1289 #ifdef KILL_BY_SIGPRC
1290 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1295 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1296 /* Call the perl level handler now--
1297 * with risk we may be in malloc() etc. */
1298 (*PL_sighandlerp)(sig);
1300 S_raise_signal(aTHX_ sig);
1303 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1305 Perl_csighandler_init(void)
1308 if (PL_sig_handlers_initted) return;
1310 for (sig = 1; sig < SIG_SIZE; sig++) {
1311 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313 PL_sig_defaulting[sig] = 1;
1314 (void) rsignal(sig, PL_csighandlerp);
1316 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1317 PL_sig_ignoring[sig] = 0;
1320 PL_sig_handlers_initted = 1;
1325 Perl_despatch_signals(pTHX)
1330 for (sig = 1; sig < SIG_SIZE; sig++) {
1331 if (PL_psig_pend[sig]) {
1332 PERL_BLOCKSIG_ADD(set, sig);
1333 PL_psig_pend[sig] = 0;
1334 PERL_BLOCKSIG_BLOCK(set);
1335 (*PL_sighandlerp)(sig);
1336 PERL_BLOCKSIG_UNBLOCK(set);
1342 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1347 /* Need to be careful with SvREFCNT_dec(), because that can have side
1348 * effects (due to closures). We must make sure that the new disposition
1349 * is in place before it is called.
1353 #ifdef HAS_SIGPROCMASK
1358 register const char *s = MgPV_const(mg,len);
1360 if (strEQ(s,"__DIE__"))
1362 else if (strEQ(s,"__WARN__"))
1365 Perl_croak(aTHX_ "No such hook: %s", s);
1373 i = whichsig(s); /* ...no, a brick */
1375 if (ckWARN(WARN_SIGNAL))
1376 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1379 #ifdef HAS_SIGPROCMASK
1380 /* Avoid having the signal arrive at a bad time, if possible. */
1383 sigprocmask(SIG_BLOCK, &set, &save);
1385 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1386 SAVEFREESV(save_sv);
1387 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1390 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1391 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1393 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1394 PL_sig_ignoring[i] = 0;
1396 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1397 PL_sig_defaulting[i] = 0;
1399 SvREFCNT_dec(PL_psig_name[i]);
1400 to_dec = PL_psig_ptr[i];
1401 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1402 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1403 PL_psig_name[i] = newSVpvn(s, len);
1404 SvREADONLY_on(PL_psig_name[i]);
1406 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1408 (void)rsignal(i, PL_csighandlerp);
1409 #ifdef HAS_SIGPROCMASK
1414 *svp = SvREFCNT_inc(sv);
1416 SvREFCNT_dec(to_dec);
1419 s = SvPV_force(sv,len);
1420 if (strEQ(s,"IGNORE")) {
1422 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1423 PL_sig_ignoring[i] = 1;
1424 (void)rsignal(i, PL_csighandlerp);
1426 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1430 else if (strEQ(s,"DEFAULT") || !*s) {
1432 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1434 PL_sig_defaulting[i] = 1;
1435 (void)rsignal(i, PL_csighandlerp);
1438 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1443 * We should warn if HINT_STRICT_REFS, but without
1444 * access to a known hint bit in a known OP, we can't
1445 * tell whether HINT_STRICT_REFS is in force or not.
1447 if (!strchr(s,':') && !strchr(s,'\''))
1448 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1450 (void)rsignal(i, PL_csighandlerp);
1452 *svp = SvREFCNT_inc(sv);
1454 #ifdef HAS_SIGPROCMASK
1459 SvREFCNT_dec(to_dec);
1462 #endif /* !PERL_MICRO */
1465 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1468 PERL_UNUSED_ARG(sv);
1469 PERL_UNUSED_ARG(mg);
1470 PL_sub_generation++;
1475 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_UNUSED_ARG(sv);
1479 PERL_UNUSED_ARG(mg);
1480 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1481 PL_amagic_generation++;
1487 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1489 HV * const hv = (HV*)LvTARG(sv);
1491 PERL_UNUSED_ARG(mg);
1494 (void) hv_iterinit(hv);
1495 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1498 while (hv_iternext(hv))
1503 sv_setiv(sv, (IV)i);
1508 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1510 PERL_UNUSED_ARG(mg);
1512 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1517 /* caller is responsible for stack switching/cleanup */
1519 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1526 PUSHs(SvTIED_obj(sv, mg));
1529 if (mg->mg_len >= 0)
1530 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1531 else if (mg->mg_len == HEf_SVKEY)
1532 PUSHs((SV*)mg->mg_ptr);
1534 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1535 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1543 return call_method(meth, flags);
1547 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1553 PUSHSTACKi(PERLSI_MAGIC);
1555 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1556 sv_setsv(sv, *PL_stack_sp--);
1566 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1569 mg->mg_flags |= MGf_GSKIP;
1570 magic_methpack(sv,mg,"FETCH");
1575 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1579 PUSHSTACKi(PERLSI_MAGIC);
1580 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1587 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1589 return magic_methpack(sv,mg,"DELETE");
1594 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1601 PUSHSTACKi(PERLSI_MAGIC);
1602 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1603 sv = *PL_stack_sp--;
1604 retval = (U32) SvIV(sv)-1;
1613 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1618 PUSHSTACKi(PERLSI_MAGIC);
1620 XPUSHs(SvTIED_obj(sv, mg));
1622 call_method("CLEAR", G_SCALAR|G_DISCARD);
1630 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1633 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1637 PUSHSTACKi(PERLSI_MAGIC);
1640 PUSHs(SvTIED_obj(sv, mg));
1645 if (call_method(meth, G_SCALAR))
1646 sv_setsv(key, *PL_stack_sp--);
1655 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1657 return magic_methpack(sv,mg,"EXISTS");
1661 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1664 SV *retval = &PL_sv_undef;
1665 SV * const tied = SvTIED_obj((SV*)hv, mg);
1666 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1668 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1670 if (HvEITER_get(hv))
1671 /* we are in an iteration so the hash cannot be empty */
1673 /* no xhv_eiter so now use FIRSTKEY */
1674 key = sv_newmortal();
1675 magic_nextpack((SV*)hv, mg, key);
1676 HvEITER_set(hv, NULL); /* need to reset iterator */
1677 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1680 /* there is a SCALAR method that we can call */
1682 PUSHSTACKi(PERLSI_MAGIC);
1688 if (call_method("SCALAR", G_SCALAR))
1689 retval = *PL_stack_sp--;
1696 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1699 GV * const gv = PL_DBline;
1700 const I32 i = SvTRUE(sv);
1701 SV ** const svp = av_fetch(GvAV(gv),
1702 atoi(MgPV_nolen_const(mg)), FALSE);
1703 if (svp && SvIOKp(*svp)) {
1704 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1706 /* set or clear breakpoint in the relevant control op */
1708 o->op_flags |= OPf_SPECIAL;
1710 o->op_flags &= ~OPf_SPECIAL;
1717 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1720 const AV * const obj = (AV*)mg->mg_obj;
1722 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1730 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1733 AV * const obj = (AV*)mg->mg_obj;
1735 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1737 if (ckWARN(WARN_MISC))
1738 Perl_warner(aTHX_ packWARN(WARN_MISC),
1739 "Attempt to set length of freed array");
1745 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1748 PERL_UNUSED_ARG(sv);
1749 /* during global destruction, mg_obj may already have been freed */
1750 if (PL_in_clean_all)
1753 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1756 /* arylen scalar holds a pointer back to the array, but doesn't own a
1757 reference. Hence the we (the array) are about to go away with it
1758 still pointing at us. Clear its pointer, else it would be pointing
1759 at free memory. See the comment in sv_magic about reference loops,
1760 and why it can't own a reference to us. */
1767 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1770 SV* const lsv = LvTARG(sv);
1772 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1773 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1774 if (mg && mg->mg_len >= 0) {
1777 sv_pos_b2u(lsv, &i);
1778 sv_setiv(sv, i + PL_curcop->cop_arybase);
1787 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1790 SV* const lsv = LvTARG(sv);
1797 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1798 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1802 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1803 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1805 else if (!SvOK(sv)) {
1809 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1811 pos = SvIV(sv) - PL_curcop->cop_arybase;
1814 ulen = sv_len_utf8(lsv);
1824 else if (pos > (SSize_t)len)
1829 sv_pos_u2b(lsv, &p, 0);
1834 mg->mg_flags &= ~MGf_MINMATCH;
1840 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1843 PERL_UNUSED_ARG(mg);
1847 if (SvFLAGS(sv) & SVp_SCREAM
1848 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1849 /* We're actually already a typeglob, so don't need the stuff below.
1853 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1858 GvGP(sv) = gp_ref(GvGP(gv));
1863 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1866 SV * const lsv = LvTARG(sv);
1867 const char * const tmps = SvPV_const(lsv,len);
1868 I32 offs = LvTARGOFF(sv);
1869 I32 rem = LvTARGLEN(sv);
1870 PERL_UNUSED_ARG(mg);
1873 sv_pos_u2b(lsv, &offs, &rem);
1874 if (offs > (I32)len)
1876 if (rem + offs > (I32)len)
1878 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1885 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1889 const char *tmps = SvPV_const(sv, len);
1890 SV * const lsv = LvTARG(sv);
1891 I32 lvoff = LvTARGOFF(sv);
1892 I32 lvlen = LvTARGLEN(sv);
1893 PERL_UNUSED_ARG(mg);
1896 sv_utf8_upgrade(lsv);
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 sv_insert(lsv, lvoff, lvlen, tmps, len);
1899 LvTARGLEN(sv) = sv_len_utf8(sv);
1902 else if (lsv && SvUTF8(lsv)) {
1903 sv_pos_u2b(lsv, &lvoff, &lvlen);
1904 LvTARGLEN(sv) = len;
1905 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1910 sv_insert(lsv, lvoff, lvlen, tmps, len);
1911 LvTARGLEN(sv) = len;
1919 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1922 PERL_UNUSED_ARG(sv);
1923 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1928 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_UNUSED_ARG(sv);
1932 /* update taint status unless we're restoring at scope exit */
1933 if (PL_localizing != 2) {
1943 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1945 SV * const lsv = LvTARG(sv);
1946 PERL_UNUSED_ARG(mg);
1949 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1957 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1959 PERL_UNUSED_ARG(mg);
1960 do_vecset(sv); /* XXX slurp this routine */
1965 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1969 if (LvTARGLEN(sv)) {
1971 SV * const ahv = LvTARG(sv);
1972 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1977 AV* const av = (AV*)LvTARG(sv);
1978 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1979 targ = AvARRAY(av)[LvTARGOFF(sv)];
1981 if (targ && targ != &PL_sv_undef) {
1982 /* somebody else defined it for us */
1983 SvREFCNT_dec(LvTARG(sv));
1984 LvTARG(sv) = SvREFCNT_inc(targ);
1986 SvREFCNT_dec(mg->mg_obj);
1988 mg->mg_flags &= ~MGf_REFCOUNTED;
1993 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1998 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2000 PERL_UNUSED_ARG(mg);
2004 sv_setsv(LvTARG(sv), sv);
2005 SvSETMAGIC(LvTARG(sv));
2011 Perl_vivify_defelem(pTHX_ SV *sv)
2017 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2020 SV * const ahv = LvTARG(sv);
2021 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2024 if (!value || value == &PL_sv_undef)
2025 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2028 AV* const av = (AV*)LvTARG(sv);
2029 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2030 LvTARG(sv) = NULL; /* array can't be extended */
2032 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2033 if (!svp || (value = *svp) == &PL_sv_undef)
2034 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2037 (void)SvREFCNT_inc(value);
2038 SvREFCNT_dec(LvTARG(sv));
2041 SvREFCNT_dec(mg->mg_obj);
2043 mg->mg_flags &= ~MGf_REFCOUNTED;
2047 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2049 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2053 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2061 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2063 PERL_UNUSED_ARG(mg);
2064 sv_unmagic(sv, PERL_MAGIC_bm);
2070 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2072 PERL_UNUSED_ARG(mg);
2073 sv_unmagic(sv, PERL_MAGIC_fm);
2079 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2081 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2083 if (uf && uf->uf_set)
2084 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2089 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2091 PERL_UNUSED_ARG(mg);
2092 sv_unmagic(sv, PERL_MAGIC_qr);
2097 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2100 regexp * const re = (regexp *)mg->mg_obj;
2101 PERL_UNUSED_ARG(sv);
2107 #ifdef USE_LOCALE_COLLATE
2109 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2112 * RenE<eacute> Descartes said "I think not."
2113 * and vanished with a faint plop.
2115 PERL_UNUSED_ARG(sv);
2117 Safefree(mg->mg_ptr);
2123 #endif /* USE_LOCALE_COLLATE */
2125 /* Just clear the UTF-8 cache data. */
2127 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2129 PERL_UNUSED_ARG(sv);
2130 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2132 mg->mg_len = -1; /* The mg_len holds the len cache. */
2137 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2140 register const char *s;
2143 switch (*mg->mg_ptr) {
2144 case '\001': /* ^A */
2145 sv_setsv(PL_bodytarget, sv);
2147 case '\003': /* ^C */
2148 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2151 case '\004': /* ^D */
2153 s = SvPV_nolen_const(sv);
2154 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2155 DEBUG_x(dump_all());
2157 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2160 case '\005': /* ^E */
2161 if (*(mg->mg_ptr+1) == '\0') {
2162 #ifdef MACOS_TRADITIONAL
2163 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2166 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2169 SetLastError( SvIV(sv) );
2172 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2174 /* will anyone ever use this? */
2175 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2181 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2183 SvREFCNT_dec(PL_encoding);
2184 if (SvOK(sv) || SvGMAGICAL(sv)) {
2185 PL_encoding = newSVsv(sv);
2192 case '\006': /* ^F */
2193 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2195 case '\010': /* ^H */
2196 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2198 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2199 Safefree(PL_inplace);
2200 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2202 case '\017': /* ^O */
2203 if (*(mg->mg_ptr+1) == '\0') {
2204 Safefree(PL_osname);
2207 TAINT_PROPER("assigning to $^O");
2208 PL_osname = savesvpv(sv);
2211 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2212 if (!PL_compiling.cop_io)
2213 PL_compiling.cop_io = newSVsv(sv);
2215 sv_setsv(PL_compiling.cop_io,sv);
2218 case '\020': /* ^P */
2219 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2220 if (PL_perldb && !PL_DBsingle)
2223 case '\024': /* ^T */
2225 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2227 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2230 case '\027': /* ^W & $^WARNING_BITS */
2231 if (*(mg->mg_ptr+1) == '\0') {
2232 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2233 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2234 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2235 | (i ? G_WARN_ON : G_WARN_OFF) ;
2238 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2239 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2240 if (!SvPOK(sv) && PL_localizing) {
2241 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2242 PL_compiling.cop_warnings = pWARN_NONE;
2247 int accumulate = 0 ;
2248 int any_fatals = 0 ;
2249 const char * const ptr = SvPV_const(sv, len) ;
2250 for (i = 0 ; i < len ; ++i) {
2251 accumulate |= ptr[i] ;
2252 any_fatals |= (ptr[i] & 0xAA) ;
2255 PL_compiling.cop_warnings = pWARN_NONE;
2256 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2257 PL_compiling.cop_warnings = pWARN_ALL;
2258 PL_dowarn |= G_WARN_ONCE ;
2261 if (specialWARN(PL_compiling.cop_warnings))
2262 PL_compiling.cop_warnings = newSVsv(sv) ;
2264 sv_setsv(PL_compiling.cop_warnings, sv);
2265 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2266 PL_dowarn |= G_WARN_ONCE ;
2274 if (PL_localizing) {
2275 if (PL_localizing == 1)
2276 SAVESPTR(PL_last_in_gv);
2278 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2279 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2282 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2283 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2284 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2287 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2288 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2289 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2292 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2295 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2296 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2297 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2300 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2304 IO * const io = GvIOp(PL_defoutgv);
2307 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2308 IoFLAGS(io) &= ~IOf_FLUSH;
2310 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2311 PerlIO *ofp = IoOFP(io);
2313 (void)PerlIO_flush(ofp);
2314 IoFLAGS(io) |= IOf_FLUSH;
2320 SvREFCNT_dec(PL_rs);
2321 PL_rs = newSVsv(sv);
2325 SvREFCNT_dec(PL_ors_sv);
2326 if (SvOK(sv) || SvGMAGICAL(sv)) {
2327 PL_ors_sv = newSVsv(sv);
2335 SvREFCNT_dec(PL_ofs_sv);
2336 if (SvOK(sv) || SvGMAGICAL(sv)) {
2337 PL_ofs_sv = newSVsv(sv);
2344 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2347 #ifdef COMPLEX_STATUS
2348 if (PL_localizing == 2) {
2349 PL_statusvalue = LvTARGOFF(sv);
2350 PL_statusvalue_vms = LvTARGLEN(sv);
2354 #ifdef VMSISH_STATUS
2356 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2359 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2364 # define PERL_VMS_BANG vaxc$errno
2366 # define PERL_VMS_BANG 0
2368 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2369 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2373 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2374 if (PL_delaymagic) {
2375 PL_delaymagic |= DM_RUID;
2376 break; /* don't do magic till later */
2379 (void)setruid((Uid_t)PL_uid);
2382 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2384 #ifdef HAS_SETRESUID
2385 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2387 if (PL_uid == PL_euid) { /* special case $< = $> */
2389 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2390 if (PL_uid != 0 && PerlProc_getuid() == 0)
2391 (void)PerlProc_setuid(0);
2393 (void)PerlProc_setuid(PL_uid);
2395 PL_uid = PerlProc_getuid();
2396 Perl_croak(aTHX_ "setruid() not implemented");
2401 PL_uid = PerlProc_getuid();
2402 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2405 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2406 if (PL_delaymagic) {
2407 PL_delaymagic |= DM_EUID;
2408 break; /* don't do magic till later */
2411 (void)seteuid((Uid_t)PL_euid);
2414 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2416 #ifdef HAS_SETRESUID
2417 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2419 if (PL_euid == PL_uid) /* special case $> = $< */
2420 PerlProc_setuid(PL_euid);
2422 PL_euid = PerlProc_geteuid();
2423 Perl_croak(aTHX_ "seteuid() not implemented");
2428 PL_euid = PerlProc_geteuid();
2429 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2432 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2433 if (PL_delaymagic) {
2434 PL_delaymagic |= DM_RGID;
2435 break; /* don't do magic till later */
2438 (void)setrgid((Gid_t)PL_gid);
2441 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2443 #ifdef HAS_SETRESGID
2444 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2446 if (PL_gid == PL_egid) /* special case $( = $) */
2447 (void)PerlProc_setgid(PL_gid);
2449 PL_gid = PerlProc_getgid();
2450 Perl_croak(aTHX_ "setrgid() not implemented");
2455 PL_gid = PerlProc_getgid();
2456 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2459 #ifdef HAS_SETGROUPS
2461 const char *p = SvPV_const(sv, len);
2462 Groups_t *gary = NULL;
2467 for (i = 0; i < NGROUPS; ++i) {
2468 while (*p && !isSPACE(*p))
2475 Newx(gary, i + 1, Groups_t);
2477 Renew(gary, i + 1, Groups_t);
2481 (void)setgroups(i, gary);
2485 #else /* HAS_SETGROUPS */
2486 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2487 #endif /* HAS_SETGROUPS */
2488 if (PL_delaymagic) {
2489 PL_delaymagic |= DM_EGID;
2490 break; /* don't do magic till later */
2493 (void)setegid((Gid_t)PL_egid);
2496 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2498 #ifdef HAS_SETRESGID
2499 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2501 if (PL_egid == PL_gid) /* special case $) = $( */
2502 (void)PerlProc_setgid(PL_egid);
2504 PL_egid = PerlProc_getegid();
2505 Perl_croak(aTHX_ "setegid() not implemented");
2510 PL_egid = PerlProc_getegid();
2511 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2514 PL_chopset = SvPV_force(sv,len);
2516 #ifndef MACOS_TRADITIONAL
2518 LOCK_DOLLARZERO_MUTEX;
2519 #ifdef HAS_SETPROCTITLE
2520 /* The BSDs don't show the argv[] in ps(1) output, they
2521 * show a string from the process struct and provide
2522 * the setproctitle() routine to manipulate that. */
2523 if (PL_origalen != 1) {
2524 s = SvPV_const(sv, len);
2525 # if __FreeBSD_version > 410001
2526 /* The leading "-" removes the "perl: " prefix,
2527 * but not the "(perl) suffix from the ps(1)
2528 * output, because that's what ps(1) shows if the
2529 * argv[] is modified. */
2530 setproctitle("-%s", s);
2531 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2532 /* This doesn't really work if you assume that
2533 * $0 = 'foobar'; will wipe out 'perl' from the $0
2534 * because in ps(1) output the result will be like
2535 * sprintf("perl: %s (perl)", s)
2536 * I guess this is a security feature:
2537 * one (a user process) cannot get rid of the original name.
2539 setproctitle("%s", s);
2543 #if defined(__hpux) && defined(PSTAT_SETCMD)
2544 if (PL_origalen != 1) {
2546 s = SvPV_const(sv, len);
2547 un.pst_command = (char *)s;
2548 pstat(PSTAT_SETCMD, un, len, 0, 0);
2551 if (PL_origalen > 1) {
2552 /* PL_origalen is set in perl_parse(). */
2553 s = SvPV_force(sv,len);
2554 if (len >= (STRLEN)PL_origalen-1) {
2555 /* Longer than original, will be truncated. We assume that
2556 * PL_origalen bytes are available. */
2557 Copy(s, PL_origargv[0], PL_origalen-1, char);
2560 /* Shorter than original, will be padded. */
2561 Copy(s, PL_origargv[0], len, char);
2562 PL_origargv[0][len] = 0;
2563 memset(PL_origargv[0] + len + 1,
2564 /* Is the space counterintuitive? Yes.
2565 * (You were expecting \0?)
2566 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2569 PL_origalen - len - 1);
2571 PL_origargv[0][PL_origalen-1] = 0;
2572 for (i = 1; i < PL_origargc; i++)
2575 UNLOCK_DOLLARZERO_MUTEX;
2583 Perl_whichsig(pTHX_ const char *sig)
2585 register char* const* sigv;
2587 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2588 if (strEQ(sig,*sigv))
2589 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2591 if (strEQ(sig,"CHLD"))
2595 if (strEQ(sig,"CLD"))
2602 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2603 Perl_sighandler(int sig, ...)
2605 Perl_sighandler(int sig)
2608 #ifdef PERL_GET_SIG_CONTEXT
2609 dTHXa(PERL_GET_SIG_CONTEXT);
2616 SV * const tSv = PL_Sv;
2620 XPV * const tXpv = PL_Xpv;
2622 if (PL_savestack_ix + 15 <= PL_savestack_max)
2624 if (PL_markstack_ptr < PL_markstack_max - 2)
2626 if (PL_scopestack_ix < PL_scopestack_max - 3)
2629 if (!PL_psig_ptr[sig]) {
2630 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2635 /* Max number of items pushed there is 3*n or 4. We cannot fix
2636 infinity, so we fix 4 (in fact 5): */
2638 PL_savestack_ix += 5; /* Protect save in progress. */
2639 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2642 PL_markstack_ptr++; /* Protect mark. */
2644 PL_scopestack_ix += 1;
2645 /* sv_2cv is too complicated, try a simpler variant first: */
2646 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2647 || SvTYPE(cv) != SVt_PVCV) {
2649 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2652 if (!cv || !CvROOT(cv)) {
2653 if (ckWARN(WARN_SIGNAL))
2654 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2655 PL_sig_name[sig], (gv ? GvENAME(gv)
2662 if(PL_psig_name[sig]) {
2663 sv = SvREFCNT_inc(PL_psig_name[sig]);
2665 #if !defined(PERL_IMPLICIT_CONTEXT)
2669 sv = sv_newmortal();
2670 sv_setpv(sv,PL_sig_name[sig]);
2673 PUSHSTACKi(PERLSI_SIGNAL);
2676 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2678 struct sigaction oact;
2680 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2684 va_start(args, sig);
2685 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2688 SV *rv = newRV_noinc((SV*)sih);
2689 /* The siginfo fields signo, code, errno, pid, uid,
2690 * addr, status, and band are defined by POSIX/SUSv3. */
2691 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2692 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2693 #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. */
2694 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2695 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2696 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2697 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2698 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2699 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2703 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2712 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2715 if (SvTRUE(ERRSV)) {
2717 #ifdef HAS_SIGPROCMASK
2718 /* Handler "died", for example to get out of a restart-able read().
2719 * Before we re-do that on its behalf re-enable the signal which was
2720 * blocked by the system when we entered.
2724 sigaddset(&set,sig);
2725 sigprocmask(SIG_UNBLOCK, &set, NULL);
2727 /* Not clear if this will work */
2728 (void)rsignal(sig, SIG_IGN);
2729 (void)rsignal(sig, PL_csighandlerp);
2731 #endif /* !PERL_MICRO */
2732 Perl_die(aTHX_ NULL);
2736 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2740 PL_scopestack_ix -= 1;
2743 PL_op = myop; /* Apparently not needed... */
2745 PL_Sv = tSv; /* Restore global temporaries. */
2752 S_restore_magic(pTHX_ const void *p)
2755 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2756 SV* const sv = mgs->mgs_sv;
2761 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2763 #ifdef PERL_OLD_COPY_ON_WRITE
2764 /* While magic was saved (and off) sv_setsv may well have seen
2765 this SV as a prime candidate for COW. */
2767 sv_force_normal_flags(sv, 0);
2771 SvFLAGS(sv) |= mgs->mgs_flags;
2774 if (SvGMAGICAL(sv)) {
2775 /* downgrade public flags to private,
2776 and discard any other private flags */
2778 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2780 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2781 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2786 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2788 /* If we're still on top of the stack, pop us off. (That condition
2789 * will be satisfied if restore_magic was called explicitly, but *not*
2790 * if it's being called via leave_scope.)
2791 * The reason for doing this is that otherwise, things like sv_2cv()
2792 * may leave alloc gunk on the savestack, and some code
2793 * (e.g. sighandler) doesn't expect that...
2795 if (PL_savestack_ix == mgs->mgs_ss_ix)
2797 I32 popval = SSPOPINT;
2798 assert(popval == SAVEt_DESTRUCTOR_X);
2799 PL_savestack_ix -= 2;
2801 assert(popval == SAVEt_ALLOC);
2803 PL_savestack_ix -= popval;
2809 S_unwind_handler_stack(pTHX_ const void *p)
2812 const U32 flags = *(const U32*)p;
2815 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2816 #if !defined(PERL_IMPLICIT_CONTEXT)
2818 SvREFCNT_dec(PL_sig_sv);
2824 * c-indentation-style: bsd
2826 * indent-tabs-mode: t
2829 * ex: set ts=8 sts=4 sw=4 noet: