3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
120 const MGVTBL* const vtbl = mg->mg_virtual;
122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
135 Do magic after a value is retrieved from the SV. See C<sv_magic>.
141 Perl_mg_get(pTHX_ SV *sv)
144 const I32 mgs_ix = SSNEW(sizeof(MGS));
145 const bool was_temp = (bool)SvTEMP(sv);
147 MAGIC *newmg, *head, *cur, *mg;
148 /* guard against sv having being freed midway by holding a private
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
155 sv_2mortal(SvREFCNT_inc_simple(sv));
160 save_magic(mgs_ix, sv);
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
166 newmg = cur = head = mg = SvMAGIC(sv);
168 const MGVTBL * const vtbl = mg->mg_virtual;
170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
173 /* guard against magic having been deleted - eg FETCH calling
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
183 mg = mg->mg_moremagic;
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
195 /* Were any new entries added? */
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
216 Do magic after a value is assigned to the SV. See C<sv_magic>.
222 Perl_mg_set(pTHX_ SV *sv)
225 const I32 mgs_ix = SSNEW(sizeof(MGS));
229 save_magic(mgs_ix, sv);
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
232 const MGVTBL* vtbl = mg->mg_virtual;
233 nextmg = mg->mg_moremagic; /* it may delete itself */
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
238 if (vtbl && vtbl->svt_set)
239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
247 =for apidoc mg_length
249 Report on the SV's length. See C<sv_magic>.
255 Perl_mg_length(pTHX_ SV *sv)
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 const MGVTBL * const vtbl = mg->mg_virtual;
263 if (vtbl && vtbl->svt_len) {
264 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
266 /* omit MGf_GSKIP -- not changed here */
267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
274 const U8 *s = (U8*)SvPV_const(sv, len);
275 len = Perl_utf8_length(aTHX_ s, s + len);
278 (void)SvPV_const(sv, len);
283 Perl_mg_size(pTHX_ SV *sv)
287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
288 const MGVTBL* const vtbl = mg->mg_virtual;
289 if (vtbl && vtbl->svt_len) {
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 save_magic(mgs_ix, sv);
293 /* omit MGf_GSKIP -- not changed here */
294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
306 Perl_croak(aTHX_ "Size magic not implemented");
315 Clear something magical that the SV represents. See C<sv_magic>.
321 Perl_mg_clear(pTHX_ SV *sv)
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
326 save_magic(mgs_ix, sv);
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 /* omit GSKIP -- never set here */
332 if (vtbl && vtbl->svt_clear)
333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 Finds the magic pointer for type matching the SV. See C<sv_magic>.
349 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
381 const char type = mg->mg_type;
384 (type == PERL_MAGIC_tied)
386 : (type == PERL_MAGIC_regdata && mg->mg_obj)
389 toLOWER(type), key, klen);
398 =for apidoc mg_localize
400 Copy some of the magic from an existing SV to new localized version of
401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
402 doesn't (eg taint, pos).
408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 MGVTBL* const vtbl = mg->mg_virtual;
414 switch (mg->mg_type) {
415 /* value magic types: don't copy */
418 case PERL_MAGIC_regex_global:
419 case PERL_MAGIC_nkeys:
420 #ifdef USE_LOCALE_COLLATE
421 case PERL_MAGIC_collxfrm:
424 case PERL_MAGIC_taint:
426 case PERL_MAGIC_vstring:
427 case PERL_MAGIC_utf8:
428 case PERL_MAGIC_substr:
429 case PERL_MAGIC_defelem:
430 case PERL_MAGIC_arylen:
432 case PERL_MAGIC_backref:
433 case PERL_MAGIC_arylen_p:
434 case PERL_MAGIC_rhash:
435 case PERL_MAGIC_symtab:
439 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
440 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
442 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
443 mg->mg_ptr, mg->mg_len);
445 /* container types should remain read-only across localization */
446 SvFLAGS(nsv) |= SvREADONLY(sv);
449 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
450 SvFLAGS(nsv) |= SvMAGICAL(sv);
460 Free any magic storage used by the SV. See C<sv_magic>.
466 Perl_mg_free(pTHX_ SV *sv)
470 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 moremagic = mg->mg_moremagic;
473 if (vtbl && vtbl->svt_free)
474 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
475 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
476 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
477 Safefree(mg->mg_ptr);
478 else if (mg->mg_len == HEf_SVKEY)
479 SvREFCNT_dec((SV*)mg->mg_ptr);
481 if (mg->mg_flags & MGf_REFCOUNTED)
482 SvREFCNT_dec(mg->mg_obj);
485 SvMAGIC_set(sv, NULL);
492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
498 register const REGEXP * const rx = PM_GETRE(PL_curpm);
501 ? rx->nparens /* @+ */
502 : rx->lastparen; /* @- */
510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 register const I32 paren = mg->mg_len;
521 if (paren <= (I32)rx->nparens &&
522 (s = rx->startp[paren]) != -1 &&
523 (t = rx->endp[paren]) != -1)
526 if (mg->mg_obj) /* @+ */
531 if (i > 0 && RX_MATCH_UTF8(rx)) {
532 const char * const b = rx->subbeg;
534 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
547 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
548 Perl_croak(aTHX_ PL_no_modify);
549 NORETURN_FUNCTION_END;
553 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
558 register const REGEXP *rx;
561 switch (*mg->mg_ptr) {
562 case '1': case '2': case '3': case '4':
563 case '5': case '6': case '7': case '8': case '9': case '&':
564 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
566 paren = atoi(mg->mg_ptr); /* $& is in [0] */
568 if (paren <= (I32)rx->nparens &&
569 (s1 = rx->startp[paren]) != -1 &&
570 (t1 = rx->endp[paren]) != -1)
574 if (i > 0 && RX_MATCH_UTF8(rx)) {
575 const char * const s = rx->subbeg + s1;
580 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
584 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
588 if (ckWARN(WARN_UNINITIALIZED))
593 if (ckWARN(WARN_UNINITIALIZED))
598 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
599 paren = rx->lastparen;
604 case '\016': /* ^N */
605 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
606 paren = rx->lastcloseparen;
612 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
613 if (rx->startp[0] != -1) {
624 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
625 if (rx->endp[0] != -1) {
626 i = rx->sublen - rx->endp[0];
637 if (!SvPOK(sv) && SvNIOK(sv)) {
645 #define SvRTRIM(sv) STMT_START { \
647 STRLEN len = SvCUR(sv); \
648 char * const p = SvPVX(sv); \
649 while (len > 0 && isSPACE(p[len-1])) \
651 SvCUR_set(sv, len); \
657 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
661 register char *s = NULL;
664 const char * const remaining = mg->mg_ptr + 1;
665 const char nextchar = *remaining;
667 switch (*mg->mg_ptr) {
668 case '\001': /* ^A */
669 sv_setsv(sv, PL_bodytarget);
671 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
672 if (nextchar == '\0') {
673 sv_setiv(sv, (IV)PL_minus_c);
675 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
676 sv_setiv(sv, (IV)STATUS_NATIVE);
680 case '\004': /* ^D */
681 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
683 case '\005': /* ^E */
684 if (nextchar == '\0') {
685 #if defined(MACOS_TRADITIONAL)
689 sv_setnv(sv,(double)gMacPerl_OSErr);
690 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
694 # include <descrip.h>
695 # include <starlet.h>
697 $DESCRIPTOR(msgdsc,msg);
698 sv_setnv(sv,(NV) vaxc$errno);
699 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
700 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));
719 DWORD dwErr = GetLastError();
720 sv_setnv(sv, (NV)dwErr);
722 PerlProc_GetOSError(sv, dwErr);
725 sv_setpvn(sv, "", 0);
730 const int saveerrno = errno;
731 sv_setnv(sv, (NV)errno);
732 sv_setpv(sv, errno ? Strerror(errno) : "");
737 SvNOK_on(sv); /* what a wonderful hack! */
739 else if (strEQ(remaining, "NCODING"))
740 sv_setsv(sv, PL_encoding);
742 case '\006': /* ^F */
743 sv_setiv(sv, (IV)PL_maxsysfd);
745 case '\010': /* ^H */
746 sv_setiv(sv, (IV)PL_hints);
748 case '\011': /* ^I */ /* NOT \t in EBCDIC */
750 sv_setpv(sv, PL_inplace);
752 sv_setsv(sv, &PL_sv_undef);
754 case '\017': /* ^O & ^OPEN */
755 if (nextchar == '\0') {
756 sv_setpv(sv, PL_osname);
759 else if (strEQ(remaining, "PEN")) {
760 if (!PL_compiling.cop_io)
761 sv_setsv(sv, &PL_sv_undef);
763 sv_setsv(sv, PL_compiling.cop_io);
767 case '\020': /* ^P */
768 sv_setiv(sv, (IV)PL_perldb);
770 case '\023': /* ^S */
771 if (nextchar == '\0') {
772 if (PL_lex_state != LEX_NOTPARSING)
775 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
780 case '\024': /* ^T */
781 if (nextchar == '\0') {
783 sv_setnv(sv, PL_basetime);
785 sv_setiv(sv, (IV)PL_basetime);
788 else if (strEQ(remaining, "AINT"))
789 sv_setiv(sv, PL_tainting
790 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
793 case '\025': /* $^UNICODE, $^UTF8LOCALE */
794 if (strEQ(remaining, "NICODE"))
795 sv_setuv(sv, (UV) PL_unicode);
796 else if (strEQ(remaining, "TF8LOCALE"))
797 sv_setuv(sv, (UV) PL_utf8locale);
799 case '\027': /* ^W & $^WARNING_BITS */
800 if (nextchar == '\0')
801 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
802 else if (strEQ(remaining, "ARNING_BITS")) {
803 if (PL_compiling.cop_warnings == pWARN_NONE) {
804 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
806 else if (PL_compiling.cop_warnings == pWARN_STD) {
809 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
813 else if (PL_compiling.cop_warnings == pWARN_ALL) {
814 /* Get the bit mask for $warnings::Bits{all}, because
815 * it could have been extended by warnings::register */
817 HV * const bits=get_hv("warnings::Bits", FALSE);
818 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
819 sv_setsv(sv, *bits_all);
822 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
826 sv_setsv(sv, PL_compiling.cop_warnings);
831 case '1': case '2': case '3': case '4':
832 case '5': case '6': case '7': case '8': case '9': case '&':
833 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
837 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
838 * XXX Does the new way break anything?
840 paren = atoi(mg->mg_ptr); /* $& is in [0] */
842 if (paren <= (I32)rx->nparens &&
843 (s1 = rx->startp[paren]) != -1 &&
844 (t1 = rx->endp[paren]) != -1)
852 const int oldtainted = PL_tainted;
855 PL_tainted = oldtainted;
856 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
861 if (RX_MATCH_TAINTED(rx)) {
862 MAGIC* const mg = SvMAGIC(sv);
865 SvMAGIC_set(sv, mg->mg_moremagic);
867 if ((mgt = SvMAGIC(sv))) {
868 mg->mg_moremagic = mgt;
878 sv_setsv(sv,&PL_sv_undef);
881 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
882 paren = rx->lastparen;
886 sv_setsv(sv,&PL_sv_undef);
888 case '\016': /* ^N */
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 paren = rx->lastcloseparen;
894 sv_setsv(sv,&PL_sv_undef);
897 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
898 if ((s = rx->subbeg) && rx->startp[0] != -1) {
903 sv_setsv(sv,&PL_sv_undef);
906 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
907 if (rx->subbeg && rx->endp[0] != -1) {
908 s = rx->subbeg + rx->endp[0];
909 i = rx->sublen - rx->endp[0];
913 sv_setsv(sv,&PL_sv_undef);
916 if (GvIO(PL_last_in_gv)) {
917 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
922 sv_setiv(sv, (IV)STATUS_CURRENT);
923 #ifdef COMPLEX_STATUS
924 LvTARGOFF(sv) = PL_statusvalue;
925 LvTARGLEN(sv) = PL_statusvalue_vms;
930 if (GvIOp(PL_defoutgv))
931 s = IoTOP_NAME(GvIOp(PL_defoutgv));
935 sv_setpv(sv,GvENAME(PL_defoutgv));
940 if (GvIOp(PL_defoutgv))
941 s = IoFMT_NAME(GvIOp(PL_defoutgv));
943 s = GvENAME(PL_defoutgv);
947 if (GvIOp(PL_defoutgv))
948 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
951 if (GvIOp(PL_defoutgv))
952 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
963 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
966 if (GvIOp(PL_defoutgv))
967 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
973 sv_copypv(sv, PL_ors_sv);
977 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
978 sv_setpv(sv, errno ? Strerror(errno) : "");
981 const int saveerrno = errno;
982 sv_setnv(sv, (NV)errno);
984 if (errno == errno_isOS2 || errno == errno_isOS2_set)
985 sv_setpv(sv, os2error(Perl_rc));
988 sv_setpv(sv, errno ? Strerror(errno) : "");
993 SvNOK_on(sv); /* what a wonderful hack! */
996 sv_setiv(sv, (IV)PL_uid);
999 sv_setiv(sv, (IV)PL_euid);
1002 sv_setiv(sv, (IV)PL_gid);
1005 sv_setiv(sv, (IV)PL_egid);
1007 #ifdef HAS_GETGROUPS
1009 Groups_t *gary = NULL;
1010 I32 i, num_groups = getgroups(0, gary);
1011 Newx(gary, num_groups, Groups_t);
1012 num_groups = getgroups(num_groups, gary);
1013 for (i = 0; i < num_groups; i++)
1014 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1017 (void)SvIOK_on(sv); /* what a wonderful hack! */
1020 #ifndef MACOS_TRADITIONAL
1029 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1031 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1033 if (uf && uf->uf_val)
1034 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1039 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1043 const char *s = SvPV_const(sv,len);
1044 const char * const ptr = MgPV_const(mg,klen);
1047 #ifdef DYNAMIC_ENV_FETCH
1048 /* We just undefd an environment var. Is a replacement */
1049 /* waiting in the wings? */
1051 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1053 s = SvPV_const(*valp, len);
1057 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1058 /* And you'll never guess what the dog had */
1059 /* in its mouth... */
1061 MgTAINTEDDIR_off(mg);
1063 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1064 char pathbuf[256], eltbuf[256], *cp, *elt;
1068 strncpy(eltbuf, s, 255);
1071 do { /* DCL$PATH may be a search list */
1072 while (1) { /* as may dev portion of any element */
1073 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1074 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1075 cando_by_name(S_IWUSR,0,elt) ) {
1076 MgTAINTEDDIR_on(mg);
1080 if ((cp = strchr(elt, ':')) != NULL)
1082 if (my_trnlnm(elt, eltbuf, j++))
1088 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1091 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1092 const char * const strend = s + len;
1094 while (s < strend) {
1098 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1099 s, strend, ':', &i);
1101 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1103 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1104 MgTAINTEDDIR_on(mg);
1110 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1116 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1118 PERL_UNUSED_ARG(sv);
1119 my_setenv(MgPV_nolen_const(mg),NULL);
1124 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1127 PERL_UNUSED_ARG(mg);
1129 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1131 if (PL_localizing) {
1134 hv_iterinit((HV*)sv);
1135 while ((entry = hv_iternext((HV*)sv))) {
1137 my_setenv(hv_iterkey(entry, &keylen),
1138 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1146 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1149 PERL_UNUSED_ARG(sv);
1150 PERL_UNUSED_ARG(mg);
1152 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1160 #ifdef HAS_SIGPROCMASK
1162 restore_sigmask(pTHX_ SV *save_sv)
1164 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1165 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1169 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1172 /* Are we fetching a signal entry? */
1173 const I32 i = whichsig(MgPV_nolen_const(mg));
1176 sv_setsv(sv,PL_psig_ptr[i]);
1178 Sighandler_t sigstate;
1179 sigstate = rsignal_state(i);
1180 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1181 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1186 /* cache state so we don't fetch it again */
1187 if(sigstate == (Sighandler_t) SIG_IGN)
1188 sv_setpv(sv,"IGNORE");
1190 sv_setsv(sv,&PL_sv_undef);
1191 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1198 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1200 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1201 * refactoring might be in order.
1204 register const char * const s = MgPV_nolen_const(mg);
1205 PERL_UNUSED_ARG(sv);
1208 if (strEQ(s,"__DIE__"))
1210 else if (strEQ(s,"__WARN__"))
1213 Perl_croak(aTHX_ "No such hook: %s", s);
1215 SV * const to_dec = *svp;
1217 SvREFCNT_dec(to_dec);
1221 /* Are we clearing a signal entry? */
1222 const I32 i = whichsig(s);
1224 #ifdef HAS_SIGPROCMASK
1227 /* Avoid having the signal arrive at a bad time, if possible. */
1230 sigprocmask(SIG_BLOCK, &set, &save);
1232 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1233 SAVEFREESV(save_sv);
1234 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1238 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1240 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1241 PL_sig_defaulting[i] = 1;
1242 (void)rsignal(i, PL_csighandlerp);
1244 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1246 if(PL_psig_name[i]) {
1247 SvREFCNT_dec(PL_psig_name[i]);
1250 if(PL_psig_ptr[i]) {
1251 SV * const to_dec=PL_psig_ptr[i];
1254 SvREFCNT_dec(to_dec);
1264 S_raise_signal(pTHX_ int sig)
1267 /* Set a flag to say this signal is pending */
1268 PL_psig_pend[sig]++;
1269 /* And one to say _a_ signal is pending */
1274 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1275 Perl_csighandler(int sig, ...)
1277 Perl_csighandler(int sig)
1280 #ifdef PERL_GET_SIG_CONTEXT
1281 dTHXa(PERL_GET_SIG_CONTEXT);
1285 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1286 (void) rsignal(sig, PL_csighandlerp);
1287 if (PL_sig_ignoring[sig]) return;
1289 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1290 if (PL_sig_defaulting[sig])
1291 #ifdef KILL_BY_SIGPRC
1292 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1297 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1298 /* Call the perl level handler now--
1299 * with risk we may be in malloc() etc. */
1300 (*PL_sighandlerp)(sig);
1302 S_raise_signal(aTHX_ sig);
1305 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1307 Perl_csighandler_init(void)
1310 if (PL_sig_handlers_initted) return;
1312 for (sig = 1; sig < SIG_SIZE; sig++) {
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1315 PL_sig_defaulting[sig] = 1;
1316 (void) rsignal(sig, PL_csighandlerp);
1318 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1319 PL_sig_ignoring[sig] = 0;
1322 PL_sig_handlers_initted = 1;
1327 Perl_despatch_signals(pTHX)
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333 if (PL_psig_pend[sig]) {
1334 PERL_BLOCKSIG_ADD(set, sig);
1335 PL_psig_pend[sig] = 0;
1336 PERL_BLOCKSIG_BLOCK(set);
1337 (*PL_sighandlerp)(sig);
1338 PERL_BLOCKSIG_UNBLOCK(set);
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1349 /* Need to be careful with SvREFCNT_dec(), because that can have side
1350 * effects (due to closures). We must make sure that the new disposition
1351 * is in place before it is called.
1355 #ifdef HAS_SIGPROCMASK
1360 register const char *s = MgPV_const(mg,len);
1362 if (strEQ(s,"__DIE__"))
1364 else if (strEQ(s,"__WARN__"))
1367 Perl_croak(aTHX_ "No such hook: %s", s);
1375 i = whichsig(s); /* ...no, a brick */
1377 if (ckWARN(WARN_SIGNAL))
1378 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1381 #ifdef HAS_SIGPROCMASK
1382 /* Avoid having the signal arrive at a bad time, if possible. */
1385 sigprocmask(SIG_BLOCK, &set, &save);
1387 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388 SAVEFREESV(save_sv);
1389 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396 PL_sig_ignoring[i] = 0;
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399 PL_sig_defaulting[i] = 0;
1401 SvREFCNT_dec(PL_psig_name[i]);
1402 to_dec = PL_psig_ptr[i];
1403 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1404 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405 PL_psig_name[i] = newSVpvn(s, len);
1406 SvREADONLY_on(PL_psig_name[i]);
1408 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1410 (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1416 *svp = SvREFCNT_inc_simple_NN(sv);
1418 SvREFCNT_dec(to_dec);
1421 s = SvPV_force(sv,len);
1422 if (strEQ(s,"IGNORE")) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425 PL_sig_ignoring[i] = 1;
1426 (void)rsignal(i, PL_csighandlerp);
1428 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1432 else if (strEQ(s,"DEFAULT") || !*s) {
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1436 PL_sig_defaulting[i] = 1;
1437 (void)rsignal(i, PL_csighandlerp);
1440 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1445 * We should warn if HINT_STRICT_REFS, but without
1446 * access to a known hint bit in a known OP, we can't
1447 * tell whether HINT_STRICT_REFS is in force or not.
1449 if (!strchr(s,':') && !strchr(s,'\''))
1450 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1452 (void)rsignal(i, PL_csighandlerp);
1454 *svp = SvREFCNT_inc_simple(sv);
1456 #ifdef HAS_SIGPROCMASK
1461 SvREFCNT_dec(to_dec);
1464 #endif /* !PERL_MICRO */
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1470 PERL_UNUSED_ARG(sv);
1471 PERL_UNUSED_ARG(mg);
1472 PL_sub_generation++;
1477 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1480 PERL_UNUSED_ARG(sv);
1481 PERL_UNUSED_ARG(mg);
1482 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1483 PL_amagic_generation++;
1489 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1491 HV * const hv = (HV*)LvTARG(sv);
1493 PERL_UNUSED_ARG(mg);
1496 (void) hv_iterinit(hv);
1497 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1500 while (hv_iternext(hv))
1505 sv_setiv(sv, (IV)i);
1510 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1512 PERL_UNUSED_ARG(mg);
1514 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1519 /* caller is responsible for stack switching/cleanup */
1521 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1528 PUSHs(SvTIED_obj(sv, mg));
1531 if (mg->mg_len >= 0)
1532 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1533 else if (mg->mg_len == HEf_SVKEY)
1534 PUSHs((SV*)mg->mg_ptr);
1536 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1537 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1545 return call_method(meth, flags);
1549 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1555 PUSHSTACKi(PERLSI_MAGIC);
1557 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1558 sv_setsv(sv, *PL_stack_sp--);
1568 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1571 mg->mg_flags |= MGf_GSKIP;
1572 magic_methpack(sv,mg,"FETCH");
1577 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1581 PUSHSTACKi(PERLSI_MAGIC);
1582 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1589 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1591 return magic_methpack(sv,mg,"DELETE");
1596 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1603 PUSHSTACKi(PERLSI_MAGIC);
1604 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1605 sv = *PL_stack_sp--;
1606 retval = (U32) SvIV(sv)-1;
1615 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1620 PUSHSTACKi(PERLSI_MAGIC);
1622 XPUSHs(SvTIED_obj(sv, mg));
1624 call_method("CLEAR", G_SCALAR|G_DISCARD);
1632 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1635 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1639 PUSHSTACKi(PERLSI_MAGIC);
1642 PUSHs(SvTIED_obj(sv, mg));
1647 if (call_method(meth, G_SCALAR))
1648 sv_setsv(key, *PL_stack_sp--);
1657 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1659 return magic_methpack(sv,mg,"EXISTS");
1663 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1666 SV *retval = &PL_sv_undef;
1667 SV * const tied = SvTIED_obj((SV*)hv, mg);
1668 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1670 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1672 if (HvEITER_get(hv))
1673 /* we are in an iteration so the hash cannot be empty */
1675 /* no xhv_eiter so now use FIRSTKEY */
1676 key = sv_newmortal();
1677 magic_nextpack((SV*)hv, mg, key);
1678 HvEITER_set(hv, NULL); /* need to reset iterator */
1679 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1682 /* there is a SCALAR method that we can call */
1684 PUSHSTACKi(PERLSI_MAGIC);
1690 if (call_method("SCALAR", G_SCALAR))
1691 retval = *PL_stack_sp--;
1698 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1701 GV * const gv = PL_DBline;
1702 const I32 i = SvTRUE(sv);
1703 SV ** const svp = av_fetch(GvAV(gv),
1704 atoi(MgPV_nolen_const(mg)), FALSE);
1705 if (svp && SvIOKp(*svp)) {
1706 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1708 /* set or clear breakpoint in the relevant control op */
1710 o->op_flags |= OPf_SPECIAL;
1712 o->op_flags &= ~OPf_SPECIAL;
1719 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1722 const AV * const obj = (AV*)mg->mg_obj;
1724 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1732 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1735 AV * const obj = (AV*)mg->mg_obj;
1737 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1739 if (ckWARN(WARN_MISC))
1740 Perl_warner(aTHX_ packWARN(WARN_MISC),
1741 "Attempt to set length of freed array");
1747 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1750 PERL_UNUSED_ARG(sv);
1751 /* during global destruction, mg_obj may already have been freed */
1752 if (PL_in_clean_all)
1755 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1758 /* arylen scalar holds a pointer back to the array, but doesn't own a
1759 reference. Hence the we (the array) are about to go away with it
1760 still pointing at us. Clear its pointer, else it would be pointing
1761 at free memory. See the comment in sv_magic about reference loops,
1762 and why it can't own a reference to us. */
1769 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1772 SV* const lsv = LvTARG(sv);
1774 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1775 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1776 if (mg && mg->mg_len >= 0) {
1779 sv_pos_b2u(lsv, &i);
1780 sv_setiv(sv, i + PL_curcop->cop_arybase);
1789 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1792 SV* const lsv = LvTARG(sv);
1799 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1800 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1804 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1805 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1807 else if (!SvOK(sv)) {
1811 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1813 pos = SvIV(sv) - PL_curcop->cop_arybase;
1816 ulen = sv_len_utf8(lsv);
1826 else if (pos > (SSize_t)len)
1831 sv_pos_u2b(lsv, &p, 0);
1836 mg->mg_flags &= ~MGf_MINMATCH;
1842 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1845 PERL_UNUSED_ARG(mg);
1849 if (SvFLAGS(sv) & SVp_SCREAM
1850 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1851 /* We're actually already a typeglob, so don't need the stuff below.
1855 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1860 GvGP(sv) = gp_ref(GvGP(gv));
1865 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1868 SV * const lsv = LvTARG(sv);
1869 const char * const tmps = SvPV_const(lsv,len);
1870 I32 offs = LvTARGOFF(sv);
1871 I32 rem = LvTARGLEN(sv);
1872 PERL_UNUSED_ARG(mg);
1875 sv_pos_u2b(lsv, &offs, &rem);
1876 if (offs > (I32)len)
1878 if (rem + offs > (I32)len)
1880 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1887 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1891 const char *tmps = SvPV_const(sv, len);
1892 SV * const lsv = LvTARG(sv);
1893 I32 lvoff = LvTARGOFF(sv);
1894 I32 lvlen = LvTARGLEN(sv);
1895 PERL_UNUSED_ARG(mg);
1898 sv_utf8_upgrade(lsv);
1899 sv_pos_u2b(lsv, &lvoff, &lvlen);
1900 sv_insert(lsv, lvoff, lvlen, tmps, len);
1901 LvTARGLEN(sv) = sv_len_utf8(sv);
1904 else if (lsv && SvUTF8(lsv)) {
1905 sv_pos_u2b(lsv, &lvoff, &lvlen);
1906 LvTARGLEN(sv) = len;
1907 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1908 sv_insert(lsv, lvoff, lvlen, tmps, len);
1912 sv_insert(lsv, lvoff, lvlen, tmps, len);
1913 LvTARGLEN(sv) = len;
1921 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1924 PERL_UNUSED_ARG(sv);
1925 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1930 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1933 PERL_UNUSED_ARG(sv);
1934 /* update taint status unless we're restoring at scope exit */
1935 if (PL_localizing != 2) {
1945 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1947 SV * const lsv = LvTARG(sv);
1948 PERL_UNUSED_ARG(mg);
1951 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1959 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1961 PERL_UNUSED_ARG(mg);
1962 do_vecset(sv); /* XXX slurp this routine */
1967 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1971 if (LvTARGLEN(sv)) {
1973 SV * const ahv = LvTARG(sv);
1974 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1979 AV* const av = (AV*)LvTARG(sv);
1980 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1981 targ = AvARRAY(av)[LvTARGOFF(sv)];
1983 if (targ && targ != &PL_sv_undef) {
1984 /* somebody else defined it for us */
1985 SvREFCNT_dec(LvTARG(sv));
1986 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
1988 SvREFCNT_dec(mg->mg_obj);
1990 mg->mg_flags &= ~MGf_REFCOUNTED;
1995 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2000 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2002 PERL_UNUSED_ARG(mg);
2006 sv_setsv(LvTARG(sv), sv);
2007 SvSETMAGIC(LvTARG(sv));
2013 Perl_vivify_defelem(pTHX_ SV *sv)
2019 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2022 SV * const ahv = LvTARG(sv);
2023 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2026 if (!value || value == &PL_sv_undef)
2027 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2030 AV* const av = (AV*)LvTARG(sv);
2031 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2032 LvTARG(sv) = NULL; /* array can't be extended */
2034 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2035 if (!svp || (value = *svp) == &PL_sv_undef)
2036 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2039 SvREFCNT_inc_simple_void(value);
2040 SvREFCNT_dec(LvTARG(sv));
2043 SvREFCNT_dec(mg->mg_obj);
2045 mg->mg_flags &= ~MGf_REFCOUNTED;
2049 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2051 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2055 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2057 PERL_UNUSED_CONTEXT;
2064 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2066 PERL_UNUSED_ARG(mg);
2067 sv_unmagic(sv, PERL_MAGIC_bm);
2073 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2075 PERL_UNUSED_ARG(mg);
2076 sv_unmagic(sv, PERL_MAGIC_fm);
2082 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2084 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2086 if (uf && uf->uf_set)
2087 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2092 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2094 PERL_UNUSED_ARG(mg);
2095 sv_unmagic(sv, PERL_MAGIC_qr);
2100 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2103 regexp * const re = (regexp *)mg->mg_obj;
2104 PERL_UNUSED_ARG(sv);
2110 #ifdef USE_LOCALE_COLLATE
2112 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2115 * RenE<eacute> Descartes said "I think not."
2116 * and vanished with a faint plop.
2118 PERL_UNUSED_CONTEXT;
2119 PERL_UNUSED_ARG(sv);
2121 Safefree(mg->mg_ptr);
2127 #endif /* USE_LOCALE_COLLATE */
2129 /* Just clear the UTF-8 cache data. */
2131 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2133 PERL_UNUSED_CONTEXT;
2134 PERL_UNUSED_ARG(sv);
2135 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2137 mg->mg_len = -1; /* The mg_len holds the len cache. */
2142 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2145 register const char *s;
2148 switch (*mg->mg_ptr) {
2149 case '\001': /* ^A */
2150 sv_setsv(PL_bodytarget, sv);
2152 case '\003': /* ^C */
2153 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2156 case '\004': /* ^D */
2158 s = SvPV_nolen_const(sv);
2159 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2160 DEBUG_x(dump_all());
2162 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2165 case '\005': /* ^E */
2166 if (*(mg->mg_ptr+1) == '\0') {
2167 #ifdef MACOS_TRADITIONAL
2168 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2171 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2174 SetLastError( SvIV(sv) );
2177 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2179 /* will anyone ever use this? */
2180 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2186 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2188 SvREFCNT_dec(PL_encoding);
2189 if (SvOK(sv) || SvGMAGICAL(sv)) {
2190 PL_encoding = newSVsv(sv);
2197 case '\006': /* ^F */
2198 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2200 case '\010': /* ^H */
2201 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2203 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2204 Safefree(PL_inplace);
2205 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2207 case '\017': /* ^O */
2208 if (*(mg->mg_ptr+1) == '\0') {
2209 Safefree(PL_osname);
2212 TAINT_PROPER("assigning to $^O");
2213 PL_osname = savesvpv(sv);
2216 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2217 if (!PL_compiling.cop_io)
2218 PL_compiling.cop_io = newSVsv(sv);
2220 sv_setsv(PL_compiling.cop_io,sv);
2223 case '\020': /* ^P */
2224 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2225 if (PL_perldb && !PL_DBsingle)
2228 case '\024': /* ^T */
2230 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2232 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2235 case '\027': /* ^W & $^WARNING_BITS */
2236 if (*(mg->mg_ptr+1) == '\0') {
2237 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2238 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2239 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2240 | (i ? G_WARN_ON : G_WARN_OFF) ;
2243 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2244 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2245 if (!SvPOK(sv) && PL_localizing) {
2246 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2247 PL_compiling.cop_warnings = pWARN_NONE;
2252 int accumulate = 0 ;
2253 int any_fatals = 0 ;
2254 const char * const ptr = SvPV_const(sv, len) ;
2255 for (i = 0 ; i < len ; ++i) {
2256 accumulate |= ptr[i] ;
2257 any_fatals |= (ptr[i] & 0xAA) ;
2260 PL_compiling.cop_warnings = pWARN_NONE;
2261 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2262 PL_compiling.cop_warnings = pWARN_ALL;
2263 PL_dowarn |= G_WARN_ONCE ;
2266 if (specialWARN(PL_compiling.cop_warnings))
2267 PL_compiling.cop_warnings = newSVsv(sv) ;
2269 sv_setsv(PL_compiling.cop_warnings, sv);
2270 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2271 PL_dowarn |= G_WARN_ONCE ;
2279 if (PL_localizing) {
2280 if (PL_localizing == 1)
2281 SAVESPTR(PL_last_in_gv);
2283 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2284 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2287 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2288 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2289 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2292 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2293 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2294 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2297 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2300 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2301 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2302 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2305 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2309 IO * const io = GvIOp(PL_defoutgv);
2312 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2313 IoFLAGS(io) &= ~IOf_FLUSH;
2315 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2316 PerlIO *ofp = IoOFP(io);
2318 (void)PerlIO_flush(ofp);
2319 IoFLAGS(io) |= IOf_FLUSH;
2325 SvREFCNT_dec(PL_rs);
2326 PL_rs = newSVsv(sv);
2330 SvREFCNT_dec(PL_ors_sv);
2331 if (SvOK(sv) || SvGMAGICAL(sv)) {
2332 PL_ors_sv = newSVsv(sv);
2340 SvREFCNT_dec(PL_ofs_sv);
2341 if (SvOK(sv) || SvGMAGICAL(sv)) {
2342 PL_ofs_sv = newSVsv(sv);
2349 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2352 #ifdef COMPLEX_STATUS
2353 if (PL_localizing == 2) {
2354 PL_statusvalue = LvTARGOFF(sv);
2355 PL_statusvalue_vms = LvTARGLEN(sv);
2359 #ifdef VMSISH_STATUS
2361 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2364 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2369 # define PERL_VMS_BANG vaxc$errno
2371 # define PERL_VMS_BANG 0
2373 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2374 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2378 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2379 if (PL_delaymagic) {
2380 PL_delaymagic |= DM_RUID;
2381 break; /* don't do magic till later */
2384 (void)setruid((Uid_t)PL_uid);
2387 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2389 #ifdef HAS_SETRESUID
2390 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2392 if (PL_uid == PL_euid) { /* special case $< = $> */
2394 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2395 if (PL_uid != 0 && PerlProc_getuid() == 0)
2396 (void)PerlProc_setuid(0);
2398 (void)PerlProc_setuid(PL_uid);
2400 PL_uid = PerlProc_getuid();
2401 Perl_croak(aTHX_ "setruid() not implemented");
2406 PL_uid = PerlProc_getuid();
2407 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2410 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2411 if (PL_delaymagic) {
2412 PL_delaymagic |= DM_EUID;
2413 break; /* don't do magic till later */
2416 (void)seteuid((Uid_t)PL_euid);
2419 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2421 #ifdef HAS_SETRESUID
2422 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2424 if (PL_euid == PL_uid) /* special case $> = $< */
2425 PerlProc_setuid(PL_euid);
2427 PL_euid = PerlProc_geteuid();
2428 Perl_croak(aTHX_ "seteuid() not implemented");
2433 PL_euid = PerlProc_geteuid();
2434 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2437 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2438 if (PL_delaymagic) {
2439 PL_delaymagic |= DM_RGID;
2440 break; /* don't do magic till later */
2443 (void)setrgid((Gid_t)PL_gid);
2446 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2448 #ifdef HAS_SETRESGID
2449 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2451 if (PL_gid == PL_egid) /* special case $( = $) */
2452 (void)PerlProc_setgid(PL_gid);
2454 PL_gid = PerlProc_getgid();
2455 Perl_croak(aTHX_ "setrgid() not implemented");
2460 PL_gid = PerlProc_getgid();
2461 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2464 #ifdef HAS_SETGROUPS
2466 const char *p = SvPV_const(sv, len);
2467 Groups_t *gary = NULL;
2472 for (i = 0; i < NGROUPS; ++i) {
2473 while (*p && !isSPACE(*p))
2480 Newx(gary, i + 1, Groups_t);
2482 Renew(gary, i + 1, Groups_t);
2486 (void)setgroups(i, gary);
2490 #else /* HAS_SETGROUPS */
2491 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2492 #endif /* HAS_SETGROUPS */
2493 if (PL_delaymagic) {
2494 PL_delaymagic |= DM_EGID;
2495 break; /* don't do magic till later */
2498 (void)setegid((Gid_t)PL_egid);
2501 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2503 #ifdef HAS_SETRESGID
2504 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2506 if (PL_egid == PL_gid) /* special case $) = $( */
2507 (void)PerlProc_setgid(PL_egid);
2509 PL_egid = PerlProc_getegid();
2510 Perl_croak(aTHX_ "setegid() not implemented");
2515 PL_egid = PerlProc_getegid();
2516 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2519 PL_chopset = SvPV_force(sv,len);
2521 #ifndef MACOS_TRADITIONAL
2523 LOCK_DOLLARZERO_MUTEX;
2524 #ifdef HAS_SETPROCTITLE
2525 /* The BSDs don't show the argv[] in ps(1) output, they
2526 * show a string from the process struct and provide
2527 * the setproctitle() routine to manipulate that. */
2528 if (PL_origalen != 1) {
2529 s = SvPV_const(sv, len);
2530 # if __FreeBSD_version > 410001
2531 /* The leading "-" removes the "perl: " prefix,
2532 * but not the "(perl) suffix from the ps(1)
2533 * output, because that's what ps(1) shows if the
2534 * argv[] is modified. */
2535 setproctitle("-%s", s);
2536 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2537 /* This doesn't really work if you assume that
2538 * $0 = 'foobar'; will wipe out 'perl' from the $0
2539 * because in ps(1) output the result will be like
2540 * sprintf("perl: %s (perl)", s)
2541 * I guess this is a security feature:
2542 * one (a user process) cannot get rid of the original name.
2544 setproctitle("%s", s);
2548 #if defined(__hpux) && defined(PSTAT_SETCMD)
2549 if (PL_origalen != 1) {
2551 s = SvPV_const(sv, len);
2552 un.pst_command = (char *)s;
2553 pstat(PSTAT_SETCMD, un, len, 0, 0);
2556 if (PL_origalen > 1) {
2557 /* PL_origalen is set in perl_parse(). */
2558 s = SvPV_force(sv,len);
2559 if (len >= (STRLEN)PL_origalen-1) {
2560 /* Longer than original, will be truncated. We assume that
2561 * PL_origalen bytes are available. */
2562 Copy(s, PL_origargv[0], PL_origalen-1, char);
2565 /* Shorter than original, will be padded. */
2566 Copy(s, PL_origargv[0], len, char);
2567 PL_origargv[0][len] = 0;
2568 memset(PL_origargv[0] + len + 1,
2569 /* Is the space counterintuitive? Yes.
2570 * (You were expecting \0?)
2571 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2574 PL_origalen - len - 1);
2576 PL_origargv[0][PL_origalen-1] = 0;
2577 for (i = 1; i < PL_origargc; i++)
2580 UNLOCK_DOLLARZERO_MUTEX;
2588 Perl_whichsig(pTHX_ const char *sig)
2590 register char* const* sigv;
2591 PERL_UNUSED_CONTEXT;
2593 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2594 if (strEQ(sig,*sigv))
2595 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2597 if (strEQ(sig,"CHLD"))
2601 if (strEQ(sig,"CLD"))
2608 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2609 Perl_sighandler(int sig, ...)
2611 Perl_sighandler(int sig)
2614 #ifdef PERL_GET_SIG_CONTEXT
2615 dTHXa(PERL_GET_SIG_CONTEXT);
2622 SV * const tSv = PL_Sv;
2626 XPV * const tXpv = PL_Xpv;
2628 if (PL_savestack_ix + 15 <= PL_savestack_max)
2630 if (PL_markstack_ptr < PL_markstack_max - 2)
2632 if (PL_scopestack_ix < PL_scopestack_max - 3)
2635 if (!PL_psig_ptr[sig]) {
2636 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2641 /* Max number of items pushed there is 3*n or 4. We cannot fix
2642 infinity, so we fix 4 (in fact 5): */
2644 PL_savestack_ix += 5; /* Protect save in progress. */
2645 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2648 PL_markstack_ptr++; /* Protect mark. */
2650 PL_scopestack_ix += 1;
2651 /* sv_2cv is too complicated, try a simpler variant first: */
2652 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2653 || SvTYPE(cv) != SVt_PVCV) {
2655 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2658 if (!cv || !CvROOT(cv)) {
2659 if (ckWARN(WARN_SIGNAL))
2660 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2661 PL_sig_name[sig], (gv ? GvENAME(gv)
2668 if(PL_psig_name[sig]) {
2669 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2671 #if !defined(PERL_IMPLICIT_CONTEXT)
2675 sv = sv_newmortal();
2676 sv_setpv(sv,PL_sig_name[sig]);
2679 PUSHSTACKi(PERLSI_SIGNAL);
2682 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2684 struct sigaction oact;
2686 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2690 va_start(args, sig);
2691 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2694 SV *rv = newRV_noinc((SV*)sih);
2695 /* The siginfo fields signo, code, errno, pid, uid,
2696 * addr, status, and band are defined by POSIX/SUSv3. */
2697 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2698 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2699 #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. */
2700 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2701 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2702 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2703 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2704 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2705 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2709 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2718 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2721 if (SvTRUE(ERRSV)) {
2723 #ifdef HAS_SIGPROCMASK
2724 /* Handler "died", for example to get out of a restart-able read().
2725 * Before we re-do that on its behalf re-enable the signal which was
2726 * blocked by the system when we entered.
2730 sigaddset(&set,sig);
2731 sigprocmask(SIG_UNBLOCK, &set, NULL);
2733 /* Not clear if this will work */
2734 (void)rsignal(sig, SIG_IGN);
2735 (void)rsignal(sig, PL_csighandlerp);
2737 #endif /* !PERL_MICRO */
2738 Perl_die(aTHX_ NULL);
2742 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2746 PL_scopestack_ix -= 1;
2749 PL_op = myop; /* Apparently not needed... */
2751 PL_Sv = tSv; /* Restore global temporaries. */
2758 S_restore_magic(pTHX_ const void *p)
2761 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2762 SV* const sv = mgs->mgs_sv;
2767 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2769 #ifdef PERL_OLD_COPY_ON_WRITE
2770 /* While magic was saved (and off) sv_setsv may well have seen
2771 this SV as a prime candidate for COW. */
2773 sv_force_normal_flags(sv, 0);
2777 SvFLAGS(sv) |= mgs->mgs_flags;
2780 if (SvGMAGICAL(sv)) {
2781 /* downgrade public flags to private,
2782 and discard any other private flags */
2784 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2786 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2787 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2792 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2794 /* If we're still on top of the stack, pop us off. (That condition
2795 * will be satisfied if restore_magic was called explicitly, but *not*
2796 * if it's being called via leave_scope.)
2797 * The reason for doing this is that otherwise, things like sv_2cv()
2798 * may leave alloc gunk on the savestack, and some code
2799 * (e.g. sighandler) doesn't expect that...
2801 if (PL_savestack_ix == mgs->mgs_ss_ix)
2803 I32 popval = SSPOPINT;
2804 assert(popval == SAVEt_DESTRUCTOR_X);
2805 PL_savestack_ix -= 2;
2807 assert(popval == SAVEt_ALLOC);
2809 PL_savestack_ix -= popval;
2815 S_unwind_handler_stack(pTHX_ const void *p)
2818 const U32 flags = *(const U32*)p;
2821 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2822 #if !defined(PERL_IMPLICIT_CONTEXT)
2824 SvREFCNT_dec(PL_sig_sv);
2830 * c-indentation-style: bsd
2832 * indent-tabs-mode: t
2835 * ex: set ts=8 sts=4 sw=4 noet: