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 #ifdef MACOS_TRADITIONAL
687 sv_setnv(sv,(double)gMacPerl_OSErr);
688 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
693 # include <descrip.h>
694 # include <starlet.h>
696 $DESCRIPTOR(msgdsc,msg);
697 sv_setnv(sv,(NV) vaxc$errno);
698 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
699 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
705 if (!(_emx_env & 0x200)) { /* Under DOS */
706 sv_setnv(sv, (NV)errno);
707 sv_setpv(sv, errno ? Strerror(errno) : "");
709 if (errno != errno_isOS2) {
710 const int tmp = _syserrno();
711 if (tmp) /* 2nd call to _syserrno() makes it 0 */
714 sv_setnv(sv, (NV)Perl_rc);
715 sv_setpv(sv, os2error(Perl_rc));
720 DWORD dwErr = GetLastError();
721 sv_setnv(sv, (NV)dwErr);
723 PerlProc_GetOSError(sv, dwErr);
726 sv_setpvn(sv, "", 0);
731 const int saveerrno = errno;
732 sv_setnv(sv, (NV)errno);
733 sv_setpv(sv, errno ? Strerror(errno) : "");
741 SvNOK_on(sv); /* what a wonderful hack! */
743 else if (strEQ(remaining, "NCODING"))
744 sv_setsv(sv, PL_encoding);
746 case '\006': /* ^F */
747 sv_setiv(sv, (IV)PL_maxsysfd);
749 case '\010': /* ^H */
750 sv_setiv(sv, (IV)PL_hints);
752 case '\011': /* ^I */ /* NOT \t in EBCDIC */
754 sv_setpv(sv, PL_inplace);
756 sv_setsv(sv, &PL_sv_undef);
758 case '\017': /* ^O & ^OPEN */
759 if (nextchar == '\0') {
760 sv_setpv(sv, PL_osname);
763 else if (strEQ(remaining, "PEN")) {
764 if (!PL_compiling.cop_io)
765 sv_setsv(sv, &PL_sv_undef);
767 sv_setsv(sv, PL_compiling.cop_io);
771 case '\020': /* ^P */
772 sv_setiv(sv, (IV)PL_perldb);
774 case '\023': /* ^S */
775 if (nextchar == '\0') {
776 if (PL_lex_state != LEX_NOTPARSING)
779 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
784 case '\024': /* ^T */
785 if (nextchar == '\0') {
787 sv_setnv(sv, PL_basetime);
789 sv_setiv(sv, (IV)PL_basetime);
792 else if (strEQ(remaining, "AINT"))
793 sv_setiv(sv, PL_tainting
794 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
797 case '\025': /* $^UNICODE, $^UTF8LOCALE */
798 if (strEQ(remaining, "NICODE"))
799 sv_setuv(sv, (UV) PL_unicode);
800 else if (strEQ(remaining, "TF8LOCALE"))
801 sv_setuv(sv, (UV) PL_utf8locale);
803 case '\027': /* ^W & $^WARNING_BITS */
804 if (nextchar == '\0')
805 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
806 else if (strEQ(remaining, "ARNING_BITS")) {
807 if (PL_compiling.cop_warnings == pWARN_NONE) {
808 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
810 else if (PL_compiling.cop_warnings == pWARN_STD) {
813 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
817 else if (PL_compiling.cop_warnings == pWARN_ALL) {
818 /* Get the bit mask for $warnings::Bits{all}, because
819 * it could have been extended by warnings::register */
821 HV * const bits=get_hv("warnings::Bits", FALSE);
822 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
823 sv_setsv(sv, *bits_all);
826 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
830 sv_setsv(sv, PL_compiling.cop_warnings);
835 case '1': case '2': case '3': case '4':
836 case '5': case '6': case '7': case '8': case '9': case '&':
837 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
841 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
842 * XXX Does the new way break anything?
844 paren = atoi(mg->mg_ptr); /* $& is in [0] */
846 if (paren <= (I32)rx->nparens &&
847 (s1 = rx->startp[paren]) != -1 &&
848 (t1 = rx->endp[paren]) != -1)
857 const int oldtainted = PL_tainted;
860 PL_tainted = oldtainted;
861 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
866 if (RX_MATCH_TAINTED(rx)) {
867 MAGIC* const mg = SvMAGIC(sv);
870 SvMAGIC_set(sv, mg->mg_moremagic);
872 if ((mgt = SvMAGIC(sv))) {
873 mg->mg_moremagic = mgt;
883 sv_setsv(sv,&PL_sv_undef);
886 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
887 paren = rx->lastparen;
891 sv_setsv(sv,&PL_sv_undef);
893 case '\016': /* ^N */
894 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
895 paren = rx->lastcloseparen;
899 sv_setsv(sv,&PL_sv_undef);
902 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
903 if ((s = rx->subbeg) && rx->startp[0] != -1) {
908 sv_setsv(sv,&PL_sv_undef);
911 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
912 if (rx->subbeg && rx->endp[0] != -1) {
913 s = rx->subbeg + rx->endp[0];
914 i = rx->sublen - rx->endp[0];
918 sv_setsv(sv,&PL_sv_undef);
921 if (GvIO(PL_last_in_gv)) {
922 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
927 sv_setiv(sv, (IV)STATUS_CURRENT);
928 #ifdef COMPLEX_STATUS
929 LvTARGOFF(sv) = PL_statusvalue;
930 LvTARGLEN(sv) = PL_statusvalue_vms;
935 if (GvIOp(PL_defoutgv))
936 s = IoTOP_NAME(GvIOp(PL_defoutgv));
940 sv_setpv(sv,GvENAME(PL_defoutgv));
945 if (GvIOp(PL_defoutgv))
946 s = IoFMT_NAME(GvIOp(PL_defoutgv));
948 s = GvENAME(PL_defoutgv);
952 if (GvIOp(PL_defoutgv))
953 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
956 if (GvIOp(PL_defoutgv))
957 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
960 if (GvIOp(PL_defoutgv))
961 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
968 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
971 if (GvIOp(PL_defoutgv))
972 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
978 sv_copypv(sv, PL_ors_sv);
982 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
983 sv_setpv(sv, errno ? Strerror(errno) : "");
986 const int saveerrno = errno;
987 sv_setnv(sv, (NV)errno);
989 if (errno == errno_isOS2 || errno == errno_isOS2_set)
990 sv_setpv(sv, os2error(Perl_rc));
993 sv_setpv(sv, errno ? Strerror(errno) : "");
998 SvNOK_on(sv); /* what a wonderful hack! */
1001 sv_setiv(sv, (IV)PL_uid);
1004 sv_setiv(sv, (IV)PL_euid);
1007 sv_setiv(sv, (IV)PL_gid);
1010 sv_setiv(sv, (IV)PL_egid);
1012 #ifdef HAS_GETGROUPS
1014 Groups_t *gary = NULL;
1015 I32 i, num_groups = getgroups(0, gary);
1016 Newx(gary, num_groups, Groups_t);
1017 num_groups = getgroups(num_groups, gary);
1018 for (i = 0; i < num_groups; i++)
1019 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1022 (void)SvIOK_on(sv); /* what a wonderful hack! */
1025 #ifndef MACOS_TRADITIONAL
1034 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1036 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1038 if (uf && uf->uf_val)
1039 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1044 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1048 const char *s = SvPV_const(sv,len);
1049 const char * const ptr = MgPV_const(mg,klen);
1052 #ifdef DYNAMIC_ENV_FETCH
1053 /* We just undefd an environment var. Is a replacement */
1054 /* waiting in the wings? */
1056 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1058 s = SvPV_const(*valp, len);
1062 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1063 /* And you'll never guess what the dog had */
1064 /* in its mouth... */
1066 MgTAINTEDDIR_off(mg);
1068 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1069 char pathbuf[256], eltbuf[256], *cp, *elt;
1073 strncpy(eltbuf, s, 255);
1076 do { /* DCL$PATH may be a search list */
1077 while (1) { /* as may dev portion of any element */
1078 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1079 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1080 cando_by_name(S_IWUSR,0,elt) ) {
1081 MgTAINTEDDIR_on(mg);
1085 if ((cp = strchr(elt, ':')) != Nullch)
1087 if (my_trnlnm(elt, eltbuf, j++))
1093 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1096 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1097 const char * const strend = s + len;
1099 while (s < strend) {
1103 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1104 s, strend, ':', &i);
1106 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1108 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1109 MgTAINTEDDIR_on(mg);
1115 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1121 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1123 PERL_UNUSED_ARG(sv);
1124 my_setenv(MgPV_nolen_const(mg),Nullch);
1129 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1132 PERL_UNUSED_ARG(mg);
1134 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1136 if (PL_localizing) {
1139 hv_iterinit((HV*)sv);
1140 while ((entry = hv_iternext((HV*)sv))) {
1142 my_setenv(hv_iterkey(entry, &keylen),
1143 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1151 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1154 PERL_UNUSED_ARG(sv);
1155 PERL_UNUSED_ARG(mg);
1157 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1165 #ifdef HAS_SIGPROCMASK
1167 restore_sigmask(pTHX_ SV *save_sv)
1169 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1170 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1174 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1177 /* Are we fetching a signal entry? */
1178 const I32 i = whichsig(MgPV_nolen_const(mg));
1181 sv_setsv(sv,PL_psig_ptr[i]);
1183 Sighandler_t sigstate;
1184 sigstate = rsignal_state(i);
1185 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1186 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1188 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1189 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1191 /* cache state so we don't fetch it again */
1192 if(sigstate == (Sighandler_t) SIG_IGN)
1193 sv_setpv(sv,"IGNORE");
1195 sv_setsv(sv,&PL_sv_undef);
1196 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1203 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1205 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1206 * refactoring might be in order.
1209 register const char * const s = MgPV_nolen_const(mg);
1210 PERL_UNUSED_ARG(sv);
1213 if (strEQ(s,"__DIE__"))
1215 else if (strEQ(s,"__WARN__"))
1218 Perl_croak(aTHX_ "No such hook: %s", s);
1220 SV * const to_dec = *svp;
1222 SvREFCNT_dec(to_dec);
1226 /* Are we clearing a signal entry? */
1227 const I32 i = whichsig(s);
1229 #ifdef HAS_SIGPROCMASK
1232 /* Avoid having the signal arrive at a bad time, if possible. */
1235 sigprocmask(SIG_BLOCK, &set, &save);
1237 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1238 SAVEFREESV(save_sv);
1239 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1242 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1243 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1246 PL_sig_defaulting[i] = 1;
1247 (void)rsignal(i, PL_csighandlerp);
1249 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1251 if(PL_psig_name[i]) {
1252 SvREFCNT_dec(PL_psig_name[i]);
1255 if(PL_psig_ptr[i]) {
1256 SV * const to_dec=PL_psig_ptr[i];
1259 SvREFCNT_dec(to_dec);
1269 S_raise_signal(pTHX_ int sig)
1272 /* Set a flag to say this signal is pending */
1273 PL_psig_pend[sig]++;
1274 /* And one to say _a_ signal is pending */
1279 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1280 Perl_csighandler(int sig, ...)
1282 Perl_csighandler(int sig)
1285 #ifdef PERL_GET_SIG_CONTEXT
1286 dTHXa(PERL_GET_SIG_CONTEXT);
1290 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1291 (void) rsignal(sig, PL_csighandlerp);
1292 if (PL_sig_ignoring[sig]) return;
1294 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1295 if (PL_sig_defaulting[sig])
1296 #ifdef KILL_BY_SIGPRC
1297 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1302 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1303 /* Call the perl level handler now--
1304 * with risk we may be in malloc() etc. */
1305 (*PL_sighandlerp)(sig);
1307 S_raise_signal(aTHX_ sig);
1310 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1312 Perl_csighandler_init(void)
1315 if (PL_sig_handlers_initted) return;
1317 for (sig = 1; sig < SIG_SIZE; sig++) {
1318 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1320 PL_sig_defaulting[sig] = 1;
1321 (void) rsignal(sig, PL_csighandlerp);
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324 PL_sig_ignoring[sig] = 0;
1327 PL_sig_handlers_initted = 1;
1332 Perl_despatch_signals(pTHX)
1337 for (sig = 1; sig < SIG_SIZE; sig++) {
1338 if (PL_psig_pend[sig]) {
1339 PERL_BLOCKSIG_ADD(set, sig);
1340 PL_psig_pend[sig] = 0;
1341 PERL_BLOCKSIG_BLOCK(set);
1342 (*PL_sighandlerp)(sig);
1343 PERL_BLOCKSIG_UNBLOCK(set);
1349 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1354 /* Need to be careful with SvREFCNT_dec(), because that can have side
1355 * effects (due to closures). We must make sure that the new disposition
1356 * is in place before it is called.
1360 #ifdef HAS_SIGPROCMASK
1365 register const char *s = MgPV_const(mg,len);
1367 if (strEQ(s,"__DIE__"))
1369 else if (strEQ(s,"__WARN__"))
1372 Perl_croak(aTHX_ "No such hook: %s", s);
1380 i = whichsig(s); /* ...no, a brick */
1382 if (ckWARN(WARN_SIGNAL))
1383 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1386 #ifdef HAS_SIGPROCMASK
1387 /* Avoid having the signal arrive at a bad time, if possible. */
1390 sigprocmask(SIG_BLOCK, &set, &save);
1392 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1393 SAVEFREESV(save_sv);
1394 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1397 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1398 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1400 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1401 PL_sig_ignoring[i] = 0;
1403 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1404 PL_sig_defaulting[i] = 0;
1406 SvREFCNT_dec(PL_psig_name[i]);
1407 to_dec = PL_psig_ptr[i];
1408 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1409 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1410 PL_psig_name[i] = newSVpvn(s, len);
1411 SvREADONLY_on(PL_psig_name[i]);
1413 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1415 (void)rsignal(i, PL_csighandlerp);
1416 #ifdef HAS_SIGPROCMASK
1421 *svp = SvREFCNT_inc(sv);
1423 SvREFCNT_dec(to_dec);
1426 s = SvPV_force(sv,len);
1427 if (strEQ(s,"IGNORE")) {
1429 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1430 PL_sig_ignoring[i] = 1;
1431 (void)rsignal(i, PL_csighandlerp);
1433 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1437 else if (strEQ(s,"DEFAULT") || !*s) {
1439 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1441 PL_sig_defaulting[i] = 1;
1442 (void)rsignal(i, PL_csighandlerp);
1445 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1450 * We should warn if HINT_STRICT_REFS, but without
1451 * access to a known hint bit in a known OP, we can't
1452 * tell whether HINT_STRICT_REFS is in force or not.
1454 if (!strchr(s,':') && !strchr(s,'\''))
1455 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1457 (void)rsignal(i, PL_csighandlerp);
1459 *svp = SvREFCNT_inc(sv);
1461 #ifdef HAS_SIGPROCMASK
1466 SvREFCNT_dec(to_dec);
1469 #endif /* !PERL_MICRO */
1472 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1475 PERL_UNUSED_ARG(sv);
1476 PERL_UNUSED_ARG(mg);
1477 PL_sub_generation++;
1482 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1485 PERL_UNUSED_ARG(sv);
1486 PERL_UNUSED_ARG(mg);
1487 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1488 PL_amagic_generation++;
1494 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1496 HV * const hv = (HV*)LvTARG(sv);
1498 PERL_UNUSED_ARG(mg);
1501 (void) hv_iterinit(hv);
1502 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1505 while (hv_iternext(hv))
1510 sv_setiv(sv, (IV)i);
1515 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1517 PERL_UNUSED_ARG(mg);
1519 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1524 /* caller is responsible for stack switching/cleanup */
1526 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1533 PUSHs(SvTIED_obj(sv, mg));
1536 if (mg->mg_len >= 0)
1537 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1538 else if (mg->mg_len == HEf_SVKEY)
1539 PUSHs((SV*)mg->mg_ptr);
1541 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1542 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1550 return call_method(meth, flags);
1554 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1560 PUSHSTACKi(PERLSI_MAGIC);
1562 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1563 sv_setsv(sv, *PL_stack_sp--);
1573 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1576 mg->mg_flags |= MGf_GSKIP;
1577 magic_methpack(sv,mg,"FETCH");
1582 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1586 PUSHSTACKi(PERLSI_MAGIC);
1587 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1594 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1596 return magic_methpack(sv,mg,"DELETE");
1601 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1608 PUSHSTACKi(PERLSI_MAGIC);
1609 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1610 sv = *PL_stack_sp--;
1611 retval = (U32) SvIV(sv)-1;
1620 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1625 PUSHSTACKi(PERLSI_MAGIC);
1627 XPUSHs(SvTIED_obj(sv, mg));
1629 call_method("CLEAR", G_SCALAR|G_DISCARD);
1637 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1640 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1644 PUSHSTACKi(PERLSI_MAGIC);
1647 PUSHs(SvTIED_obj(sv, mg));
1652 if (call_method(meth, G_SCALAR))
1653 sv_setsv(key, *PL_stack_sp--);
1662 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1664 return magic_methpack(sv,mg,"EXISTS");
1668 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1671 SV *retval = &PL_sv_undef;
1672 SV * const tied = SvTIED_obj((SV*)hv, mg);
1673 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1675 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1677 if (HvEITER_get(hv))
1678 /* we are in an iteration so the hash cannot be empty */
1680 /* no xhv_eiter so now use FIRSTKEY */
1681 key = sv_newmortal();
1682 magic_nextpack((SV*)hv, mg, key);
1683 HvEITER_set(hv, NULL); /* need to reset iterator */
1684 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1687 /* there is a SCALAR method that we can call */
1689 PUSHSTACKi(PERLSI_MAGIC);
1695 if (call_method("SCALAR", G_SCALAR))
1696 retval = *PL_stack_sp--;
1703 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1706 GV * const gv = PL_DBline;
1707 const I32 i = SvTRUE(sv);
1708 SV ** const svp = av_fetch(GvAV(gv),
1709 atoi(MgPV_nolen_const(mg)), FALSE);
1710 if (svp && SvIOKp(*svp)) {
1711 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1713 /* set or clear breakpoint in the relevant control op */
1715 o->op_flags |= OPf_SPECIAL;
1717 o->op_flags &= ~OPf_SPECIAL;
1724 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1727 const AV * const obj = (AV*)mg->mg_obj;
1729 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1737 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1740 AV * const obj = (AV*)mg->mg_obj;
1742 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1744 if (ckWARN(WARN_MISC))
1745 Perl_warner(aTHX_ packWARN(WARN_MISC),
1746 "Attempt to set length of freed array");
1752 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1755 PERL_UNUSED_ARG(sv);
1756 /* during global destruction, mg_obj may already have been freed */
1757 if (PL_in_clean_all)
1760 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1763 /* arylen scalar holds a pointer back to the array, but doesn't own a
1764 reference. Hence the we (the array) are about to go away with it
1765 still pointing at us. Clear its pointer, else it would be pointing
1766 at free memory. See the comment in sv_magic about reference loops,
1767 and why it can't own a reference to us. */
1774 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1777 SV* const lsv = LvTARG(sv);
1779 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1780 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1781 if (mg && mg->mg_len >= 0) {
1784 sv_pos_b2u(lsv, &i);
1785 sv_setiv(sv, i + PL_curcop->cop_arybase);
1794 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1797 SV* const lsv = LvTARG(sv);
1804 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1805 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1809 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1810 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1812 else if (!SvOK(sv)) {
1816 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1818 pos = SvIV(sv) - PL_curcop->cop_arybase;
1821 ulen = sv_len_utf8(lsv);
1831 else if (pos > (SSize_t)len)
1836 sv_pos_u2b(lsv, &p, 0);
1841 mg->mg_flags &= ~MGf_MINMATCH;
1847 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1849 PERL_UNUSED_ARG(mg);
1850 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1852 gv_efullname3(sv,((GV*)sv), "*");
1856 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1861 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1864 PERL_UNUSED_ARG(mg);
1868 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1873 GvGP(sv) = gp_ref(GvGP(gv));
1878 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1881 SV * const lsv = LvTARG(sv);
1882 const char * const tmps = SvPV_const(lsv,len);
1883 I32 offs = LvTARGOFF(sv);
1884 I32 rem = LvTARGLEN(sv);
1885 PERL_UNUSED_ARG(mg);
1888 sv_pos_u2b(lsv, &offs, &rem);
1889 if (offs > (I32)len)
1891 if (rem + offs > (I32)len)
1893 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1900 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1904 const char *tmps = SvPV_const(sv, len);
1905 SV * const lsv = LvTARG(sv);
1906 I32 lvoff = LvTARGOFF(sv);
1907 I32 lvlen = LvTARGLEN(sv);
1908 PERL_UNUSED_ARG(mg);
1911 sv_utf8_upgrade(lsv);
1912 sv_pos_u2b(lsv, &lvoff, &lvlen);
1913 sv_insert(lsv, lvoff, lvlen, tmps, len);
1914 LvTARGLEN(sv) = sv_len_utf8(sv);
1917 else if (lsv && SvUTF8(lsv)) {
1918 sv_pos_u2b(lsv, &lvoff, &lvlen);
1919 LvTARGLEN(sv) = len;
1920 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1921 sv_insert(lsv, lvoff, lvlen, tmps, len);
1925 sv_insert(lsv, lvoff, lvlen, tmps, len);
1926 LvTARGLEN(sv) = len;
1934 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1937 PERL_UNUSED_ARG(sv);
1938 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1943 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1946 PERL_UNUSED_ARG(sv);
1947 /* update taint status unless we're restoring at scope exit */
1948 if (PL_localizing != 2) {
1958 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1960 SV * const lsv = LvTARG(sv);
1961 PERL_UNUSED_ARG(mg);
1964 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1972 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1974 PERL_UNUSED_ARG(mg);
1975 do_vecset(sv); /* XXX slurp this routine */
1980 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1984 if (LvTARGLEN(sv)) {
1986 SV * const ahv = LvTARG(sv);
1987 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1992 AV* const av = (AV*)LvTARG(sv);
1993 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1994 targ = AvARRAY(av)[LvTARGOFF(sv)];
1996 if (targ && targ != &PL_sv_undef) {
1997 /* somebody else defined it for us */
1998 SvREFCNT_dec(LvTARG(sv));
1999 LvTARG(sv) = SvREFCNT_inc(targ);
2001 SvREFCNT_dec(mg->mg_obj);
2002 mg->mg_obj = Nullsv;
2003 mg->mg_flags &= ~MGf_REFCOUNTED;
2008 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2013 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2015 PERL_UNUSED_ARG(mg);
2019 sv_setsv(LvTARG(sv), sv);
2020 SvSETMAGIC(LvTARG(sv));
2026 Perl_vivify_defelem(pTHX_ SV *sv)
2032 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2035 SV * const ahv = LvTARG(sv);
2036 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2039 if (!value || value == &PL_sv_undef)
2040 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2043 AV* const av = (AV*)LvTARG(sv);
2044 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2045 LvTARG(sv) = Nullsv; /* array can't be extended */
2047 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2048 if (!svp || (value = *svp) == &PL_sv_undef)
2049 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2052 (void)SvREFCNT_inc(value);
2053 SvREFCNT_dec(LvTARG(sv));
2056 SvREFCNT_dec(mg->mg_obj);
2057 mg->mg_obj = Nullsv;
2058 mg->mg_flags &= ~MGf_REFCOUNTED;
2062 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2064 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2068 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2076 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2078 PERL_UNUSED_ARG(mg);
2079 sv_unmagic(sv, PERL_MAGIC_bm);
2085 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2087 PERL_UNUSED_ARG(mg);
2088 sv_unmagic(sv, PERL_MAGIC_fm);
2094 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2096 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2098 if (uf && uf->uf_set)
2099 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2104 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2106 PERL_UNUSED_ARG(mg);
2107 sv_unmagic(sv, PERL_MAGIC_qr);
2112 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2115 regexp * const re = (regexp *)mg->mg_obj;
2116 PERL_UNUSED_ARG(sv);
2122 #ifdef USE_LOCALE_COLLATE
2124 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2127 * RenE<eacute> Descartes said "I think not."
2128 * and vanished with a faint plop.
2130 PERL_UNUSED_ARG(sv);
2132 Safefree(mg->mg_ptr);
2138 #endif /* USE_LOCALE_COLLATE */
2140 /* Just clear the UTF-8 cache data. */
2142 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2144 PERL_UNUSED_ARG(sv);
2145 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2147 mg->mg_len = -1; /* The mg_len holds the len cache. */
2152 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2155 register const char *s;
2158 switch (*mg->mg_ptr) {
2159 case '\001': /* ^A */
2160 sv_setsv(PL_bodytarget, sv);
2162 case '\003': /* ^C */
2163 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2166 case '\004': /* ^D */
2168 s = SvPV_nolen_const(sv);
2169 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2170 DEBUG_x(dump_all());
2172 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2175 case '\005': /* ^E */
2176 if (*(mg->mg_ptr+1) == '\0') {
2177 #ifdef MACOS_TRADITIONAL
2178 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2181 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2184 SetLastError( SvIV(sv) );
2187 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2189 /* will anyone ever use this? */
2190 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2196 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2198 SvREFCNT_dec(PL_encoding);
2199 if (SvOK(sv) || SvGMAGICAL(sv)) {
2200 PL_encoding = newSVsv(sv);
2203 PL_encoding = Nullsv;
2207 case '\006': /* ^F */
2208 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2210 case '\010': /* ^H */
2211 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2213 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2214 Safefree(PL_inplace);
2215 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2217 case '\017': /* ^O */
2218 if (*(mg->mg_ptr+1) == '\0') {
2219 Safefree(PL_osname);
2222 TAINT_PROPER("assigning to $^O");
2223 PL_osname = savesvpv(sv);
2226 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2227 if (!PL_compiling.cop_io)
2228 PL_compiling.cop_io = newSVsv(sv);
2230 sv_setsv(PL_compiling.cop_io,sv);
2233 case '\020': /* ^P */
2234 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235 if (PL_perldb && !PL_DBsingle)
2238 case '\024': /* ^T */
2240 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2242 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2245 case '\027': /* ^W & $^WARNING_BITS */
2246 if (*(mg->mg_ptr+1) == '\0') {
2247 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2248 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2249 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2250 | (i ? G_WARN_ON : G_WARN_OFF) ;
2253 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2254 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2255 if (!SvPOK(sv) && PL_localizing) {
2256 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2257 PL_compiling.cop_warnings = pWARN_NONE;
2262 int accumulate = 0 ;
2263 int any_fatals = 0 ;
2264 const char * const ptr = SvPV_const(sv, len) ;
2265 for (i = 0 ; i < len ; ++i) {
2266 accumulate |= ptr[i] ;
2267 any_fatals |= (ptr[i] & 0xAA) ;
2270 PL_compiling.cop_warnings = pWARN_NONE;
2271 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2272 PL_compiling.cop_warnings = pWARN_ALL;
2273 PL_dowarn |= G_WARN_ONCE ;
2276 if (specialWARN(PL_compiling.cop_warnings))
2277 PL_compiling.cop_warnings = newSVsv(sv) ;
2279 sv_setsv(PL_compiling.cop_warnings, sv);
2280 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2281 PL_dowarn |= G_WARN_ONCE ;
2289 if (PL_localizing) {
2290 if (PL_localizing == 1)
2291 SAVESPTR(PL_last_in_gv);
2293 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2294 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2297 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2298 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2299 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2302 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2303 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2304 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2307 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2310 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2312 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2315 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2319 IO * const io = GvIOp(PL_defoutgv);
2322 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2323 IoFLAGS(io) &= ~IOf_FLUSH;
2325 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2326 PerlIO *ofp = IoOFP(io);
2328 (void)PerlIO_flush(ofp);
2329 IoFLAGS(io) |= IOf_FLUSH;
2335 SvREFCNT_dec(PL_rs);
2336 PL_rs = newSVsv(sv);
2340 SvREFCNT_dec(PL_ors_sv);
2341 if (SvOK(sv) || SvGMAGICAL(sv)) {
2342 PL_ors_sv = newSVsv(sv);
2350 SvREFCNT_dec(PL_ofs_sv);
2351 if (SvOK(sv) || SvGMAGICAL(sv)) {
2352 PL_ofs_sv = newSVsv(sv);
2359 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2362 #ifdef COMPLEX_STATUS
2363 if (PL_localizing == 2) {
2364 PL_statusvalue = LvTARGOFF(sv);
2365 PL_statusvalue_vms = LvTARGLEN(sv);
2369 #ifdef VMSISH_STATUS
2371 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2374 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2379 # define PERL_VMS_BANG vaxc$errno
2381 # define PERL_VMS_BANG 0
2383 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2384 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2388 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2389 if (PL_delaymagic) {
2390 PL_delaymagic |= DM_RUID;
2391 break; /* don't do magic till later */
2394 (void)setruid((Uid_t)PL_uid);
2397 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2399 #ifdef HAS_SETRESUID
2400 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2402 if (PL_uid == PL_euid) { /* special case $< = $> */
2404 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2405 if (PL_uid != 0 && PerlProc_getuid() == 0)
2406 (void)PerlProc_setuid(0);
2408 (void)PerlProc_setuid(PL_uid);
2410 PL_uid = PerlProc_getuid();
2411 Perl_croak(aTHX_ "setruid() not implemented");
2416 PL_uid = PerlProc_getuid();
2417 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2420 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421 if (PL_delaymagic) {
2422 PL_delaymagic |= DM_EUID;
2423 break; /* don't do magic till later */
2426 (void)seteuid((Uid_t)PL_euid);
2429 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2431 #ifdef HAS_SETRESUID
2432 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2434 if (PL_euid == PL_uid) /* special case $> = $< */
2435 PerlProc_setuid(PL_euid);
2437 PL_euid = PerlProc_geteuid();
2438 Perl_croak(aTHX_ "seteuid() not implemented");
2443 PL_euid = PerlProc_geteuid();
2444 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2447 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2448 if (PL_delaymagic) {
2449 PL_delaymagic |= DM_RGID;
2450 break; /* don't do magic till later */
2453 (void)setrgid((Gid_t)PL_gid);
2456 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2458 #ifdef HAS_SETRESGID
2459 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2461 if (PL_gid == PL_egid) /* special case $( = $) */
2462 (void)PerlProc_setgid(PL_gid);
2464 PL_gid = PerlProc_getgid();
2465 Perl_croak(aTHX_ "setrgid() not implemented");
2470 PL_gid = PerlProc_getgid();
2471 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2474 #ifdef HAS_SETGROUPS
2476 const char *p = SvPV_const(sv, len);
2477 Groups_t *gary = NULL;
2482 for (i = 0; i < NGROUPS; ++i) {
2483 while (*p && !isSPACE(*p))
2490 Newx(gary, i + 1, Groups_t);
2492 Renew(gary, i + 1, Groups_t);
2496 (void)setgroups(i, gary);
2500 #else /* HAS_SETGROUPS */
2501 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2502 #endif /* HAS_SETGROUPS */
2503 if (PL_delaymagic) {
2504 PL_delaymagic |= DM_EGID;
2505 break; /* don't do magic till later */
2508 (void)setegid((Gid_t)PL_egid);
2511 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2513 #ifdef HAS_SETRESGID
2514 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2516 if (PL_egid == PL_gid) /* special case $) = $( */
2517 (void)PerlProc_setgid(PL_egid);
2519 PL_egid = PerlProc_getegid();
2520 Perl_croak(aTHX_ "setegid() not implemented");
2525 PL_egid = PerlProc_getegid();
2526 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2529 PL_chopset = SvPV_force(sv,len);
2531 #ifndef MACOS_TRADITIONAL
2533 LOCK_DOLLARZERO_MUTEX;
2534 #ifdef HAS_SETPROCTITLE
2535 /* The BSDs don't show the argv[] in ps(1) output, they
2536 * show a string from the process struct and provide
2537 * the setproctitle() routine to manipulate that. */
2538 if (PL_origalen != 1) {
2539 s = SvPV_const(sv, len);
2540 # if __FreeBSD_version > 410001
2541 /* The leading "-" removes the "perl: " prefix,
2542 * but not the "(perl) suffix from the ps(1)
2543 * output, because that's what ps(1) shows if the
2544 * argv[] is modified. */
2545 setproctitle("-%s", s);
2546 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2547 /* This doesn't really work if you assume that
2548 * $0 = 'foobar'; will wipe out 'perl' from the $0
2549 * because in ps(1) output the result will be like
2550 * sprintf("perl: %s (perl)", s)
2551 * I guess this is a security feature:
2552 * one (a user process) cannot get rid of the original name.
2554 setproctitle("%s", s);
2558 #if defined(__hpux) && defined(PSTAT_SETCMD)
2559 if (PL_origalen != 1) {
2561 s = SvPV_const(sv, len);
2562 un.pst_command = (char *)s;
2563 pstat(PSTAT_SETCMD, un, len, 0, 0);
2566 if (PL_origalen > 1) {
2567 /* PL_origalen is set in perl_parse(). */
2568 s = SvPV_force(sv,len);
2569 if (len >= (STRLEN)PL_origalen-1) {
2570 /* Longer than original, will be truncated. We assume that
2571 * PL_origalen bytes are available. */
2572 Copy(s, PL_origargv[0], PL_origalen-1, char);
2575 /* Shorter than original, will be padded. */
2576 Copy(s, PL_origargv[0], len, char);
2577 PL_origargv[0][len] = 0;
2578 memset(PL_origargv[0] + len + 1,
2579 /* Is the space counterintuitive? Yes.
2580 * (You were expecting \0?)
2581 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2584 PL_origalen - len - 1);
2586 PL_origargv[0][PL_origalen-1] = 0;
2587 for (i = 1; i < PL_origargc; i++)
2590 UNLOCK_DOLLARZERO_MUTEX;
2598 Perl_whichsig(pTHX_ const char *sig)
2600 register char* const* sigv;
2602 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2603 if (strEQ(sig,*sigv))
2604 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2606 if (strEQ(sig,"CHLD"))
2610 if (strEQ(sig,"CLD"))
2617 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2618 Perl_sighandler(int sig, ...)
2620 Perl_sighandler(int sig)
2623 #ifdef PERL_GET_SIG_CONTEXT
2624 dTHXa(PERL_GET_SIG_CONTEXT);
2631 SV * const tSv = PL_Sv;
2635 XPV * const tXpv = PL_Xpv;
2637 if (PL_savestack_ix + 15 <= PL_savestack_max)
2639 if (PL_markstack_ptr < PL_markstack_max - 2)
2641 if (PL_scopestack_ix < PL_scopestack_max - 3)
2644 if (!PL_psig_ptr[sig]) {
2645 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2650 /* Max number of items pushed there is 3*n or 4. We cannot fix
2651 infinity, so we fix 4 (in fact 5): */
2653 PL_savestack_ix += 5; /* Protect save in progress. */
2654 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2657 PL_markstack_ptr++; /* Protect mark. */
2659 PL_scopestack_ix += 1;
2660 /* sv_2cv is too complicated, try a simpler variant first: */
2661 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2662 || SvTYPE(cv) != SVt_PVCV) {
2664 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2667 if (!cv || !CvROOT(cv)) {
2668 if (ckWARN(WARN_SIGNAL))
2669 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2670 PL_sig_name[sig], (gv ? GvENAME(gv)
2677 if(PL_psig_name[sig]) {
2678 sv = SvREFCNT_inc(PL_psig_name[sig]);
2680 #if !defined(PERL_IMPLICIT_CONTEXT)
2684 sv = sv_newmortal();
2685 sv_setpv(sv,PL_sig_name[sig]);
2688 PUSHSTACKi(PERLSI_SIGNAL);
2691 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2693 struct sigaction oact;
2695 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2699 va_start(args, sig);
2700 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2703 SV *rv = newRV_noinc((SV*)sih);
2704 /* The siginfo fields signo, code, errno, pid, uid,
2705 * addr, status, and band are defined by POSIX/SUSv3. */
2706 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2707 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2708 #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. */
2709 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2710 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2711 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2712 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2713 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2714 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2718 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2727 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2730 if (SvTRUE(ERRSV)) {
2732 #ifdef HAS_SIGPROCMASK
2733 /* Handler "died", for example to get out of a restart-able read().
2734 * Before we re-do that on its behalf re-enable the signal which was
2735 * blocked by the system when we entered.
2739 sigaddset(&set,sig);
2740 sigprocmask(SIG_UNBLOCK, &set, NULL);
2742 /* Not clear if this will work */
2743 (void)rsignal(sig, SIG_IGN);
2744 (void)rsignal(sig, PL_csighandlerp);
2746 #endif /* !PERL_MICRO */
2747 Perl_die(aTHX_ Nullch);
2751 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2755 PL_scopestack_ix -= 1;
2758 PL_op = myop; /* Apparently not needed... */
2760 PL_Sv = tSv; /* Restore global temporaries. */
2767 S_restore_magic(pTHX_ const void *p)
2770 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2771 SV* const sv = mgs->mgs_sv;
2776 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2778 #ifdef PERL_OLD_COPY_ON_WRITE
2779 /* While magic was saved (and off) sv_setsv may well have seen
2780 this SV as a prime candidate for COW. */
2782 sv_force_normal_flags(sv, 0);
2786 SvFLAGS(sv) |= mgs->mgs_flags;
2789 if (SvGMAGICAL(sv)) {
2790 /* downgrade public flags to private,
2791 and discard any other private flags */
2793 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2795 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2796 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2801 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2803 /* If we're still on top of the stack, pop us off. (That condition
2804 * will be satisfied if restore_magic was called explicitly, but *not*
2805 * if it's being called via leave_scope.)
2806 * The reason for doing this is that otherwise, things like sv_2cv()
2807 * may leave alloc gunk on the savestack, and some code
2808 * (e.g. sighandler) doesn't expect that...
2810 if (PL_savestack_ix == mgs->mgs_ss_ix)
2812 I32 popval = SSPOPINT;
2813 assert(popval == SAVEt_DESTRUCTOR_X);
2814 PL_savestack_ix -= 2;
2816 assert(popval == SAVEt_ALLOC);
2818 PL_savestack_ix -= popval;
2824 S_unwind_handler_stack(pTHX_ const void *p)
2827 const U32 flags = *(const U32*)p;
2830 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2831 #if !defined(PERL_IMPLICIT_CONTEXT)
2833 SvREFCNT_dec(PL_sig_sv);
2839 * c-indentation-style: bsd
2841 * indent-tabs-mode: t
2844 * ex: set ts=8 sts=4 sw=4 noet: