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 #ifdef PERL_OLD_COPY_ON_WRITE
90 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
92 sv_force_normal_flags(sv, 0);
95 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
97 mgs = SSPTR(mgs_ix, MGS*);
99 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
100 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
104 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
108 =for apidoc mg_magical
110 Turns on the magical status of an SV. See C<sv_magic>.
116 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(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)
353 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
354 if (mg->mg_type == type)
364 Copies the magic from one SV to another. See C<sv_magic>.
370 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
374 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
375 const MGVTBL* const vtbl = mg->mg_virtual;
376 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
377 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
380 const char type = mg->mg_type;
383 (type == PERL_MAGIC_tied)
385 : (type == PERL_MAGIC_regdata && mg->mg_obj)
388 toLOWER(type), key, klen);
397 =for apidoc mg_localize
399 Copy some of the magic from an existing SV to new localized version of
400 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
401 doesn't (eg taint, pos).
407 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
411 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
412 const MGVTBL* const vtbl = mg->mg_virtual;
413 switch (mg->mg_type) {
414 /* value magic types: don't copy */
417 case PERL_MAGIC_regex_global:
418 case PERL_MAGIC_nkeys:
419 #ifdef USE_LOCALE_COLLATE
420 case PERL_MAGIC_collxfrm:
423 case PERL_MAGIC_taint:
425 case PERL_MAGIC_vstring:
426 case PERL_MAGIC_utf8:
427 case PERL_MAGIC_substr:
428 case PERL_MAGIC_defelem:
429 case PERL_MAGIC_arylen:
431 case PERL_MAGIC_backref:
432 case PERL_MAGIC_arylen_p:
433 case PERL_MAGIC_rhash:
434 case PERL_MAGIC_symtab:
438 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
439 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
441 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
442 mg->mg_ptr, mg->mg_len);
444 /* container types should remain read-only across localization */
445 SvFLAGS(nsv) |= SvREADONLY(sv);
448 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
449 SvFLAGS(nsv) |= SvMAGICAL(sv);
459 Free any magic storage used by the SV. See C<sv_magic>.
465 Perl_mg_free(pTHX_ SV *sv)
469 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
470 const MGVTBL* const vtbl = mg->mg_virtual;
471 moremagic = mg->mg_moremagic;
472 if (vtbl && vtbl->svt_free)
473 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
474 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
475 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
476 Safefree(mg->mg_ptr);
477 else if (mg->mg_len == HEf_SVKEY)
478 SvREFCNT_dec((SV*)mg->mg_ptr);
480 if (mg->mg_flags & MGf_REFCOUNTED)
481 SvREFCNT_dec(mg->mg_obj);
484 SvMAGIC_set(sv, NULL);
491 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
497 register const REGEXP * const rx = PM_GETRE(PL_curpm);
500 ? rx->nparens /* @+ */
501 : rx->lastparen; /* @- */
509 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
513 register const REGEXP * const rx = PM_GETRE(PL_curpm);
515 register const I32 paren = mg->mg_len;
520 if (paren <= (I32)rx->nparens &&
521 (s = rx->startp[paren]) != -1 &&
522 (t = rx->endp[paren]) != -1)
525 if (mg->mg_obj) /* @+ */
530 if (i > 0 && RX_MATCH_UTF8(rx)) {
531 const char * const b = rx->subbeg;
533 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
544 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
546 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
547 Perl_croak(aTHX_ PL_no_modify);
548 NORETURN_FUNCTION_END;
552 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
557 register const REGEXP *rx;
560 switch (*mg->mg_ptr) {
561 case '1': case '2': case '3': case '4':
562 case '5': case '6': case '7': case '8': case '9': case '&':
563 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
565 paren = atoi(mg->mg_ptr); /* $& is in [0] */
567 if (paren <= (I32)rx->nparens &&
568 (s1 = rx->startp[paren]) != -1 &&
569 (t1 = rx->endp[paren]) != -1)
573 if (i > 0 && RX_MATCH_UTF8(rx)) {
574 const char * const s = rx->subbeg + s1;
579 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
583 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
587 if (ckWARN(WARN_UNINITIALIZED))
592 if (ckWARN(WARN_UNINITIALIZED))
597 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
598 paren = rx->lastparen;
603 case '\016': /* ^N */
604 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
605 paren = rx->lastcloseparen;
611 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
612 if (rx->startp[0] != -1) {
623 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
624 if (rx->endp[0] != -1) {
625 i = rx->sublen - rx->endp[0];
636 if (!SvPOK(sv) && SvNIOK(sv)) {
644 #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); \
654 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
658 register char *s = NULL;
661 const char * const remaining = mg->mg_ptr + 1;
662 const char nextchar = *remaining;
664 switch (*mg->mg_ptr) {
665 case '\001': /* ^A */
666 sv_setsv(sv, PL_bodytarget);
668 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
669 if (nextchar == '\0') {
670 sv_setiv(sv, (IV)PL_minus_c);
672 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
673 sv_setiv(sv, (IV)STATUS_NATIVE);
677 case '\004': /* ^D */
678 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
680 case '\005': /* ^E */
681 if (nextchar == '\0') {
682 #ifdef MACOS_TRADITIONAL
686 sv_setnv(sv,(double)gMacPerl_OSErr);
687 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
692 # include <descrip.h>
693 # include <starlet.h>
695 $DESCRIPTOR(msgdsc,msg);
696 sv_setnv(sv,(NV) vaxc$errno);
697 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
698 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
704 if (!(_emx_env & 0x200)) { /* Under DOS */
705 sv_setnv(sv, (NV)errno);
706 sv_setpv(sv, errno ? Strerror(errno) : "");
708 if (errno != errno_isOS2) {
709 const int tmp = _syserrno();
710 if (tmp) /* 2nd call to _syserrno() makes it 0 */
713 sv_setnv(sv, (NV)Perl_rc);
714 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) : "");
740 SvNOK_on(sv); /* what a wonderful hack! */
742 else if (strEQ(remaining, "NCODING"))
743 sv_setsv(sv, PL_encoding);
745 case '\006': /* ^F */
746 sv_setiv(sv, (IV)PL_maxsysfd);
748 case '\010': /* ^H */
749 sv_setiv(sv, (IV)PL_hints);
751 case '\011': /* ^I */ /* NOT \t in EBCDIC */
753 sv_setpv(sv, PL_inplace);
755 sv_setsv(sv, &PL_sv_undef);
757 case '\017': /* ^O & ^OPEN */
758 if (nextchar == '\0') {
759 sv_setpv(sv, PL_osname);
762 else if (strEQ(remaining, "PEN")) {
763 if (!PL_compiling.cop_io)
764 sv_setsv(sv, &PL_sv_undef);
766 sv_setsv(sv, PL_compiling.cop_io);
770 case '\020': /* ^P */
771 sv_setiv(sv, (IV)PL_perldb);
773 case '\023': /* ^S */
774 if (nextchar == '\0') {
775 if (PL_lex_state != LEX_NOTPARSING)
778 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
783 case '\024': /* ^T */
784 if (nextchar == '\0') {
786 sv_setnv(sv, PL_basetime);
788 sv_setiv(sv, (IV)PL_basetime);
791 else if (strEQ(remaining, "AINT"))
792 sv_setiv(sv, PL_tainting
793 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
796 case '\025': /* $^UNICODE, $^UTF8LOCALE */
797 if (strEQ(remaining, "NICODE"))
798 sv_setuv(sv, (UV) PL_unicode);
799 else if (strEQ(remaining, "TF8LOCALE"))
800 sv_setuv(sv, (UV) PL_utf8locale);
802 case '\027': /* ^W & $^WARNING_BITS */
803 if (nextchar == '\0')
804 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
805 else if (strEQ(remaining, "ARNING_BITS")) {
806 if (PL_compiling.cop_warnings == pWARN_NONE) {
807 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
809 else if (PL_compiling.cop_warnings == pWARN_STD) {
812 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
816 else if (PL_compiling.cop_warnings == pWARN_ALL) {
817 /* Get the bit mask for $warnings::Bits{all}, because
818 * it could have been extended by warnings::register */
820 HV * const bits=get_hv("warnings::Bits", FALSE);
821 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
822 sv_setsv(sv, *bits_all);
825 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
829 sv_setsv(sv, PL_compiling.cop_warnings);
834 case '1': case '2': case '3': case '4':
835 case '5': case '6': case '7': case '8': case '9': case '&':
836 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
840 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
841 * XXX Does the new way break anything?
843 paren = atoi(mg->mg_ptr); /* $& is in [0] */
845 if (paren <= (I32)rx->nparens &&
846 (s1 = rx->startp[paren]) != -1 &&
847 (t1 = rx->endp[paren]) != -1)
856 const int oldtainted = PL_tainted;
859 PL_tainted = oldtainted;
860 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
865 if (RX_MATCH_TAINTED(rx)) {
866 MAGIC* const mg = SvMAGIC(sv);
869 SvMAGIC_set(sv, mg->mg_moremagic);
871 if ((mgt = SvMAGIC(sv))) {
872 mg->mg_moremagic = mgt;
882 sv_setsv(sv,&PL_sv_undef);
885 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
886 paren = rx->lastparen;
890 sv_setsv(sv,&PL_sv_undef);
892 case '\016': /* ^N */
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
894 paren = rx->lastcloseparen;
898 sv_setsv(sv,&PL_sv_undef);
901 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
902 if ((s = rx->subbeg) && rx->startp[0] != -1) {
907 sv_setsv(sv,&PL_sv_undef);
910 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
911 if (rx->subbeg && rx->endp[0] != -1) {
912 s = rx->subbeg + rx->endp[0];
913 i = rx->sublen - rx->endp[0];
917 sv_setsv(sv,&PL_sv_undef);
920 if (GvIO(PL_last_in_gv)) {
921 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
926 sv_setiv(sv, (IV)STATUS_CURRENT);
927 #ifdef COMPLEX_STATUS
928 LvTARGOFF(sv) = PL_statusvalue;
929 LvTARGLEN(sv) = PL_statusvalue_vms;
934 if (GvIOp(PL_defoutgv))
935 s = IoTOP_NAME(GvIOp(PL_defoutgv));
939 sv_setpv(sv,GvENAME(PL_defoutgv));
944 if (GvIOp(PL_defoutgv))
945 s = IoFMT_NAME(GvIOp(PL_defoutgv));
947 s = GvENAME(PL_defoutgv);
951 if (GvIOp(PL_defoutgv))
952 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
959 if (GvIOp(PL_defoutgv))
960 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
967 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
970 if (GvIOp(PL_defoutgv))
971 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
977 sv_copypv(sv, PL_ors_sv);
981 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
982 sv_setpv(sv, errno ? Strerror(errno) : "");
985 const int saveerrno = errno;
986 sv_setnv(sv, (NV)errno);
988 if (errno == errno_isOS2 || errno == errno_isOS2_set)
989 sv_setpv(sv, os2error(Perl_rc));
992 sv_setpv(sv, errno ? Strerror(errno) : "");
997 SvNOK_on(sv); /* what a wonderful hack! */
1000 sv_setiv(sv, (IV)PL_uid);
1003 sv_setiv(sv, (IV)PL_euid);
1006 sv_setiv(sv, (IV)PL_gid);
1009 sv_setiv(sv, (IV)PL_egid);
1011 #ifdef HAS_GETGROUPS
1013 Groups_t *gary = NULL;
1014 I32 i, num_groups = getgroups(0, gary);
1015 Newx(gary, num_groups, Groups_t);
1016 num_groups = getgroups(num_groups, gary);
1017 for (i = 0; i < num_groups; i++)
1018 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1021 (void)SvIOK_on(sv); /* what a wonderful hack! */
1024 #ifndef MACOS_TRADITIONAL
1033 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1035 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1037 if (uf && uf->uf_val)
1038 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1043 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1047 const char *s = SvPV_const(sv,len);
1048 const char * const ptr = MgPV_const(mg,klen);
1051 #ifdef DYNAMIC_ENV_FETCH
1052 /* We just undefd an environment var. Is a replacement */
1053 /* waiting in the wings? */
1055 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1057 s = SvPV_const(*valp, len);
1061 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1062 /* And you'll never guess what the dog had */
1063 /* in its mouth... */
1065 MgTAINTEDDIR_off(mg);
1067 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1068 char pathbuf[256], eltbuf[256], *cp, *elt;
1072 strncpy(eltbuf, s, 255);
1075 do { /* DCL$PATH may be a search list */
1076 while (1) { /* as may dev portion of any element */
1077 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079 cando_by_name(S_IWUSR,0,elt) ) {
1080 MgTAINTEDDIR_on(mg);
1084 if ((cp = strchr(elt, ':')) != Nullch)
1086 if (my_trnlnm(elt, eltbuf, j++))
1092 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1095 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1096 const char * const strend = s + len;
1098 while (s < strend) {
1102 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1103 s, strend, ':', &i);
1105 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1107 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1108 MgTAINTEDDIR_on(mg);
1114 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1120 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1122 PERL_UNUSED_ARG(sv);
1123 my_setenv(MgPV_nolen_const(mg),Nullch);
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1131 PERL_UNUSED_ARG(mg);
1133 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1135 if (PL_localizing) {
1138 hv_iterinit((HV*)sv);
1139 while ((entry = hv_iternext((HV*)sv))) {
1141 my_setenv(hv_iterkey(entry, &keylen),
1142 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1150 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1153 PERL_UNUSED_ARG(sv);
1154 PERL_UNUSED_ARG(mg);
1156 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1164 #ifdef HAS_SIGPROCMASK
1166 restore_sigmask(pTHX_ SV *save_sv)
1168 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1169 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1173 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1176 /* Are we fetching a signal entry? */
1177 const I32 i = whichsig(MgPV_nolen_const(mg));
1180 sv_setsv(sv,PL_psig_ptr[i]);
1182 Sighandler_t sigstate;
1183 sigstate = rsignal_state(i);
1184 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1185 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1187 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1188 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1190 /* cache state so we don't fetch it again */
1191 if(sigstate == (Sighandler_t) SIG_IGN)
1192 sv_setpv(sv,"IGNORE");
1194 sv_setsv(sv,&PL_sv_undef);
1195 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1202 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1204 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1205 * refactoring might be in order.
1208 register const char * const s = MgPV_nolen_const(mg);
1209 PERL_UNUSED_ARG(sv);
1212 if (strEQ(s,"__DIE__"))
1214 else if (strEQ(s,"__WARN__"))
1217 Perl_croak(aTHX_ "No such hook: %s", s);
1219 SV * const to_dec = *svp;
1221 SvREFCNT_dec(to_dec);
1225 /* Are we clearing a signal entry? */
1226 const I32 i = whichsig(s);
1228 #ifdef HAS_SIGPROCMASK
1231 /* Avoid having the signal arrive at a bad time, if possible. */
1234 sigprocmask(SIG_BLOCK, &set, &save);
1236 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1237 SAVEFREESV(save_sv);
1238 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1241 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1242 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1244 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1245 PL_sig_defaulting[i] = 1;
1246 (void)rsignal(i, PL_csighandlerp);
1248 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1250 if(PL_psig_name[i]) {
1251 SvREFCNT_dec(PL_psig_name[i]);
1254 if(PL_psig_ptr[i]) {
1255 SV * const to_dec=PL_psig_ptr[i];
1258 SvREFCNT_dec(to_dec);
1268 S_raise_signal(pTHX_ int sig)
1271 /* Set a flag to say this signal is pending */
1272 PL_psig_pend[sig]++;
1273 /* And one to say _a_ signal is pending */
1278 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1279 Perl_csighandler(int sig, ...)
1281 Perl_csighandler(int sig)
1284 #ifdef PERL_GET_SIG_CONTEXT
1285 dTHXa(PERL_GET_SIG_CONTEXT);
1289 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1290 (void) rsignal(sig, PL_csighandlerp);
1291 if (PL_sig_ignoring[sig]) return;
1293 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1294 if (PL_sig_defaulting[sig])
1295 #ifdef KILL_BY_SIGPRC
1296 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1301 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1302 /* Call the perl level handler now--
1303 * with risk we may be in malloc() etc. */
1304 (*PL_sighandlerp)(sig);
1306 S_raise_signal(aTHX_ sig);
1309 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1311 Perl_csighandler_init(void)
1314 if (PL_sig_handlers_initted) return;
1316 for (sig = 1; sig < SIG_SIZE; sig++) {
1317 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319 PL_sig_defaulting[sig] = 1;
1320 (void) rsignal(sig, PL_csighandlerp);
1322 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1323 PL_sig_ignoring[sig] = 0;
1326 PL_sig_handlers_initted = 1;
1331 Perl_despatch_signals(pTHX)
1336 for (sig = 1; sig < SIG_SIZE; sig++) {
1337 if (PL_psig_pend[sig]) {
1338 PERL_BLOCKSIG_ADD(set, sig);
1339 PL_psig_pend[sig] = 0;
1340 PERL_BLOCKSIG_BLOCK(set);
1341 (*PL_sighandlerp)(sig);
1342 PERL_BLOCKSIG_UNBLOCK(set);
1348 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1353 /* Need to be careful with SvREFCNT_dec(), because that can have side
1354 * effects (due to closures). We must make sure that the new disposition
1355 * is in place before it is called.
1359 #ifdef HAS_SIGPROCMASK
1364 register const char *s = MgPV_const(mg,len);
1366 if (strEQ(s,"__DIE__"))
1368 else if (strEQ(s,"__WARN__"))
1371 Perl_croak(aTHX_ "No such hook: %s", s);
1379 i = whichsig(s); /* ...no, a brick */
1381 if (ckWARN(WARN_SIGNAL))
1382 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1385 #ifdef HAS_SIGPROCMASK
1386 /* Avoid having the signal arrive at a bad time, if possible. */
1389 sigprocmask(SIG_BLOCK, &set, &save);
1391 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1392 SAVEFREESV(save_sv);
1393 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1396 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1397 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1399 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1400 PL_sig_ignoring[i] = 0;
1402 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1403 PL_sig_defaulting[i] = 0;
1405 SvREFCNT_dec(PL_psig_name[i]);
1406 to_dec = PL_psig_ptr[i];
1407 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1408 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1409 PL_psig_name[i] = newSVpvn(s, len);
1410 SvREADONLY_on(PL_psig_name[i]);
1412 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1414 (void)rsignal(i, PL_csighandlerp);
1415 #ifdef HAS_SIGPROCMASK
1420 *svp = SvREFCNT_inc(sv);
1422 SvREFCNT_dec(to_dec);
1425 s = SvPV_force(sv,len);
1426 if (strEQ(s,"IGNORE")) {
1428 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1429 PL_sig_ignoring[i] = 1;
1430 (void)rsignal(i, PL_csighandlerp);
1432 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1436 else if (strEQ(s,"DEFAULT") || !*s) {
1438 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 PL_sig_defaulting[i] = 1;
1441 (void)rsignal(i, PL_csighandlerp);
1444 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1449 * We should warn if HINT_STRICT_REFS, but without
1450 * access to a known hint bit in a known OP, we can't
1451 * tell whether HINT_STRICT_REFS is in force or not.
1453 if (!strchr(s,':') && !strchr(s,'\''))
1454 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1456 (void)rsignal(i, PL_csighandlerp);
1458 *svp = SvREFCNT_inc(sv);
1460 #ifdef HAS_SIGPROCMASK
1465 SvREFCNT_dec(to_dec);
1468 #endif /* !PERL_MICRO */
1471 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1474 PERL_UNUSED_ARG(sv);
1475 PERL_UNUSED_ARG(mg);
1476 PL_sub_generation++;
1481 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1484 PERL_UNUSED_ARG(sv);
1485 PERL_UNUSED_ARG(mg);
1486 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1487 PL_amagic_generation++;
1493 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1495 HV * const hv = (HV*)LvTARG(sv);
1497 PERL_UNUSED_ARG(mg);
1500 (void) hv_iterinit(hv);
1501 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1504 while (hv_iternext(hv))
1509 sv_setiv(sv, (IV)i);
1514 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1516 PERL_UNUSED_ARG(mg);
1518 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1523 /* caller is responsible for stack switching/cleanup */
1525 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1532 PUSHs(SvTIED_obj(sv, mg));
1535 if (mg->mg_len >= 0)
1536 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1537 else if (mg->mg_len == HEf_SVKEY)
1538 PUSHs((SV*)mg->mg_ptr);
1540 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1541 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1549 return call_method(meth, flags);
1553 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1559 PUSHSTACKi(PERLSI_MAGIC);
1561 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1562 sv_setsv(sv, *PL_stack_sp--);
1572 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1575 mg->mg_flags |= MGf_GSKIP;
1576 magic_methpack(sv,mg,"FETCH");
1581 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1585 PUSHSTACKi(PERLSI_MAGIC);
1586 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1593 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1595 return magic_methpack(sv,mg,"DELETE");
1600 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1607 PUSHSTACKi(PERLSI_MAGIC);
1608 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1609 sv = *PL_stack_sp--;
1610 retval = (U32) SvIV(sv)-1;
1619 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1624 PUSHSTACKi(PERLSI_MAGIC);
1626 XPUSHs(SvTIED_obj(sv, mg));
1628 call_method("CLEAR", G_SCALAR|G_DISCARD);
1636 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1639 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1643 PUSHSTACKi(PERLSI_MAGIC);
1646 PUSHs(SvTIED_obj(sv, mg));
1651 if (call_method(meth, G_SCALAR))
1652 sv_setsv(key, *PL_stack_sp--);
1661 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1663 return magic_methpack(sv,mg,"EXISTS");
1667 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1670 SV *retval = &PL_sv_undef;
1671 SV * const tied = SvTIED_obj((SV*)hv, mg);
1672 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1674 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1676 if (HvEITER_get(hv))
1677 /* we are in an iteration so the hash cannot be empty */
1679 /* no xhv_eiter so now use FIRSTKEY */
1680 key = sv_newmortal();
1681 magic_nextpack((SV*)hv, mg, key);
1682 HvEITER_set(hv, NULL); /* need to reset iterator */
1683 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1686 /* there is a SCALAR method that we can call */
1688 PUSHSTACKi(PERLSI_MAGIC);
1694 if (call_method("SCALAR", G_SCALAR))
1695 retval = *PL_stack_sp--;
1702 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1705 GV * const gv = PL_DBline;
1706 const I32 i = SvTRUE(sv);
1707 SV ** const svp = av_fetch(GvAV(gv),
1708 atoi(MgPV_nolen_const(mg)), FALSE);
1709 if (svp && SvIOKp(*svp)) {
1710 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1712 /* set or clear breakpoint in the relevant control op */
1714 o->op_flags |= OPf_SPECIAL;
1716 o->op_flags &= ~OPf_SPECIAL;
1723 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1726 const AV * const obj = (AV*)mg->mg_obj;
1728 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1736 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1739 AV * const obj = (AV*)mg->mg_obj;
1741 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1743 if (ckWARN(WARN_MISC))
1744 Perl_warner(aTHX_ packWARN(WARN_MISC),
1745 "Attempt to set length of freed array");
1751 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1754 PERL_UNUSED_ARG(sv);
1755 /* during global destruction, mg_obj may already have been freed */
1756 if (PL_in_clean_all)
1759 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1762 /* arylen scalar holds a pointer back to the array, but doesn't own a
1763 reference. Hence the we (the array) are about to go away with it
1764 still pointing at us. Clear its pointer, else it would be pointing
1765 at free memory. See the comment in sv_magic about reference loops,
1766 and why it can't own a reference to us. */
1773 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1776 SV* const lsv = LvTARG(sv);
1778 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1779 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1780 if (mg && mg->mg_len >= 0) {
1783 sv_pos_b2u(lsv, &i);
1784 sv_setiv(sv, i + PL_curcop->cop_arybase);
1793 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1796 SV* const lsv = LvTARG(sv);
1803 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1804 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1808 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1809 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1811 else if (!SvOK(sv)) {
1815 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1817 pos = SvIV(sv) - PL_curcop->cop_arybase;
1820 ulen = sv_len_utf8(lsv);
1830 else if (pos > (SSize_t)len)
1835 sv_pos_u2b(lsv, &p, 0);
1840 mg->mg_flags &= ~MGf_MINMATCH;
1846 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1848 PERL_UNUSED_ARG(mg);
1849 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1851 gv_efullname3(sv,((GV*)sv), "*");
1855 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1860 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1863 PERL_UNUSED_ARG(mg);
1867 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1872 GvGP(sv) = gp_ref(GvGP(gv));
1877 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1880 SV * const lsv = LvTARG(sv);
1881 const char * const tmps = SvPV_const(lsv,len);
1882 I32 offs = LvTARGOFF(sv);
1883 I32 rem = LvTARGLEN(sv);
1884 PERL_UNUSED_ARG(mg);
1887 sv_pos_u2b(lsv, &offs, &rem);
1888 if (offs > (I32)len)
1890 if (rem + offs > (I32)len)
1892 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1899 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1903 const char *tmps = SvPV_const(sv, len);
1904 SV * const lsv = LvTARG(sv);
1905 I32 lvoff = LvTARGOFF(sv);
1906 I32 lvlen = LvTARGLEN(sv);
1907 PERL_UNUSED_ARG(mg);
1910 sv_utf8_upgrade(lsv);
1911 sv_pos_u2b(lsv, &lvoff, &lvlen);
1912 sv_insert(lsv, lvoff, lvlen, tmps, len);
1913 LvTARGLEN(sv) = sv_len_utf8(sv);
1916 else if (lsv && SvUTF8(lsv)) {
1917 sv_pos_u2b(lsv, &lvoff, &lvlen);
1918 LvTARGLEN(sv) = len;
1919 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1920 sv_insert(lsv, lvoff, lvlen, tmps, len);
1924 sv_insert(lsv, lvoff, lvlen, tmps, len);
1925 LvTARGLEN(sv) = len;
1933 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1936 PERL_UNUSED_ARG(sv);
1937 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1942 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1945 PERL_UNUSED_ARG(sv);
1946 /* update taint status unless we're restoring at scope exit */
1947 if (PL_localizing != 2) {
1957 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1959 SV * const lsv = LvTARG(sv);
1960 PERL_UNUSED_ARG(mg);
1963 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1971 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1973 PERL_UNUSED_ARG(mg);
1974 do_vecset(sv); /* XXX slurp this routine */
1979 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1983 if (LvTARGLEN(sv)) {
1985 SV * const ahv = LvTARG(sv);
1986 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1991 AV* const av = (AV*)LvTARG(sv);
1992 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1993 targ = AvARRAY(av)[LvTARGOFF(sv)];
1995 if (targ && targ != &PL_sv_undef) {
1996 /* somebody else defined it for us */
1997 SvREFCNT_dec(LvTARG(sv));
1998 LvTARG(sv) = SvREFCNT_inc(targ);
2000 SvREFCNT_dec(mg->mg_obj);
2001 mg->mg_obj = Nullsv;
2002 mg->mg_flags &= ~MGf_REFCOUNTED;
2007 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2012 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2014 PERL_UNUSED_ARG(mg);
2018 sv_setsv(LvTARG(sv), sv);
2019 SvSETMAGIC(LvTARG(sv));
2025 Perl_vivify_defelem(pTHX_ SV *sv)
2031 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2034 SV * const ahv = LvTARG(sv);
2035 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2038 if (!value || value == &PL_sv_undef)
2039 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2042 AV* const av = (AV*)LvTARG(sv);
2043 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2044 LvTARG(sv) = Nullsv; /* array can't be extended */
2046 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2047 if (!svp || (value = *svp) == &PL_sv_undef)
2048 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2051 (void)SvREFCNT_inc(value);
2052 SvREFCNT_dec(LvTARG(sv));
2055 SvREFCNT_dec(mg->mg_obj);
2056 mg->mg_obj = Nullsv;
2057 mg->mg_flags &= ~MGf_REFCOUNTED;
2061 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2063 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2067 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2075 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2077 PERL_UNUSED_ARG(mg);
2078 sv_unmagic(sv, PERL_MAGIC_bm);
2084 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2086 PERL_UNUSED_ARG(mg);
2087 sv_unmagic(sv, PERL_MAGIC_fm);
2093 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2095 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2097 if (uf && uf->uf_set)
2098 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2103 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2105 PERL_UNUSED_ARG(mg);
2106 sv_unmagic(sv, PERL_MAGIC_qr);
2111 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2114 regexp * const re = (regexp *)mg->mg_obj;
2115 PERL_UNUSED_ARG(sv);
2121 #ifdef USE_LOCALE_COLLATE
2123 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2126 * RenE<eacute> Descartes said "I think not."
2127 * and vanished with a faint plop.
2129 PERL_UNUSED_ARG(sv);
2131 Safefree(mg->mg_ptr);
2137 #endif /* USE_LOCALE_COLLATE */
2139 /* Just clear the UTF-8 cache data. */
2141 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2143 PERL_UNUSED_ARG(sv);
2144 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2146 mg->mg_len = -1; /* The mg_len holds the len cache. */
2151 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2154 register const char *s;
2157 switch (*mg->mg_ptr) {
2158 case '\001': /* ^A */
2159 sv_setsv(PL_bodytarget, sv);
2161 case '\003': /* ^C */
2162 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2165 case '\004': /* ^D */
2167 s = SvPV_nolen_const(sv);
2168 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2169 DEBUG_x(dump_all());
2171 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2174 case '\005': /* ^E */
2175 if (*(mg->mg_ptr+1) == '\0') {
2176 #ifdef MACOS_TRADITIONAL
2177 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2180 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2183 SetLastError( SvIV(sv) );
2186 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2188 /* will anyone ever use this? */
2189 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2195 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2197 SvREFCNT_dec(PL_encoding);
2198 if (SvOK(sv) || SvGMAGICAL(sv)) {
2199 PL_encoding = newSVsv(sv);
2202 PL_encoding = Nullsv;
2206 case '\006': /* ^F */
2207 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2209 case '\010': /* ^H */
2210 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2212 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2213 Safefree(PL_inplace);
2214 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2216 case '\017': /* ^O */
2217 if (*(mg->mg_ptr+1) == '\0') {
2218 Safefree(PL_osname);
2221 TAINT_PROPER("assigning to $^O");
2222 PL_osname = savesvpv(sv);
2225 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2226 if (!PL_compiling.cop_io)
2227 PL_compiling.cop_io = newSVsv(sv);
2229 sv_setsv(PL_compiling.cop_io,sv);
2232 case '\020': /* ^P */
2233 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2234 if (PL_perldb && !PL_DBsingle)
2237 case '\024': /* ^T */
2239 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2241 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2244 case '\027': /* ^W & $^WARNING_BITS */
2245 if (*(mg->mg_ptr+1) == '\0') {
2246 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2247 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2248 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2249 | (i ? G_WARN_ON : G_WARN_OFF) ;
2252 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2253 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2254 if (!SvPOK(sv) && PL_localizing) {
2255 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2256 PL_compiling.cop_warnings = pWARN_NONE;
2261 int accumulate = 0 ;
2262 int any_fatals = 0 ;
2263 const char * const ptr = SvPV_const(sv, len) ;
2264 for (i = 0 ; i < len ; ++i) {
2265 accumulate |= ptr[i] ;
2266 any_fatals |= (ptr[i] & 0xAA) ;
2269 PL_compiling.cop_warnings = pWARN_NONE;
2270 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2271 PL_compiling.cop_warnings = pWARN_ALL;
2272 PL_dowarn |= G_WARN_ONCE ;
2275 if (specialWARN(PL_compiling.cop_warnings))
2276 PL_compiling.cop_warnings = newSVsv(sv) ;
2278 sv_setsv(PL_compiling.cop_warnings, sv);
2279 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2280 PL_dowarn |= G_WARN_ONCE ;
2288 if (PL_localizing) {
2289 if (PL_localizing == 1)
2290 SAVESPTR(PL_last_in_gv);
2292 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2293 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2296 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2297 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2298 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2301 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2302 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2303 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2306 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2309 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2310 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2311 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2314 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2318 IO * const io = GvIOp(PL_defoutgv);
2321 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2322 IoFLAGS(io) &= ~IOf_FLUSH;
2324 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2325 PerlIO *ofp = IoOFP(io);
2327 (void)PerlIO_flush(ofp);
2328 IoFLAGS(io) |= IOf_FLUSH;
2334 SvREFCNT_dec(PL_rs);
2335 PL_rs = newSVsv(sv);
2339 SvREFCNT_dec(PL_ors_sv);
2340 if (SvOK(sv) || SvGMAGICAL(sv)) {
2341 PL_ors_sv = newSVsv(sv);
2349 SvREFCNT_dec(PL_ofs_sv);
2350 if (SvOK(sv) || SvGMAGICAL(sv)) {
2351 PL_ofs_sv = newSVsv(sv);
2358 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2361 #ifdef COMPLEX_STATUS
2362 if (PL_localizing == 2) {
2363 PL_statusvalue = LvTARGOFF(sv);
2364 PL_statusvalue_vms = LvTARGLEN(sv);
2368 #ifdef VMSISH_STATUS
2370 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2373 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2378 # define PERL_VMS_BANG vaxc$errno
2380 # define PERL_VMS_BANG 0
2382 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2383 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2387 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2388 if (PL_delaymagic) {
2389 PL_delaymagic |= DM_RUID;
2390 break; /* don't do magic till later */
2393 (void)setruid((Uid_t)PL_uid);
2396 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2398 #ifdef HAS_SETRESUID
2399 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2401 if (PL_uid == PL_euid) { /* special case $< = $> */
2403 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2404 if (PL_uid != 0 && PerlProc_getuid() == 0)
2405 (void)PerlProc_setuid(0);
2407 (void)PerlProc_setuid(PL_uid);
2409 PL_uid = PerlProc_getuid();
2410 Perl_croak(aTHX_ "setruid() not implemented");
2415 PL_uid = PerlProc_getuid();
2416 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2419 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2420 if (PL_delaymagic) {
2421 PL_delaymagic |= DM_EUID;
2422 break; /* don't do magic till later */
2425 (void)seteuid((Uid_t)PL_euid);
2428 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2430 #ifdef HAS_SETRESUID
2431 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2433 if (PL_euid == PL_uid) /* special case $> = $< */
2434 PerlProc_setuid(PL_euid);
2436 PL_euid = PerlProc_geteuid();
2437 Perl_croak(aTHX_ "seteuid() not implemented");
2442 PL_euid = PerlProc_geteuid();
2443 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2446 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2447 if (PL_delaymagic) {
2448 PL_delaymagic |= DM_RGID;
2449 break; /* don't do magic till later */
2452 (void)setrgid((Gid_t)PL_gid);
2455 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2457 #ifdef HAS_SETRESGID
2458 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2460 if (PL_gid == PL_egid) /* special case $( = $) */
2461 (void)PerlProc_setgid(PL_gid);
2463 PL_gid = PerlProc_getgid();
2464 Perl_croak(aTHX_ "setrgid() not implemented");
2469 PL_gid = PerlProc_getgid();
2470 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2473 #ifdef HAS_SETGROUPS
2475 const char *p = SvPV_const(sv, len);
2476 Groups_t *gary = NULL;
2481 for (i = 0; i < NGROUPS; ++i) {
2482 while (*p && !isSPACE(*p))
2489 Newx(gary, i + 1, Groups_t);
2491 Renew(gary, i + 1, Groups_t);
2495 (void)setgroups(i, gary);
2499 #else /* HAS_SETGROUPS */
2500 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2501 #endif /* HAS_SETGROUPS */
2502 if (PL_delaymagic) {
2503 PL_delaymagic |= DM_EGID;
2504 break; /* don't do magic till later */
2507 (void)setegid((Gid_t)PL_egid);
2510 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2512 #ifdef HAS_SETRESGID
2513 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2515 if (PL_egid == PL_gid) /* special case $) = $( */
2516 (void)PerlProc_setgid(PL_egid);
2518 PL_egid = PerlProc_getegid();
2519 Perl_croak(aTHX_ "setegid() not implemented");
2524 PL_egid = PerlProc_getegid();
2525 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2528 PL_chopset = SvPV_force(sv,len);
2530 #ifndef MACOS_TRADITIONAL
2532 LOCK_DOLLARZERO_MUTEX;
2533 #ifdef HAS_SETPROCTITLE
2534 /* The BSDs don't show the argv[] in ps(1) output, they
2535 * show a string from the process struct and provide
2536 * the setproctitle() routine to manipulate that. */
2537 if (PL_origalen != 1) {
2538 s = SvPV_const(sv, len);
2539 # if __FreeBSD_version > 410001
2540 /* The leading "-" removes the "perl: " prefix,
2541 * but not the "(perl) suffix from the ps(1)
2542 * output, because that's what ps(1) shows if the
2543 * argv[] is modified. */
2544 setproctitle("-%s", s);
2545 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2546 /* This doesn't really work if you assume that
2547 * $0 = 'foobar'; will wipe out 'perl' from the $0
2548 * because in ps(1) output the result will be like
2549 * sprintf("perl: %s (perl)", s)
2550 * I guess this is a security feature:
2551 * one (a user process) cannot get rid of the original name.
2553 setproctitle("%s", s);
2557 #if defined(__hpux) && defined(PSTAT_SETCMD)
2558 if (PL_origalen != 1) {
2560 s = SvPV_const(sv, len);
2561 un.pst_command = (char *)s;
2562 pstat(PSTAT_SETCMD, un, len, 0, 0);
2565 if (PL_origalen > 1) {
2566 /* PL_origalen is set in perl_parse(). */
2567 s = SvPV_force(sv,len);
2568 if (len >= (STRLEN)PL_origalen-1) {
2569 /* Longer than original, will be truncated. We assume that
2570 * PL_origalen bytes are available. */
2571 Copy(s, PL_origargv[0], PL_origalen-1, char);
2574 /* Shorter than original, will be padded. */
2575 Copy(s, PL_origargv[0], len, char);
2576 PL_origargv[0][len] = 0;
2577 memset(PL_origargv[0] + len + 1,
2578 /* Is the space counterintuitive? Yes.
2579 * (You were expecting \0?)
2580 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2583 PL_origalen - len - 1);
2585 PL_origargv[0][PL_origalen-1] = 0;
2586 for (i = 1; i < PL_origargc; i++)
2589 UNLOCK_DOLLARZERO_MUTEX;
2597 Perl_whichsig(pTHX_ const char *sig)
2599 register char* const* sigv;
2601 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2602 if (strEQ(sig,*sigv))
2603 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2605 if (strEQ(sig,"CHLD"))
2609 if (strEQ(sig,"CLD"))
2616 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2617 Perl_sighandler(int sig, ...)
2619 Perl_sighandler(int sig)
2622 #ifdef PERL_GET_SIG_CONTEXT
2623 dTHXa(PERL_GET_SIG_CONTEXT);
2630 SV * const tSv = PL_Sv;
2634 XPV * const tXpv = PL_Xpv;
2636 if (PL_savestack_ix + 15 <= PL_savestack_max)
2638 if (PL_markstack_ptr < PL_markstack_max - 2)
2640 if (PL_scopestack_ix < PL_scopestack_max - 3)
2643 if (!PL_psig_ptr[sig]) {
2644 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2649 /* Max number of items pushed there is 3*n or 4. We cannot fix
2650 infinity, so we fix 4 (in fact 5): */
2652 PL_savestack_ix += 5; /* Protect save in progress. */
2653 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2656 PL_markstack_ptr++; /* Protect mark. */
2658 PL_scopestack_ix += 1;
2659 /* sv_2cv is too complicated, try a simpler variant first: */
2660 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2661 || SvTYPE(cv) != SVt_PVCV) {
2663 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2666 if (!cv || !CvROOT(cv)) {
2667 if (ckWARN(WARN_SIGNAL))
2668 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2669 PL_sig_name[sig], (gv ? GvENAME(gv)
2676 if(PL_psig_name[sig]) {
2677 sv = SvREFCNT_inc(PL_psig_name[sig]);
2679 #if !defined(PERL_IMPLICIT_CONTEXT)
2683 sv = sv_newmortal();
2684 sv_setpv(sv,PL_sig_name[sig]);
2687 PUSHSTACKi(PERLSI_SIGNAL);
2690 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2692 struct sigaction oact;
2694 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2698 va_start(args, sig);
2699 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2702 SV *rv = newRV_noinc((SV*)sih);
2703 /* The siginfo fields signo, code, errno, pid, uid,
2704 * addr, status, and band are defined by POSIX/SUSv3. */
2705 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2706 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2707 #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. */
2708 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2709 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2710 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2711 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2712 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2713 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2717 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2726 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2729 if (SvTRUE(ERRSV)) {
2731 #ifdef HAS_SIGPROCMASK
2732 /* Handler "died", for example to get out of a restart-able read().
2733 * Before we re-do that on its behalf re-enable the signal which was
2734 * blocked by the system when we entered.
2738 sigaddset(&set,sig);
2739 sigprocmask(SIG_UNBLOCK, &set, NULL);
2741 /* Not clear if this will work */
2742 (void)rsignal(sig, SIG_IGN);
2743 (void)rsignal(sig, PL_csighandlerp);
2745 #endif /* !PERL_MICRO */
2746 Perl_die(aTHX_ Nullch);
2750 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2754 PL_scopestack_ix -= 1;
2757 PL_op = myop; /* Apparently not needed... */
2759 PL_Sv = tSv; /* Restore global temporaries. */
2766 S_restore_magic(pTHX_ const void *p)
2769 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2770 SV* const sv = mgs->mgs_sv;
2775 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2777 #ifdef PERL_OLD_COPY_ON_WRITE
2778 /* While magic was saved (and off) sv_setsv may well have seen
2779 this SV as a prime candidate for COW. */
2781 sv_force_normal_flags(sv, 0);
2785 SvFLAGS(sv) |= mgs->mgs_flags;
2788 if (SvGMAGICAL(sv)) {
2789 /* downgrade public flags to private,
2790 and discard any other private flags */
2792 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2794 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2795 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2800 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2802 /* If we're still on top of the stack, pop us off. (That condition
2803 * will be satisfied if restore_magic was called explicitly, but *not*
2804 * if it's being called via leave_scope.)
2805 * The reason for doing this is that otherwise, things like sv_2cv()
2806 * may leave alloc gunk on the savestack, and some code
2807 * (e.g. sighandler) doesn't expect that...
2809 if (PL_savestack_ix == mgs->mgs_ss_ix)
2811 I32 popval = SSPOPINT;
2812 assert(popval == SAVEt_DESTRUCTOR_X);
2813 PL_savestack_ix -= 2;
2815 assert(popval == SAVEt_ALLOC);
2817 PL_savestack_ix -= popval;
2823 S_unwind_handler_stack(pTHX_ const void *p)
2826 const U32 flags = *(const U32*)p;
2829 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2830 #if !defined(PERL_IMPLICIT_CONTEXT)
2832 SvREFCNT_dec(PL_sig_sv);
2838 * c-indentation-style: bsd
2840 * indent-tabs-mode: t
2843 * ex: set ts=8 sts=4 sw=4 noet: