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_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)
851 const int oldtainted = PL_tainted;
854 PL_tainted = oldtainted;
855 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
860 if (RX_MATCH_TAINTED(rx)) {
861 MAGIC* const mg = SvMAGIC(sv);
864 SvMAGIC_set(sv, mg->mg_moremagic);
866 if ((mgt = SvMAGIC(sv))) {
867 mg->mg_moremagic = mgt;
877 sv_setsv(sv,&PL_sv_undef);
880 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
881 paren = rx->lastparen;
885 sv_setsv(sv,&PL_sv_undef);
887 case '\016': /* ^N */
888 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
889 paren = rx->lastcloseparen;
893 sv_setsv(sv,&PL_sv_undef);
896 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
897 if ((s = rx->subbeg) && rx->startp[0] != -1) {
902 sv_setsv(sv,&PL_sv_undef);
905 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
906 if (rx->subbeg && rx->endp[0] != -1) {
907 s = rx->subbeg + rx->endp[0];
908 i = rx->sublen - rx->endp[0];
912 sv_setsv(sv,&PL_sv_undef);
915 if (GvIO(PL_last_in_gv)) {
916 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
921 sv_setiv(sv, (IV)STATUS_CURRENT);
922 #ifdef COMPLEX_STATUS
923 LvTARGOFF(sv) = PL_statusvalue;
924 LvTARGLEN(sv) = PL_statusvalue_vms;
929 if (GvIOp(PL_defoutgv))
930 s = IoTOP_NAME(GvIOp(PL_defoutgv));
934 sv_setpv(sv,GvENAME(PL_defoutgv));
939 if (GvIOp(PL_defoutgv))
940 s = IoFMT_NAME(GvIOp(PL_defoutgv));
942 s = GvENAME(PL_defoutgv);
946 if (GvIOp(PL_defoutgv))
947 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
950 if (GvIOp(PL_defoutgv))
951 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
954 if (GvIOp(PL_defoutgv))
955 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
962 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
965 if (GvIOp(PL_defoutgv))
966 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
972 sv_copypv(sv, PL_ors_sv);
976 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
977 sv_setpv(sv, errno ? Strerror(errno) : "");
980 const int saveerrno = errno;
981 sv_setnv(sv, (NV)errno);
983 if (errno == errno_isOS2 || errno == errno_isOS2_set)
984 sv_setpv(sv, os2error(Perl_rc));
987 sv_setpv(sv, errno ? Strerror(errno) : "");
992 SvNOK_on(sv); /* what a wonderful hack! */
995 sv_setiv(sv, (IV)PL_uid);
998 sv_setiv(sv, (IV)PL_euid);
1001 sv_setiv(sv, (IV)PL_gid);
1004 sv_setiv(sv, (IV)PL_egid);
1006 #ifdef HAS_GETGROUPS
1008 Groups_t *gary = NULL;
1009 I32 i, num_groups = getgroups(0, gary);
1010 Newx(gary, num_groups, Groups_t);
1011 num_groups = getgroups(num_groups, gary);
1012 for (i = 0; i < num_groups; i++)
1013 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1016 (void)SvIOK_on(sv); /* what a wonderful hack! */
1019 #ifndef MACOS_TRADITIONAL
1028 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1030 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1032 if (uf && uf->uf_val)
1033 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1038 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1042 const char *s = SvPV_const(sv,len);
1043 const char * const ptr = MgPV_const(mg,klen);
1046 #ifdef DYNAMIC_ENV_FETCH
1047 /* We just undefd an environment var. Is a replacement */
1048 /* waiting in the wings? */
1050 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1052 s = SvPV_const(*valp, len);
1056 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1057 /* And you'll never guess what the dog had */
1058 /* in its mouth... */
1060 MgTAINTEDDIR_off(mg);
1062 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1063 char pathbuf[256], eltbuf[256], *cp, *elt;
1067 strncpy(eltbuf, s, 255);
1070 do { /* DCL$PATH may be a search list */
1071 while (1) { /* as may dev portion of any element */
1072 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1073 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1074 cando_by_name(S_IWUSR,0,elt) ) {
1075 MgTAINTEDDIR_on(mg);
1079 if ((cp = strchr(elt, ':')) != Nullch)
1081 if (my_trnlnm(elt, eltbuf, j++))
1087 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1090 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1091 const char * const strend = s + len;
1093 while (s < strend) {
1097 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1098 s, strend, ':', &i);
1100 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1102 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1103 MgTAINTEDDIR_on(mg);
1109 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1115 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1117 PERL_UNUSED_ARG(sv);
1118 my_setenv(MgPV_nolen_const(mg),Nullch);
1123 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1126 PERL_UNUSED_ARG(mg);
1128 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1130 if (PL_localizing) {
1133 hv_iterinit((HV*)sv);
1134 while ((entry = hv_iternext((HV*)sv))) {
1136 my_setenv(hv_iterkey(entry, &keylen),
1137 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1145 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1148 PERL_UNUSED_ARG(sv);
1149 PERL_UNUSED_ARG(mg);
1151 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1159 #ifdef HAS_SIGPROCMASK
1161 restore_sigmask(pTHX_ SV *save_sv)
1163 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1164 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1168 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1171 /* Are we fetching a signal entry? */
1172 const I32 i = whichsig(MgPV_nolen_const(mg));
1175 sv_setsv(sv,PL_psig_ptr[i]);
1177 Sighandler_t sigstate;
1178 sigstate = rsignal_state(i);
1179 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1180 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1182 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1185 /* cache state so we don't fetch it again */
1186 if(sigstate == (Sighandler_t) SIG_IGN)
1187 sv_setpv(sv,"IGNORE");
1189 sv_setsv(sv,&PL_sv_undef);
1190 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1197 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1199 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1200 * refactoring might be in order.
1203 register const char * const s = MgPV_nolen_const(mg);
1204 PERL_UNUSED_ARG(sv);
1207 if (strEQ(s,"__DIE__"))
1209 else if (strEQ(s,"__WARN__"))
1212 Perl_croak(aTHX_ "No such hook: %s", s);
1214 SV * const to_dec = *svp;
1216 SvREFCNT_dec(to_dec);
1220 /* Are we clearing a signal entry? */
1221 const I32 i = whichsig(s);
1223 #ifdef HAS_SIGPROCMASK
1226 /* Avoid having the signal arrive at a bad time, if possible. */
1229 sigprocmask(SIG_BLOCK, &set, &save);
1231 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1232 SAVEFREESV(save_sv);
1233 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1236 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1237 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1239 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1240 PL_sig_defaulting[i] = 1;
1241 (void)rsignal(i, PL_csighandlerp);
1243 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1245 if(PL_psig_name[i]) {
1246 SvREFCNT_dec(PL_psig_name[i]);
1249 if(PL_psig_ptr[i]) {
1250 SV * const to_dec=PL_psig_ptr[i];
1253 SvREFCNT_dec(to_dec);
1263 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 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1274 Perl_csighandler(int sig, ...)
1276 Perl_csighandler(int sig)
1279 #ifdef PERL_GET_SIG_CONTEXT
1280 dTHXa(PERL_GET_SIG_CONTEXT);
1284 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1285 (void) rsignal(sig, PL_csighandlerp);
1286 if (PL_sig_ignoring[sig]) return;
1288 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1289 if (PL_sig_defaulting[sig])
1290 #ifdef KILL_BY_SIGPRC
1291 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1296 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1297 /* Call the perl level handler now--
1298 * with risk we may be in malloc() etc. */
1299 (*PL_sighandlerp)(sig);
1301 S_raise_signal(aTHX_ sig);
1304 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1306 Perl_csighandler_init(void)
1309 if (PL_sig_handlers_initted) return;
1311 for (sig = 1; sig < SIG_SIZE; sig++) {
1312 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1314 PL_sig_defaulting[sig] = 1;
1315 (void) rsignal(sig, PL_csighandlerp);
1317 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1318 PL_sig_ignoring[sig] = 0;
1321 PL_sig_handlers_initted = 1;
1326 Perl_despatch_signals(pTHX)
1331 for (sig = 1; sig < SIG_SIZE; sig++) {
1332 if (PL_psig_pend[sig]) {
1333 PERL_BLOCKSIG_ADD(set, sig);
1334 PL_psig_pend[sig] = 0;
1335 PERL_BLOCKSIG_BLOCK(set);
1336 (*PL_sighandlerp)(sig);
1337 PERL_BLOCKSIG_UNBLOCK(set);
1343 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1348 /* Need to be careful with SvREFCNT_dec(), because that can have side
1349 * effects (due to closures). We must make sure that the new disposition
1350 * is in place before it is called.
1354 #ifdef HAS_SIGPROCMASK
1359 register const char *s = MgPV_const(mg,len);
1361 if (strEQ(s,"__DIE__"))
1363 else if (strEQ(s,"__WARN__"))
1366 Perl_croak(aTHX_ "No such hook: %s", s);
1374 i = whichsig(s); /* ...no, a brick */
1376 if (ckWARN(WARN_SIGNAL))
1377 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1380 #ifdef HAS_SIGPROCMASK
1381 /* Avoid having the signal arrive at a bad time, if possible. */
1384 sigprocmask(SIG_BLOCK, &set, &save);
1386 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1387 SAVEFREESV(save_sv);
1388 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1391 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1392 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1394 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1395 PL_sig_ignoring[i] = 0;
1397 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1398 PL_sig_defaulting[i] = 0;
1400 SvREFCNT_dec(PL_psig_name[i]);
1401 to_dec = PL_psig_ptr[i];
1402 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1403 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1404 PL_psig_name[i] = newSVpvn(s, len);
1405 SvREADONLY_on(PL_psig_name[i]);
1407 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1409 (void)rsignal(i, PL_csighandlerp);
1410 #ifdef HAS_SIGPROCMASK
1415 *svp = SvREFCNT_inc(sv);
1417 SvREFCNT_dec(to_dec);
1420 s = SvPV_force(sv,len);
1421 if (strEQ(s,"IGNORE")) {
1423 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1424 PL_sig_ignoring[i] = 1;
1425 (void)rsignal(i, PL_csighandlerp);
1427 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1431 else if (strEQ(s,"DEFAULT") || !*s) {
1433 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1435 PL_sig_defaulting[i] = 1;
1436 (void)rsignal(i, PL_csighandlerp);
1439 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1444 * We should warn if HINT_STRICT_REFS, but without
1445 * access to a known hint bit in a known OP, we can't
1446 * tell whether HINT_STRICT_REFS is in force or not.
1448 if (!strchr(s,':') && !strchr(s,'\''))
1449 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1451 (void)rsignal(i, PL_csighandlerp);
1453 *svp = SvREFCNT_inc(sv);
1455 #ifdef HAS_SIGPROCMASK
1460 SvREFCNT_dec(to_dec);
1463 #endif /* !PERL_MICRO */
1466 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1469 PERL_UNUSED_ARG(sv);
1470 PERL_UNUSED_ARG(mg);
1471 PL_sub_generation++;
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1479 PERL_UNUSED_ARG(sv);
1480 PERL_UNUSED_ARG(mg);
1481 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1482 PL_amagic_generation++;
1488 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1490 HV * const hv = (HV*)LvTARG(sv);
1492 PERL_UNUSED_ARG(mg);
1495 (void) hv_iterinit(hv);
1496 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1499 while (hv_iternext(hv))
1504 sv_setiv(sv, (IV)i);
1509 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1511 PERL_UNUSED_ARG(mg);
1513 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1518 /* caller is responsible for stack switching/cleanup */
1520 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1527 PUSHs(SvTIED_obj(sv, mg));
1530 if (mg->mg_len >= 0)
1531 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1532 else if (mg->mg_len == HEf_SVKEY)
1533 PUSHs((SV*)mg->mg_ptr);
1535 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1536 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1544 return call_method(meth, flags);
1548 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1554 PUSHSTACKi(PERLSI_MAGIC);
1556 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1557 sv_setsv(sv, *PL_stack_sp--);
1567 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1570 mg->mg_flags |= MGf_GSKIP;
1571 magic_methpack(sv,mg,"FETCH");
1576 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1580 PUSHSTACKi(PERLSI_MAGIC);
1581 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1588 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1590 return magic_methpack(sv,mg,"DELETE");
1595 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1602 PUSHSTACKi(PERLSI_MAGIC);
1603 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1604 sv = *PL_stack_sp--;
1605 retval = (U32) SvIV(sv)-1;
1614 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1619 PUSHSTACKi(PERLSI_MAGIC);
1621 XPUSHs(SvTIED_obj(sv, mg));
1623 call_method("CLEAR", G_SCALAR|G_DISCARD);
1631 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1634 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1638 PUSHSTACKi(PERLSI_MAGIC);
1641 PUSHs(SvTIED_obj(sv, mg));
1646 if (call_method(meth, G_SCALAR))
1647 sv_setsv(key, *PL_stack_sp--);
1656 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1658 return magic_methpack(sv,mg,"EXISTS");
1662 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1665 SV *retval = &PL_sv_undef;
1666 SV * const tied = SvTIED_obj((SV*)hv, mg);
1667 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1669 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1671 if (HvEITER_get(hv))
1672 /* we are in an iteration so the hash cannot be empty */
1674 /* no xhv_eiter so now use FIRSTKEY */
1675 key = sv_newmortal();
1676 magic_nextpack((SV*)hv, mg, key);
1677 HvEITER_set(hv, NULL); /* need to reset iterator */
1678 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1681 /* there is a SCALAR method that we can call */
1683 PUSHSTACKi(PERLSI_MAGIC);
1689 if (call_method("SCALAR", G_SCALAR))
1690 retval = *PL_stack_sp--;
1697 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1700 GV * const gv = PL_DBline;
1701 const I32 i = SvTRUE(sv);
1702 SV ** const svp = av_fetch(GvAV(gv),
1703 atoi(MgPV_nolen_const(mg)), FALSE);
1704 if (svp && SvIOKp(*svp)) {
1705 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1707 /* set or clear breakpoint in the relevant control op */
1709 o->op_flags |= OPf_SPECIAL;
1711 o->op_flags &= ~OPf_SPECIAL;
1718 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1721 const AV * const obj = (AV*)mg->mg_obj;
1723 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1731 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1734 AV * const obj = (AV*)mg->mg_obj;
1736 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1738 if (ckWARN(WARN_MISC))
1739 Perl_warner(aTHX_ packWARN(WARN_MISC),
1740 "Attempt to set length of freed array");
1746 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1749 PERL_UNUSED_ARG(sv);
1750 /* during global destruction, mg_obj may already have been freed */
1751 if (PL_in_clean_all)
1754 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1757 /* arylen scalar holds a pointer back to the array, but doesn't own a
1758 reference. Hence the we (the array) are about to go away with it
1759 still pointing at us. Clear its pointer, else it would be pointing
1760 at free memory. See the comment in sv_magic about reference loops,
1761 and why it can't own a reference to us. */
1768 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1771 SV* const lsv = LvTARG(sv);
1773 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1774 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1775 if (mg && mg->mg_len >= 0) {
1778 sv_pos_b2u(lsv, &i);
1779 sv_setiv(sv, i + PL_curcop->cop_arybase);
1788 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1791 SV* const lsv = LvTARG(sv);
1798 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1799 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1803 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1804 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1806 else if (!SvOK(sv)) {
1810 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1812 pos = SvIV(sv) - PL_curcop->cop_arybase;
1815 ulen = sv_len_utf8(lsv);
1825 else if (pos > (SSize_t)len)
1830 sv_pos_u2b(lsv, &p, 0);
1835 mg->mg_flags &= ~MGf_MINMATCH;
1841 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1843 PERL_UNUSED_ARG(mg);
1844 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1846 gv_efullname3(sv,((GV*)sv), "*");
1850 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1855 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1858 PERL_UNUSED_ARG(mg);
1862 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1867 GvGP(sv) = gp_ref(GvGP(gv));
1872 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1875 SV * const lsv = LvTARG(sv);
1876 const char * const tmps = SvPV_const(lsv,len);
1877 I32 offs = LvTARGOFF(sv);
1878 I32 rem = LvTARGLEN(sv);
1879 PERL_UNUSED_ARG(mg);
1882 sv_pos_u2b(lsv, &offs, &rem);
1883 if (offs > (I32)len)
1885 if (rem + offs > (I32)len)
1887 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1894 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1898 const char *tmps = SvPV_const(sv, len);
1899 SV * const lsv = LvTARG(sv);
1900 I32 lvoff = LvTARGOFF(sv);
1901 I32 lvlen = LvTARGLEN(sv);
1902 PERL_UNUSED_ARG(mg);
1905 sv_utf8_upgrade(lsv);
1906 sv_pos_u2b(lsv, &lvoff, &lvlen);
1907 sv_insert(lsv, lvoff, lvlen, tmps, len);
1908 LvTARGLEN(sv) = sv_len_utf8(sv);
1911 else if (lsv && SvUTF8(lsv)) {
1912 sv_pos_u2b(lsv, &lvoff, &lvlen);
1913 LvTARGLEN(sv) = len;
1914 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1915 sv_insert(lsv, lvoff, lvlen, tmps, len);
1919 sv_insert(lsv, lvoff, lvlen, tmps, len);
1920 LvTARGLEN(sv) = len;
1928 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_UNUSED_ARG(sv);
1932 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1937 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1940 PERL_UNUSED_ARG(sv);
1941 /* update taint status unless we're restoring at scope exit */
1942 if (PL_localizing != 2) {
1952 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1954 SV * const lsv = LvTARG(sv);
1955 PERL_UNUSED_ARG(mg);
1958 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1966 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1968 PERL_UNUSED_ARG(mg);
1969 do_vecset(sv); /* XXX slurp this routine */
1974 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1978 if (LvTARGLEN(sv)) {
1980 SV * const ahv = LvTARG(sv);
1981 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1986 AV* const av = (AV*)LvTARG(sv);
1987 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1988 targ = AvARRAY(av)[LvTARGOFF(sv)];
1990 if (targ && targ != &PL_sv_undef) {
1991 /* somebody else defined it for us */
1992 SvREFCNT_dec(LvTARG(sv));
1993 LvTARG(sv) = SvREFCNT_inc(targ);
1995 SvREFCNT_dec(mg->mg_obj);
1996 mg->mg_obj = Nullsv;
1997 mg->mg_flags &= ~MGf_REFCOUNTED;
2002 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2007 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2009 PERL_UNUSED_ARG(mg);
2013 sv_setsv(LvTARG(sv), sv);
2014 SvSETMAGIC(LvTARG(sv));
2020 Perl_vivify_defelem(pTHX_ SV *sv)
2026 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2029 SV * const ahv = LvTARG(sv);
2030 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2033 if (!value || value == &PL_sv_undef)
2034 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2037 AV* const av = (AV*)LvTARG(sv);
2038 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2039 LvTARG(sv) = Nullsv; /* array can't be extended */
2041 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2042 if (!svp || (value = *svp) == &PL_sv_undef)
2043 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2046 (void)SvREFCNT_inc(value);
2047 SvREFCNT_dec(LvTARG(sv));
2050 SvREFCNT_dec(mg->mg_obj);
2051 mg->mg_obj = Nullsv;
2052 mg->mg_flags &= ~MGf_REFCOUNTED;
2056 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2058 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2062 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2070 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2072 PERL_UNUSED_ARG(mg);
2073 sv_unmagic(sv, PERL_MAGIC_bm);
2079 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2081 PERL_UNUSED_ARG(mg);
2082 sv_unmagic(sv, PERL_MAGIC_fm);
2088 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2090 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2092 if (uf && uf->uf_set)
2093 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2098 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_UNUSED_ARG(mg);
2101 sv_unmagic(sv, PERL_MAGIC_qr);
2106 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2109 regexp * const re = (regexp *)mg->mg_obj;
2110 PERL_UNUSED_ARG(sv);
2116 #ifdef USE_LOCALE_COLLATE
2118 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2121 * RenE<eacute> Descartes said "I think not."
2122 * and vanished with a faint plop.
2124 PERL_UNUSED_ARG(sv);
2126 Safefree(mg->mg_ptr);
2132 #endif /* USE_LOCALE_COLLATE */
2134 /* Just clear the UTF-8 cache data. */
2136 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2138 PERL_UNUSED_ARG(sv);
2139 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2141 mg->mg_len = -1; /* The mg_len holds the len cache. */
2146 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2149 register const char *s;
2152 switch (*mg->mg_ptr) {
2153 case '\001': /* ^A */
2154 sv_setsv(PL_bodytarget, sv);
2156 case '\003': /* ^C */
2157 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2160 case '\004': /* ^D */
2162 s = SvPV_nolen_const(sv);
2163 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2164 DEBUG_x(dump_all());
2166 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2169 case '\005': /* ^E */
2170 if (*(mg->mg_ptr+1) == '\0') {
2171 #ifdef MACOS_TRADITIONAL
2172 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2175 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2178 SetLastError( SvIV(sv) );
2181 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2183 /* will anyone ever use this? */
2184 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2190 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2192 SvREFCNT_dec(PL_encoding);
2193 if (SvOK(sv) || SvGMAGICAL(sv)) {
2194 PL_encoding = newSVsv(sv);
2197 PL_encoding = Nullsv;
2201 case '\006': /* ^F */
2202 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2204 case '\010': /* ^H */
2205 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2207 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2208 Safefree(PL_inplace);
2209 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2211 case '\017': /* ^O */
2212 if (*(mg->mg_ptr+1) == '\0') {
2213 Safefree(PL_osname);
2216 TAINT_PROPER("assigning to $^O");
2217 PL_osname = savesvpv(sv);
2220 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2221 if (!PL_compiling.cop_io)
2222 PL_compiling.cop_io = newSVsv(sv);
2224 sv_setsv(PL_compiling.cop_io,sv);
2227 case '\020': /* ^P */
2228 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2229 if (PL_perldb && !PL_DBsingle)
2232 case '\024': /* ^T */
2234 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2236 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2239 case '\027': /* ^W & $^WARNING_BITS */
2240 if (*(mg->mg_ptr+1) == '\0') {
2241 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2242 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2243 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2244 | (i ? G_WARN_ON : G_WARN_OFF) ;
2247 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2248 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2249 if (!SvPOK(sv) && PL_localizing) {
2250 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2251 PL_compiling.cop_warnings = pWARN_NONE;
2256 int accumulate = 0 ;
2257 int any_fatals = 0 ;
2258 const char * const ptr = SvPV_const(sv, len) ;
2259 for (i = 0 ; i < len ; ++i) {
2260 accumulate |= ptr[i] ;
2261 any_fatals |= (ptr[i] & 0xAA) ;
2264 PL_compiling.cop_warnings = pWARN_NONE;
2265 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2266 PL_compiling.cop_warnings = pWARN_ALL;
2267 PL_dowarn |= G_WARN_ONCE ;
2270 if (specialWARN(PL_compiling.cop_warnings))
2271 PL_compiling.cop_warnings = newSVsv(sv) ;
2273 sv_setsv(PL_compiling.cop_warnings, sv);
2274 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2275 PL_dowarn |= G_WARN_ONCE ;
2283 if (PL_localizing) {
2284 if (PL_localizing == 1)
2285 SAVESPTR(PL_last_in_gv);
2287 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2288 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2291 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2292 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2293 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2296 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2297 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2298 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2301 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2304 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2305 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2306 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2309 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2313 IO * const io = GvIOp(PL_defoutgv);
2316 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2317 IoFLAGS(io) &= ~IOf_FLUSH;
2319 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2320 PerlIO *ofp = IoOFP(io);
2322 (void)PerlIO_flush(ofp);
2323 IoFLAGS(io) |= IOf_FLUSH;
2329 SvREFCNT_dec(PL_rs);
2330 PL_rs = newSVsv(sv);
2334 SvREFCNT_dec(PL_ors_sv);
2335 if (SvOK(sv) || SvGMAGICAL(sv)) {
2336 PL_ors_sv = newSVsv(sv);
2344 SvREFCNT_dec(PL_ofs_sv);
2345 if (SvOK(sv) || SvGMAGICAL(sv)) {
2346 PL_ofs_sv = newSVsv(sv);
2353 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2356 #ifdef COMPLEX_STATUS
2357 if (PL_localizing == 2) {
2358 PL_statusvalue = LvTARGOFF(sv);
2359 PL_statusvalue_vms = LvTARGLEN(sv);
2363 #ifdef VMSISH_STATUS
2365 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2368 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2373 # define PERL_VMS_BANG vaxc$errno
2375 # define PERL_VMS_BANG 0
2377 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2378 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2382 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2383 if (PL_delaymagic) {
2384 PL_delaymagic |= DM_RUID;
2385 break; /* don't do magic till later */
2388 (void)setruid((Uid_t)PL_uid);
2391 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2393 #ifdef HAS_SETRESUID
2394 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2396 if (PL_uid == PL_euid) { /* special case $< = $> */
2398 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2399 if (PL_uid != 0 && PerlProc_getuid() == 0)
2400 (void)PerlProc_setuid(0);
2402 (void)PerlProc_setuid(PL_uid);
2404 PL_uid = PerlProc_getuid();
2405 Perl_croak(aTHX_ "setruid() not implemented");
2410 PL_uid = PerlProc_getuid();
2411 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2414 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2415 if (PL_delaymagic) {
2416 PL_delaymagic |= DM_EUID;
2417 break; /* don't do magic till later */
2420 (void)seteuid((Uid_t)PL_euid);
2423 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2425 #ifdef HAS_SETRESUID
2426 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2428 if (PL_euid == PL_uid) /* special case $> = $< */
2429 PerlProc_setuid(PL_euid);
2431 PL_euid = PerlProc_geteuid();
2432 Perl_croak(aTHX_ "seteuid() not implemented");
2437 PL_euid = PerlProc_geteuid();
2438 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2441 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2442 if (PL_delaymagic) {
2443 PL_delaymagic |= DM_RGID;
2444 break; /* don't do magic till later */
2447 (void)setrgid((Gid_t)PL_gid);
2450 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2452 #ifdef HAS_SETRESGID
2453 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2455 if (PL_gid == PL_egid) /* special case $( = $) */
2456 (void)PerlProc_setgid(PL_gid);
2458 PL_gid = PerlProc_getgid();
2459 Perl_croak(aTHX_ "setrgid() not implemented");
2464 PL_gid = PerlProc_getgid();
2465 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2468 #ifdef HAS_SETGROUPS
2470 const char *p = SvPV_const(sv, len);
2471 Groups_t *gary = NULL;
2476 for (i = 0; i < NGROUPS; ++i) {
2477 while (*p && !isSPACE(*p))
2484 Newx(gary, i + 1, Groups_t);
2486 Renew(gary, i + 1, Groups_t);
2490 (void)setgroups(i, gary);
2494 #else /* HAS_SETGROUPS */
2495 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2496 #endif /* HAS_SETGROUPS */
2497 if (PL_delaymagic) {
2498 PL_delaymagic |= DM_EGID;
2499 break; /* don't do magic till later */
2502 (void)setegid((Gid_t)PL_egid);
2505 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2507 #ifdef HAS_SETRESGID
2508 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2510 if (PL_egid == PL_gid) /* special case $) = $( */
2511 (void)PerlProc_setgid(PL_egid);
2513 PL_egid = PerlProc_getegid();
2514 Perl_croak(aTHX_ "setegid() not implemented");
2519 PL_egid = PerlProc_getegid();
2520 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2523 PL_chopset = SvPV_force(sv,len);
2525 #ifndef MACOS_TRADITIONAL
2527 LOCK_DOLLARZERO_MUTEX;
2528 #ifdef HAS_SETPROCTITLE
2529 /* The BSDs don't show the argv[] in ps(1) output, they
2530 * show a string from the process struct and provide
2531 * the setproctitle() routine to manipulate that. */
2532 if (PL_origalen != 1) {
2533 s = SvPV_const(sv, len);
2534 # if __FreeBSD_version > 410001
2535 /* The leading "-" removes the "perl: " prefix,
2536 * but not the "(perl) suffix from the ps(1)
2537 * output, because that's what ps(1) shows if the
2538 * argv[] is modified. */
2539 setproctitle("-%s", s);
2540 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2541 /* This doesn't really work if you assume that
2542 * $0 = 'foobar'; will wipe out 'perl' from the $0
2543 * because in ps(1) output the result will be like
2544 * sprintf("perl: %s (perl)", s)
2545 * I guess this is a security feature:
2546 * one (a user process) cannot get rid of the original name.
2548 setproctitle("%s", s);
2552 #if defined(__hpux) && defined(PSTAT_SETCMD)
2553 if (PL_origalen != 1) {
2555 s = SvPV_const(sv, len);
2556 un.pst_command = (char *)s;
2557 pstat(PSTAT_SETCMD, un, len, 0, 0);
2560 if (PL_origalen > 1) {
2561 /* PL_origalen is set in perl_parse(). */
2562 s = SvPV_force(sv,len);
2563 if (len >= (STRLEN)PL_origalen-1) {
2564 /* Longer than original, will be truncated. We assume that
2565 * PL_origalen bytes are available. */
2566 Copy(s, PL_origargv[0], PL_origalen-1, char);
2569 /* Shorter than original, will be padded. */
2570 Copy(s, PL_origargv[0], len, char);
2571 PL_origargv[0][len] = 0;
2572 memset(PL_origargv[0] + len + 1,
2573 /* Is the space counterintuitive? Yes.
2574 * (You were expecting \0?)
2575 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2578 PL_origalen - len - 1);
2580 PL_origargv[0][PL_origalen-1] = 0;
2581 for (i = 1; i < PL_origargc; i++)
2584 UNLOCK_DOLLARZERO_MUTEX;
2592 Perl_whichsig(pTHX_ const char *sig)
2594 register char* const* sigv;
2596 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2597 if (strEQ(sig,*sigv))
2598 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2600 if (strEQ(sig,"CHLD"))
2604 if (strEQ(sig,"CLD"))
2611 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2612 Perl_sighandler(int sig, ...)
2614 Perl_sighandler(int sig)
2617 #ifdef PERL_GET_SIG_CONTEXT
2618 dTHXa(PERL_GET_SIG_CONTEXT);
2625 SV * const tSv = PL_Sv;
2629 XPV * const tXpv = PL_Xpv;
2631 if (PL_savestack_ix + 15 <= PL_savestack_max)
2633 if (PL_markstack_ptr < PL_markstack_max - 2)
2635 if (PL_scopestack_ix < PL_scopestack_max - 3)
2638 if (!PL_psig_ptr[sig]) {
2639 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2644 /* Max number of items pushed there is 3*n or 4. We cannot fix
2645 infinity, so we fix 4 (in fact 5): */
2647 PL_savestack_ix += 5; /* Protect save in progress. */
2648 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2651 PL_markstack_ptr++; /* Protect mark. */
2653 PL_scopestack_ix += 1;
2654 /* sv_2cv is too complicated, try a simpler variant first: */
2655 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2656 || SvTYPE(cv) != SVt_PVCV) {
2658 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2661 if (!cv || !CvROOT(cv)) {
2662 if (ckWARN(WARN_SIGNAL))
2663 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2664 PL_sig_name[sig], (gv ? GvENAME(gv)
2671 if(PL_psig_name[sig]) {
2672 sv = SvREFCNT_inc(PL_psig_name[sig]);
2674 #if !defined(PERL_IMPLICIT_CONTEXT)
2678 sv = sv_newmortal();
2679 sv_setpv(sv,PL_sig_name[sig]);
2682 PUSHSTACKi(PERLSI_SIGNAL);
2685 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2687 struct sigaction oact;
2689 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2693 va_start(args, sig);
2694 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2697 SV *rv = newRV_noinc((SV*)sih);
2698 /* The siginfo fields signo, code, errno, pid, uid,
2699 * addr, status, and band are defined by POSIX/SUSv3. */
2700 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2701 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2702 #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
2703 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2704 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2705 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2706 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2707 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2708 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2712 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2721 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2724 if (SvTRUE(ERRSV)) {
2726 #ifdef HAS_SIGPROCMASK
2727 /* Handler "died", for example to get out of a restart-able read().
2728 * Before we re-do that on its behalf re-enable the signal which was
2729 * blocked by the system when we entered.
2733 sigaddset(&set,sig);
2734 sigprocmask(SIG_UNBLOCK, &set, NULL);
2736 /* Not clear if this will work */
2737 (void)rsignal(sig, SIG_IGN);
2738 (void)rsignal(sig, PL_csighandlerp);
2740 #endif /* !PERL_MICRO */
2741 Perl_die(aTHX_ Nullch);
2745 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2749 PL_scopestack_ix -= 1;
2752 PL_op = myop; /* Apparently not needed... */
2754 PL_Sv = tSv; /* Restore global temporaries. */
2761 S_restore_magic(pTHX_ const void *p)
2764 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2765 SV* const sv = mgs->mgs_sv;
2770 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2772 #ifdef PERL_OLD_COPY_ON_WRITE
2773 /* While magic was saved (and off) sv_setsv may well have seen
2774 this SV as a prime candidate for COW. */
2776 sv_force_normal_flags(sv, 0);
2780 SvFLAGS(sv) |= mgs->mgs_flags;
2783 if (SvGMAGICAL(sv)) {
2784 /* downgrade public flags to private,
2785 and discard any other private flags */
2787 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2789 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2790 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2795 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2797 /* If we're still on top of the stack, pop us off. (That condition
2798 * will be satisfied if restore_magic was called explicitly, but *not*
2799 * if it's being called via leave_scope.)
2800 * The reason for doing this is that otherwise, things like sv_2cv()
2801 * may leave alloc gunk on the savestack, and some code
2802 * (e.g. sighandler) doesn't expect that...
2804 if (PL_savestack_ix == mgs->mgs_ss_ix)
2806 I32 popval = SSPOPINT;
2807 assert(popval == SAVEt_DESTRUCTOR_X);
2808 PL_savestack_ix -= 2;
2810 assert(popval == SAVEt_ALLOC);
2812 PL_savestack_ix -= popval;
2818 S_unwind_handler_stack(pTHX_ const void *p)
2821 const U32 flags = *(const U32*)p;
2824 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2825 #if !defined(PERL_IMPLICIT_CONTEXT)
2827 SvREFCNT_dec(PL_sig_sv);
2833 * c-indentation-style: bsd
2835 * indent-tabs-mode: t
2838 * ex: set ts=8 sts=4 sw=4 noet: