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); \
653 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
657 register char *s = NULL;
660 const char * const remaining = mg->mg_ptr + 1;
661 const char nextchar = *remaining;
663 switch (*mg->mg_ptr) {
664 case '\001': /* ^A */
665 sv_setsv(sv, PL_bodytarget);
667 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
668 if (nextchar == '\0') {
669 sv_setiv(sv, (IV)PL_minus_c);
671 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
672 sv_setiv(sv, (IV)STATUS_NATIVE);
676 case '\004': /* ^D */
677 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
679 case '\005': /* ^E */
680 if (nextchar == '\0') {
681 #ifdef MACOS_TRADITIONAL
685 sv_setnv(sv,(double)gMacPerl_OSErr);
686 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
691 # include <descrip.h>
692 # include <starlet.h>
694 $DESCRIPTOR(msgdsc,msg);
695 sv_setnv(sv,(NV) vaxc$errno);
696 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
697 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
703 if (!(_emx_env & 0x200)) { /* Under DOS */
704 sv_setnv(sv, (NV)errno);
705 sv_setpv(sv, errno ? Strerror(errno) : "");
707 if (errno != errno_isOS2) {
708 const int tmp = _syserrno();
709 if (tmp) /* 2nd call to _syserrno() makes it 0 */
712 sv_setnv(sv, (NV)Perl_rc);
713 sv_setpv(sv, os2error(Perl_rc));
718 DWORD dwErr = GetLastError();
719 sv_setnv(sv, (NV)dwErr);
721 PerlProc_GetOSError(sv, dwErr);
724 sv_setpvn(sv, "", 0);
729 const int saveerrno = errno;
730 sv_setnv(sv, (NV)errno);
731 sv_setpv(sv, errno ? Strerror(errno) : "");
739 SvNOK_on(sv); /* what a wonderful hack! */
741 else if (strEQ(remaining, "NCODING"))
742 sv_setsv(sv, PL_encoding);
744 case '\006': /* ^F */
745 sv_setiv(sv, (IV)PL_maxsysfd);
747 case '\010': /* ^H */
748 sv_setiv(sv, (IV)PL_hints);
750 case '\011': /* ^I */ /* NOT \t in EBCDIC */
752 sv_setpv(sv, PL_inplace);
754 sv_setsv(sv, &PL_sv_undef);
756 case '\017': /* ^O & ^OPEN */
757 if (nextchar == '\0') {
758 sv_setpv(sv, PL_osname);
761 else if (strEQ(remaining, "PEN")) {
762 if (!PL_compiling.cop_io)
763 sv_setsv(sv, &PL_sv_undef);
765 sv_setsv(sv, PL_compiling.cop_io);
769 case '\020': /* ^P */
770 sv_setiv(sv, (IV)PL_perldb);
772 case '\023': /* ^S */
773 if (nextchar == '\0') {
774 if (PL_lex_state != LEX_NOTPARSING)
777 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
782 case '\024': /* ^T */
783 if (nextchar == '\0') {
785 sv_setnv(sv, PL_basetime);
787 sv_setiv(sv, (IV)PL_basetime);
790 else if (strEQ(remaining, "AINT"))
791 sv_setiv(sv, PL_tainting
792 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
795 case '\025': /* $^UNICODE, $^UTF8LOCALE */
796 if (strEQ(remaining, "NICODE"))
797 sv_setuv(sv, (UV) PL_unicode);
798 else if (strEQ(remaining, "TF8LOCALE"))
799 sv_setuv(sv, (UV) PL_utf8locale);
801 case '\027': /* ^W & $^WARNING_BITS */
802 if (nextchar == '\0')
803 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
804 else if (strEQ(remaining, "ARNING_BITS")) {
805 if (PL_compiling.cop_warnings == pWARN_NONE) {
806 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
808 else if (PL_compiling.cop_warnings == pWARN_STD) {
811 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
815 else if (PL_compiling.cop_warnings == pWARN_ALL) {
816 /* Get the bit mask for $warnings::Bits{all}, because
817 * it could have been extended by warnings::register */
819 HV * const bits=get_hv("warnings::Bits", FALSE);
820 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
821 sv_setsv(sv, *bits_all);
824 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
828 sv_setsv(sv, PL_compiling.cop_warnings);
833 case '1': case '2': case '3': case '4':
834 case '5': case '6': case '7': case '8': case '9': case '&':
835 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
839 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
840 * XXX Does the new way break anything?
842 paren = atoi(mg->mg_ptr); /* $& is in [0] */
844 if (paren <= (I32)rx->nparens &&
845 (s1 = rx->startp[paren]) != -1 &&
846 (t1 = rx->endp[paren]) != -1)
855 const int oldtainted = PL_tainted;
858 PL_tainted = oldtainted;
859 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
864 if (RX_MATCH_TAINTED(rx)) {
865 MAGIC* const mg = SvMAGIC(sv);
868 SvMAGIC_set(sv, mg->mg_moremagic);
870 if ((mgt = SvMAGIC(sv))) {
871 mg->mg_moremagic = mgt;
881 sv_setsv(sv,&PL_sv_undef);
884 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
885 paren = rx->lastparen;
889 sv_setsv(sv,&PL_sv_undef);
891 case '\016': /* ^N */
892 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
893 paren = rx->lastcloseparen;
897 sv_setsv(sv,&PL_sv_undef);
900 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
901 if ((s = rx->subbeg) && rx->startp[0] != -1) {
906 sv_setsv(sv,&PL_sv_undef);
909 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
910 if (rx->subbeg && rx->endp[0] != -1) {
911 s = rx->subbeg + rx->endp[0];
912 i = rx->sublen - rx->endp[0];
916 sv_setsv(sv,&PL_sv_undef);
919 if (GvIO(PL_last_in_gv)) {
920 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
925 sv_setiv(sv, (IV)STATUS_CURRENT);
926 #ifdef COMPLEX_STATUS
927 LvTARGOFF(sv) = PL_statusvalue;
928 LvTARGLEN(sv) = PL_statusvalue_vms;
933 if (GvIOp(PL_defoutgv))
934 s = IoTOP_NAME(GvIOp(PL_defoutgv));
938 sv_setpv(sv,GvENAME(PL_defoutgv));
943 if (GvIOp(PL_defoutgv))
944 s = IoFMT_NAME(GvIOp(PL_defoutgv));
946 s = GvENAME(PL_defoutgv);
950 if (GvIOp(PL_defoutgv))
951 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
954 if (GvIOp(PL_defoutgv))
955 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
966 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
969 if (GvIOp(PL_defoutgv))
970 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
976 sv_copypv(sv, PL_ors_sv);
980 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
981 sv_setpv(sv, errno ? Strerror(errno) : "");
984 const int saveerrno = errno;
985 sv_setnv(sv, (NV)errno);
987 if (errno == errno_isOS2 || errno == errno_isOS2_set)
988 sv_setpv(sv, os2error(Perl_rc));
991 sv_setpv(sv, errno ? Strerror(errno) : "");
996 SvNOK_on(sv); /* what a wonderful hack! */
999 sv_setiv(sv, (IV)PL_uid);
1002 sv_setiv(sv, (IV)PL_euid);
1005 sv_setiv(sv, (IV)PL_gid);
1006 #ifdef HAS_GETGROUPS
1007 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
1011 sv_setiv(sv, (IV)PL_egid);
1012 #ifdef HAS_GETGROUPS
1013 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
1016 #ifdef HAS_GETGROUPS
1018 Groups_t *gary = NULL;
1019 I32 num_groups = getgroups(0, gary);
1020 Newx(gary, num_groups, Groups_t);
1021 num_groups = getgroups(num_groups, gary);
1022 while (--num_groups >= 0)
1023 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1028 (void)SvIOK_on(sv); /* what a wonderful hack! */
1030 #ifndef MACOS_TRADITIONAL
1039 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1041 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1043 if (uf && uf->uf_val)
1044 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1049 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1053 const char *s = SvPV_const(sv,len);
1054 const char * const ptr = MgPV_const(mg,klen);
1057 #ifdef DYNAMIC_ENV_FETCH
1058 /* We just undefd an environment var. Is a replacement */
1059 /* waiting in the wings? */
1061 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1063 s = SvPV_const(*valp, len);
1067 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1068 /* And you'll never guess what the dog had */
1069 /* in its mouth... */
1071 MgTAINTEDDIR_off(mg);
1073 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1074 char pathbuf[256], eltbuf[256], *cp, *elt;
1078 strncpy(eltbuf, s, 255);
1081 do { /* DCL$PATH may be a search list */
1082 while (1) { /* as may dev portion of any element */
1083 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1084 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1085 cando_by_name(S_IWUSR,0,elt) ) {
1086 MgTAINTEDDIR_on(mg);
1090 if ((cp = strchr(elt, ':')) != Nullch)
1092 if (my_trnlnm(elt, eltbuf, j++))
1098 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1101 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1102 const char * const strend = s + len;
1104 while (s < strend) {
1108 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1109 s, strend, ':', &i);
1111 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1113 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1114 MgTAINTEDDIR_on(mg);
1120 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1126 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1128 PERL_UNUSED_ARG(sv);
1129 my_setenv(MgPV_nolen_const(mg),Nullch);
1134 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1137 PERL_UNUSED_ARG(mg);
1139 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1141 if (PL_localizing) {
1144 hv_iterinit((HV*)sv);
1145 while ((entry = hv_iternext((HV*)sv))) {
1147 my_setenv(hv_iterkey(entry, &keylen),
1148 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1156 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1159 PERL_UNUSED_ARG(sv);
1160 PERL_UNUSED_ARG(mg);
1162 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1170 #ifdef HAS_SIGPROCMASK
1172 restore_sigmask(pTHX_ SV *save_sv)
1174 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1175 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1179 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1182 /* Are we fetching a signal entry? */
1183 const I32 i = whichsig(MgPV_nolen_const(mg));
1186 sv_setsv(sv,PL_psig_ptr[i]);
1188 Sighandler_t sigstate;
1189 sigstate = rsignal_state(i);
1190 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1191 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1193 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1194 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1196 /* cache state so we don't fetch it again */
1197 if(sigstate == (Sighandler_t) SIG_IGN)
1198 sv_setpv(sv,"IGNORE");
1200 sv_setsv(sv,&PL_sv_undef);
1201 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1208 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1210 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1211 * refactoring might be in order.
1214 register const char * const s = MgPV_nolen_const(mg);
1215 PERL_UNUSED_ARG(sv);
1218 if (strEQ(s,"__DIE__"))
1220 else if (strEQ(s,"__WARN__"))
1223 Perl_croak(aTHX_ "No such hook: %s", s);
1225 SV * const to_dec = *svp;
1227 SvREFCNT_dec(to_dec);
1231 /* Are we clearing a signal entry? */
1232 const I32 i = whichsig(s);
1234 #ifdef HAS_SIGPROCMASK
1237 /* Avoid having the signal arrive at a bad time, if possible. */
1240 sigprocmask(SIG_BLOCK, &set, &save);
1242 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1243 SAVEFREESV(save_sv);
1244 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1247 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1248 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1250 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1251 PL_sig_defaulting[i] = 1;
1252 (void)rsignal(i, PL_csighandlerp);
1254 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1256 if(PL_psig_name[i]) {
1257 SvREFCNT_dec(PL_psig_name[i]);
1260 if(PL_psig_ptr[i]) {
1261 SV * const to_dec=PL_psig_ptr[i];
1264 SvREFCNT_dec(to_dec);
1274 S_raise_signal(pTHX_ int sig)
1277 /* Set a flag to say this signal is pending */
1278 PL_psig_pend[sig]++;
1279 /* And one to say _a_ signal is pending */
1284 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1285 Perl_csighandler(int sig, ...)
1287 Perl_csighandler(int sig)
1290 #ifdef PERL_GET_SIG_CONTEXT
1291 dTHXa(PERL_GET_SIG_CONTEXT);
1295 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1296 (void) rsignal(sig, PL_csighandlerp);
1297 if (PL_sig_ignoring[sig]) return;
1299 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1300 if (PL_sig_defaulting[sig])
1301 #ifdef KILL_BY_SIGPRC
1302 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1307 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1308 /* Call the perl level handler now--
1309 * with risk we may be in malloc() etc. */
1310 (*PL_sighandlerp)(sig);
1312 S_raise_signal(aTHX_ sig);
1315 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1317 Perl_csighandler_init(void)
1320 if (PL_sig_handlers_initted) return;
1322 for (sig = 1; sig < SIG_SIZE; sig++) {
1323 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1325 PL_sig_defaulting[sig] = 1;
1326 (void) rsignal(sig, PL_csighandlerp);
1328 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1329 PL_sig_ignoring[sig] = 0;
1332 PL_sig_handlers_initted = 1;
1337 Perl_despatch_signals(pTHX)
1342 for (sig = 1; sig < SIG_SIZE; sig++) {
1343 if (PL_psig_pend[sig]) {
1344 PERL_BLOCKSIG_ADD(set, sig);
1345 PL_psig_pend[sig] = 0;
1346 PERL_BLOCKSIG_BLOCK(set);
1347 (*PL_sighandlerp)(sig);
1348 PERL_BLOCKSIG_UNBLOCK(set);
1354 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1359 /* Need to be careful with SvREFCNT_dec(), because that can have side
1360 * effects (due to closures). We must make sure that the new disposition
1361 * is in place before it is called.
1365 #ifdef HAS_SIGPROCMASK
1370 register const char *s = MgPV_const(mg,len);
1372 if (strEQ(s,"__DIE__"))
1374 else if (strEQ(s,"__WARN__"))
1377 Perl_croak(aTHX_ "No such hook: %s", s);
1385 i = whichsig(s); /* ...no, a brick */
1387 if (ckWARN(WARN_SIGNAL))
1388 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1391 #ifdef HAS_SIGPROCMASK
1392 /* Avoid having the signal arrive at a bad time, if possible. */
1395 sigprocmask(SIG_BLOCK, &set, &save);
1397 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1398 SAVEFREESV(save_sv);
1399 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1402 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1403 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1405 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1406 PL_sig_ignoring[i] = 0;
1408 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1409 PL_sig_defaulting[i] = 0;
1411 SvREFCNT_dec(PL_psig_name[i]);
1412 to_dec = PL_psig_ptr[i];
1413 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1414 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1415 PL_psig_name[i] = newSVpvn(s, len);
1416 SvREADONLY_on(PL_psig_name[i]);
1418 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1420 (void)rsignal(i, PL_csighandlerp);
1421 #ifdef HAS_SIGPROCMASK
1426 *svp = SvREFCNT_inc(sv);
1428 SvREFCNT_dec(to_dec);
1431 s = SvPV_force(sv,len);
1432 if (strEQ(s,"IGNORE")) {
1434 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1435 PL_sig_ignoring[i] = 1;
1436 (void)rsignal(i, PL_csighandlerp);
1438 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1442 else if (strEQ(s,"DEFAULT") || !*s) {
1444 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1446 PL_sig_defaulting[i] = 1;
1447 (void)rsignal(i, PL_csighandlerp);
1450 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1455 * We should warn if HINT_STRICT_REFS, but without
1456 * access to a known hint bit in a known OP, we can't
1457 * tell whether HINT_STRICT_REFS is in force or not.
1459 if (!strchr(s,':') && !strchr(s,'\''))
1460 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1462 (void)rsignal(i, PL_csighandlerp);
1464 *svp = SvREFCNT_inc(sv);
1466 #ifdef HAS_SIGPROCMASK
1471 SvREFCNT_dec(to_dec);
1474 #endif /* !PERL_MICRO */
1477 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1480 PERL_UNUSED_ARG(sv);
1481 PERL_UNUSED_ARG(mg);
1482 PL_sub_generation++;
1487 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1490 PERL_UNUSED_ARG(sv);
1491 PERL_UNUSED_ARG(mg);
1492 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1493 PL_amagic_generation++;
1499 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1501 HV * const hv = (HV*)LvTARG(sv);
1503 PERL_UNUSED_ARG(mg);
1506 (void) hv_iterinit(hv);
1507 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1510 while (hv_iternext(hv))
1515 sv_setiv(sv, (IV)i);
1520 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1522 PERL_UNUSED_ARG(mg);
1524 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1529 /* caller is responsible for stack switching/cleanup */
1531 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1538 PUSHs(SvTIED_obj(sv, mg));
1541 if (mg->mg_len >= 0)
1542 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1543 else if (mg->mg_len == HEf_SVKEY)
1544 PUSHs((SV*)mg->mg_ptr);
1546 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1547 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1555 return call_method(meth, flags);
1559 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1565 PUSHSTACKi(PERLSI_MAGIC);
1567 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1568 sv_setsv(sv, *PL_stack_sp--);
1578 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1581 mg->mg_flags |= MGf_GSKIP;
1582 magic_methpack(sv,mg,"FETCH");
1587 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1591 PUSHSTACKi(PERLSI_MAGIC);
1592 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1599 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1601 return magic_methpack(sv,mg,"DELETE");
1606 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1613 PUSHSTACKi(PERLSI_MAGIC);
1614 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1615 sv = *PL_stack_sp--;
1616 retval = (U32) SvIV(sv)-1;
1625 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1630 PUSHSTACKi(PERLSI_MAGIC);
1632 XPUSHs(SvTIED_obj(sv, mg));
1634 call_method("CLEAR", G_SCALAR|G_DISCARD);
1642 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1645 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1649 PUSHSTACKi(PERLSI_MAGIC);
1652 PUSHs(SvTIED_obj(sv, mg));
1657 if (call_method(meth, G_SCALAR))
1658 sv_setsv(key, *PL_stack_sp--);
1667 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1669 return magic_methpack(sv,mg,"EXISTS");
1673 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1676 SV *retval = &PL_sv_undef;
1677 SV * const tied = SvTIED_obj((SV*)hv, mg);
1678 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1680 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1682 if (HvEITER_get(hv))
1683 /* we are in an iteration so the hash cannot be empty */
1685 /* no xhv_eiter so now use FIRSTKEY */
1686 key = sv_newmortal();
1687 magic_nextpack((SV*)hv, mg, key);
1688 HvEITER_set(hv, NULL); /* need to reset iterator */
1689 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1692 /* there is a SCALAR method that we can call */
1694 PUSHSTACKi(PERLSI_MAGIC);
1700 if (call_method("SCALAR", G_SCALAR))
1701 retval = *PL_stack_sp--;
1708 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1711 GV * const gv = PL_DBline;
1712 const I32 i = SvTRUE(sv);
1713 SV ** const svp = av_fetch(GvAV(gv),
1714 atoi(MgPV_nolen_const(mg)), FALSE);
1715 if (svp && SvIOKp(*svp)) {
1716 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1718 /* set or clear breakpoint in the relevant control op */
1720 o->op_flags |= OPf_SPECIAL;
1722 o->op_flags &= ~OPf_SPECIAL;
1729 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1732 const AV * const obj = (AV*)mg->mg_obj;
1734 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1742 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1745 AV * const obj = (AV*)mg->mg_obj;
1747 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1749 if (ckWARN(WARN_MISC))
1750 Perl_warner(aTHX_ packWARN(WARN_MISC),
1751 "Attempt to set length of freed array");
1757 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1760 PERL_UNUSED_ARG(sv);
1761 /* during global destruction, mg_obj may already have been freed */
1762 if (PL_in_clean_all)
1765 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1768 /* arylen scalar holds a pointer back to the array, but doesn't own a
1769 reference. Hence the we (the array) are about to go away with it
1770 still pointing at us. Clear its pointer, else it would be pointing
1771 at free memory. See the comment in sv_magic about reference loops,
1772 and why it can't own a reference to us. */
1779 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1782 SV* const lsv = LvTARG(sv);
1784 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1785 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1786 if (mg && mg->mg_len >= 0) {
1789 sv_pos_b2u(lsv, &i);
1790 sv_setiv(sv, i + PL_curcop->cop_arybase);
1799 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1802 SV* const lsv = LvTARG(sv);
1809 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1810 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1814 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1815 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1817 else if (!SvOK(sv)) {
1821 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1823 pos = SvIV(sv) - PL_curcop->cop_arybase;
1826 ulen = sv_len_utf8(lsv);
1836 else if (pos > (SSize_t)len)
1841 sv_pos_u2b(lsv, &p, 0);
1846 mg->mg_flags &= ~MGf_MINMATCH;
1852 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1854 PERL_UNUSED_ARG(mg);
1855 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1857 gv_efullname3(sv,((GV*)sv), "*");
1861 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1866 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1869 PERL_UNUSED_ARG(mg);
1873 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1878 GvGP(sv) = gp_ref(GvGP(gv));
1883 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1886 SV * const lsv = LvTARG(sv);
1887 const char * const tmps = SvPV_const(lsv,len);
1888 I32 offs = LvTARGOFF(sv);
1889 I32 rem = LvTARGLEN(sv);
1890 PERL_UNUSED_ARG(mg);
1893 sv_pos_u2b(lsv, &offs, &rem);
1894 if (offs > (I32)len)
1896 if (rem + offs > (I32)len)
1898 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1905 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1909 const char *tmps = SvPV_const(sv, len);
1910 SV * const lsv = LvTARG(sv);
1911 I32 lvoff = LvTARGOFF(sv);
1912 I32 lvlen = LvTARGLEN(sv);
1913 PERL_UNUSED_ARG(mg);
1916 sv_utf8_upgrade(lsv);
1917 sv_pos_u2b(lsv, &lvoff, &lvlen);
1918 sv_insert(lsv, lvoff, lvlen, tmps, len);
1919 LvTARGLEN(sv) = sv_len_utf8(sv);
1922 else if (lsv && SvUTF8(lsv)) {
1923 sv_pos_u2b(lsv, &lvoff, &lvlen);
1924 LvTARGLEN(sv) = len;
1925 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1926 sv_insert(lsv, lvoff, lvlen, tmps, len);
1930 sv_insert(lsv, lvoff, lvlen, tmps, len);
1931 LvTARGLEN(sv) = len;
1939 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1942 PERL_UNUSED_ARG(sv);
1943 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1948 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1951 PERL_UNUSED_ARG(sv);
1952 /* update taint status unless we're restoring at scope exit */
1953 if (PL_localizing != 2) {
1963 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1965 SV * const lsv = LvTARG(sv);
1966 PERL_UNUSED_ARG(mg);
1969 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1977 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1979 PERL_UNUSED_ARG(mg);
1980 do_vecset(sv); /* XXX slurp this routine */
1985 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1989 if (LvTARGLEN(sv)) {
1991 SV * const ahv = LvTARG(sv);
1992 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1997 AV* const av = (AV*)LvTARG(sv);
1998 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1999 targ = AvARRAY(av)[LvTARGOFF(sv)];
2001 if (targ && targ != &PL_sv_undef) {
2002 /* somebody else defined it for us */
2003 SvREFCNT_dec(LvTARG(sv));
2004 LvTARG(sv) = SvREFCNT_inc(targ);
2006 SvREFCNT_dec(mg->mg_obj);
2007 mg->mg_obj = Nullsv;
2008 mg->mg_flags &= ~MGf_REFCOUNTED;
2013 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2018 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2020 PERL_UNUSED_ARG(mg);
2024 sv_setsv(LvTARG(sv), sv);
2025 SvSETMAGIC(LvTARG(sv));
2031 Perl_vivify_defelem(pTHX_ SV *sv)
2037 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2040 SV * const ahv = LvTARG(sv);
2041 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2044 if (!value || value == &PL_sv_undef)
2045 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2048 AV* const av = (AV*)LvTARG(sv);
2049 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2050 LvTARG(sv) = Nullsv; /* array can't be extended */
2052 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2053 if (!svp || (value = *svp) == &PL_sv_undef)
2054 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2057 (void)SvREFCNT_inc(value);
2058 SvREFCNT_dec(LvTARG(sv));
2061 SvREFCNT_dec(mg->mg_obj);
2062 mg->mg_obj = Nullsv;
2063 mg->mg_flags &= ~MGf_REFCOUNTED;
2067 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2069 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2073 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2081 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2083 PERL_UNUSED_ARG(mg);
2084 sv_unmagic(sv, PERL_MAGIC_bm);
2090 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2092 PERL_UNUSED_ARG(mg);
2093 sv_unmagic(sv, PERL_MAGIC_fm);
2099 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2101 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2103 if (uf && uf->uf_set)
2104 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2109 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2111 PERL_UNUSED_ARG(mg);
2112 sv_unmagic(sv, PERL_MAGIC_qr);
2117 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2120 regexp * const re = (regexp *)mg->mg_obj;
2121 PERL_UNUSED_ARG(sv);
2127 #ifdef USE_LOCALE_COLLATE
2129 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2132 * RenE<eacute> Descartes said "I think not."
2133 * and vanished with a faint plop.
2135 PERL_UNUSED_ARG(sv);
2137 Safefree(mg->mg_ptr);
2143 #endif /* USE_LOCALE_COLLATE */
2145 /* Just clear the UTF-8 cache data. */
2147 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2149 PERL_UNUSED_ARG(sv);
2150 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2152 mg->mg_len = -1; /* The mg_len holds the len cache. */
2157 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2160 register const char *s;
2163 switch (*mg->mg_ptr) {
2164 case '\001': /* ^A */
2165 sv_setsv(PL_bodytarget, sv);
2167 case '\003': /* ^C */
2168 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2171 case '\004': /* ^D */
2173 s = SvPV_nolen_const(sv);
2174 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2175 DEBUG_x(dump_all());
2177 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2180 case '\005': /* ^E */
2181 if (*(mg->mg_ptr+1) == '\0') {
2182 #ifdef MACOS_TRADITIONAL
2183 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2186 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2189 SetLastError( SvIV(sv) );
2192 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2194 /* will anyone ever use this? */
2195 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2201 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2203 SvREFCNT_dec(PL_encoding);
2204 if (SvOK(sv) || SvGMAGICAL(sv)) {
2205 PL_encoding = newSVsv(sv);
2208 PL_encoding = Nullsv;
2212 case '\006': /* ^F */
2213 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2215 case '\010': /* ^H */
2216 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2218 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2219 Safefree(PL_inplace);
2220 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2222 case '\017': /* ^O */
2223 if (*(mg->mg_ptr+1) == '\0') {
2224 Safefree(PL_osname);
2227 TAINT_PROPER("assigning to $^O");
2228 PL_osname = savesvpv(sv);
2231 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2232 if (!PL_compiling.cop_io)
2233 PL_compiling.cop_io = newSVsv(sv);
2235 sv_setsv(PL_compiling.cop_io,sv);
2238 case '\020': /* ^P */
2239 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2240 if (PL_perldb && !PL_DBsingle)
2243 case '\024': /* ^T */
2245 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2247 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2250 case '\027': /* ^W & $^WARNING_BITS */
2251 if (*(mg->mg_ptr+1) == '\0') {
2252 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2253 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2254 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2255 | (i ? G_WARN_ON : G_WARN_OFF) ;
2258 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2259 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2260 if (!SvPOK(sv) && PL_localizing) {
2261 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2262 PL_compiling.cop_warnings = pWARN_NONE;
2267 int accumulate = 0 ;
2268 int any_fatals = 0 ;
2269 const char * const ptr = SvPV_const(sv, len) ;
2270 for (i = 0 ; i < len ; ++i) {
2271 accumulate |= ptr[i] ;
2272 any_fatals |= (ptr[i] & 0xAA) ;
2275 PL_compiling.cop_warnings = pWARN_NONE;
2276 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2277 PL_compiling.cop_warnings = pWARN_ALL;
2278 PL_dowarn |= G_WARN_ONCE ;
2281 if (specialWARN(PL_compiling.cop_warnings))
2282 PL_compiling.cop_warnings = newSVsv(sv) ;
2284 sv_setsv(PL_compiling.cop_warnings, sv);
2285 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2286 PL_dowarn |= G_WARN_ONCE ;
2294 if (PL_localizing) {
2295 if (PL_localizing == 1)
2296 SAVESPTR(PL_last_in_gv);
2298 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2299 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2302 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2303 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2304 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2307 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2308 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2309 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2312 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2315 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2316 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2317 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2320 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2324 IO * const io = GvIOp(PL_defoutgv);
2327 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2328 IoFLAGS(io) &= ~IOf_FLUSH;
2330 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2331 PerlIO *ofp = IoOFP(io);
2333 (void)PerlIO_flush(ofp);
2334 IoFLAGS(io) |= IOf_FLUSH;
2340 SvREFCNT_dec(PL_rs);
2341 PL_rs = newSVsv(sv);
2345 SvREFCNT_dec(PL_ors_sv);
2346 if (SvOK(sv) || SvGMAGICAL(sv)) {
2347 PL_ors_sv = newSVsv(sv);
2355 SvREFCNT_dec(PL_ofs_sv);
2356 if (SvOK(sv) || SvGMAGICAL(sv)) {
2357 PL_ofs_sv = newSVsv(sv);
2364 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2367 #ifdef COMPLEX_STATUS
2368 if (PL_localizing == 2) {
2369 PL_statusvalue = LvTARGOFF(sv);
2370 PL_statusvalue_vms = LvTARGLEN(sv);
2374 #ifdef VMSISH_STATUS
2376 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2379 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2384 # define PERL_VMS_BANG vaxc$errno
2386 # define PERL_VMS_BANG 0
2388 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2389 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2393 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2394 if (PL_delaymagic) {
2395 PL_delaymagic |= DM_RUID;
2396 break; /* don't do magic till later */
2399 (void)setruid((Uid_t)PL_uid);
2402 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2404 #ifdef HAS_SETRESUID
2405 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2407 if (PL_uid == PL_euid) { /* special case $< = $> */
2409 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2410 if (PL_uid != 0 && PerlProc_getuid() == 0)
2411 (void)PerlProc_setuid(0);
2413 (void)PerlProc_setuid(PL_uid);
2415 PL_uid = PerlProc_getuid();
2416 Perl_croak(aTHX_ "setruid() not implemented");
2421 PL_uid = PerlProc_getuid();
2422 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2425 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2426 if (PL_delaymagic) {
2427 PL_delaymagic |= DM_EUID;
2428 break; /* don't do magic till later */
2431 (void)seteuid((Uid_t)PL_euid);
2434 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2436 #ifdef HAS_SETRESUID
2437 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2439 if (PL_euid == PL_uid) /* special case $> = $< */
2440 PerlProc_setuid(PL_euid);
2442 PL_euid = PerlProc_geteuid();
2443 Perl_croak(aTHX_ "seteuid() not implemented");
2448 PL_euid = PerlProc_geteuid();
2449 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2452 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2453 if (PL_delaymagic) {
2454 PL_delaymagic |= DM_RGID;
2455 break; /* don't do magic till later */
2458 (void)setrgid((Gid_t)PL_gid);
2461 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2463 #ifdef HAS_SETRESGID
2464 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2466 if (PL_gid == PL_egid) /* special case $( = $) */
2467 (void)PerlProc_setgid(PL_gid);
2469 PL_gid = PerlProc_getgid();
2470 Perl_croak(aTHX_ "setrgid() not implemented");
2475 PL_gid = PerlProc_getgid();
2476 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2479 #ifdef HAS_SETGROUPS
2481 const char *p = SvPV_const(sv, len);
2482 Groups_t *gary = NULL;
2487 for (i = 0; i < NGROUPS; ++i) {
2488 while (*p && !isSPACE(*p))
2495 Newx(gary, i + 1, Groups_t);
2497 Renew(gary, i + 1, Groups_t);
2501 (void)setgroups(i, gary);
2505 #else /* HAS_SETGROUPS */
2506 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2507 #endif /* HAS_SETGROUPS */
2508 if (PL_delaymagic) {
2509 PL_delaymagic |= DM_EGID;
2510 break; /* don't do magic till later */
2513 (void)setegid((Gid_t)PL_egid);
2516 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2518 #ifdef HAS_SETRESGID
2519 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2521 if (PL_egid == PL_gid) /* special case $) = $( */
2522 (void)PerlProc_setgid(PL_egid);
2524 PL_egid = PerlProc_getegid();
2525 Perl_croak(aTHX_ "setegid() not implemented");
2530 PL_egid = PerlProc_getegid();
2531 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2534 PL_chopset = SvPV_force(sv,len);
2536 #ifndef MACOS_TRADITIONAL
2538 LOCK_DOLLARZERO_MUTEX;
2539 #ifdef HAS_SETPROCTITLE
2540 /* The BSDs don't show the argv[] in ps(1) output, they
2541 * show a string from the process struct and provide
2542 * the setproctitle() routine to manipulate that. */
2544 s = SvPV_const(sv, len);
2545 # if __FreeBSD_version > 410001
2546 /* The leading "-" removes the "perl: " prefix,
2547 * but not the "(perl) suffix from the ps(1)
2548 * output, because that's what ps(1) shows if the
2549 * argv[] is modified. */
2550 setproctitle("-%s", s);
2551 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2552 /* This doesn't really work if you assume that
2553 * $0 = 'foobar'; will wipe out 'perl' from the $0
2554 * because in ps(1) output the result will be like
2555 * sprintf("perl: %s (perl)", s)
2556 * I guess this is a security feature:
2557 * one (a user process) cannot get rid of the original name.
2559 setproctitle("%s", s);
2563 #if defined(__hpux) && defined(PSTAT_SETCMD)
2566 s = SvPV_const(sv, len);
2567 un.pst_command = (char *)s;
2568 pstat(PSTAT_SETCMD, un, len, 0, 0);
2571 if (PL_origalen > 1) {
2572 /* PL_origalen is set in perl_parse(). */
2573 s = SvPV_force(sv,len);
2574 if (len >= (STRLEN)PL_origalen-1) {
2575 /* Longer than original, will be truncated. We assume that
2576 * PL_origalen bytes are available. */
2577 Copy(s, PL_origargv[0], PL_origalen-1, char);
2580 /* Shorter than original, will be padded. */
2581 Copy(s, PL_origargv[0], len, char);
2582 PL_origargv[0][len] = 0;
2583 memset(PL_origargv[0] + len + 1,
2584 /* Is the space counterintuitive? Yes.
2585 * (You were expecting \0?)
2586 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2589 PL_origalen - len - 1);
2591 PL_origargv[0][PL_origalen-1] = 0;
2592 for (i = 1; i < PL_origargc; i++)
2595 UNLOCK_DOLLARZERO_MUTEX;
2603 Perl_whichsig(pTHX_ const char *sig)
2605 register char* const* sigv;
2607 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2608 if (strEQ(sig,*sigv))
2609 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2611 if (strEQ(sig,"CHLD"))
2615 if (strEQ(sig,"CLD"))
2622 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2623 Perl_sighandler(int sig, ...)
2625 Perl_sighandler(int sig)
2628 #ifdef PERL_GET_SIG_CONTEXT
2629 dTHXa(PERL_GET_SIG_CONTEXT);
2636 SV * const tSv = PL_Sv;
2640 XPV * const tXpv = PL_Xpv;
2642 if (PL_savestack_ix + 15 <= PL_savestack_max)
2644 if (PL_markstack_ptr < PL_markstack_max - 2)
2646 if (PL_scopestack_ix < PL_scopestack_max - 3)
2649 if (!PL_psig_ptr[sig]) {
2650 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2655 /* Max number of items pushed there is 3*n or 4. We cannot fix
2656 infinity, so we fix 4 (in fact 5): */
2658 PL_savestack_ix += 5; /* Protect save in progress. */
2659 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2662 PL_markstack_ptr++; /* Protect mark. */
2664 PL_scopestack_ix += 1;
2665 /* sv_2cv is too complicated, try a simpler variant first: */
2666 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2667 || SvTYPE(cv) != SVt_PVCV) {
2669 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2672 if (!cv || !CvROOT(cv)) {
2673 if (ckWARN(WARN_SIGNAL))
2674 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2675 PL_sig_name[sig], (gv ? GvENAME(gv)
2682 if(PL_psig_name[sig]) {
2683 sv = SvREFCNT_inc(PL_psig_name[sig]);
2685 #if !defined(PERL_IMPLICIT_CONTEXT)
2689 sv = sv_newmortal();
2690 sv_setpv(sv,PL_sig_name[sig]);
2693 PUSHSTACKi(PERLSI_SIGNAL);
2696 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2698 struct sigaction oact;
2700 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2704 va_start(args, sig);
2705 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2708 SV *rv = newRV_noinc((SV*)sih);
2709 /* The siginfo fields signo, code, errno, pid, uid,
2710 * addr, status, and band are defined by POSIX/SUSv3. */
2711 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2712 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2713 #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. */
2714 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2715 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2716 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2717 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2718 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2719 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2723 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2732 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2735 if (SvTRUE(ERRSV)) {
2737 #ifdef HAS_SIGPROCMASK
2738 /* Handler "died", for example to get out of a restart-able read().
2739 * Before we re-do that on its behalf re-enable the signal which was
2740 * blocked by the system when we entered.
2744 sigaddset(&set,sig);
2745 sigprocmask(SIG_UNBLOCK, &set, NULL);
2747 /* Not clear if this will work */
2748 (void)rsignal(sig, SIG_IGN);
2749 (void)rsignal(sig, PL_csighandlerp);
2751 #endif /* !PERL_MICRO */
2752 Perl_die(aTHX_ Nullch);
2756 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2760 PL_scopestack_ix -= 1;
2763 PL_op = myop; /* Apparently not needed... */
2765 PL_Sv = tSv; /* Restore global temporaries. */
2772 S_restore_magic(pTHX_ const void *p)
2775 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2776 SV* const sv = mgs->mgs_sv;
2781 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2783 #ifdef PERL_OLD_COPY_ON_WRITE
2784 /* While magic was saved (and off) sv_setsv may well have seen
2785 this SV as a prime candidate for COW. */
2787 sv_force_normal_flags(sv, 0);
2791 SvFLAGS(sv) |= mgs->mgs_flags;
2794 if (SvGMAGICAL(sv)) {
2795 /* downgrade public flags to private,
2796 and discard any other private flags */
2798 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2800 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2801 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2806 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2808 /* If we're still on top of the stack, pop us off. (That condition
2809 * will be satisfied if restore_magic was called explicitly, but *not*
2810 * if it's being called via leave_scope.)
2811 * The reason for doing this is that otherwise, things like sv_2cv()
2812 * may leave alloc gunk on the savestack, and some code
2813 * (e.g. sighandler) doesn't expect that...
2815 if (PL_savestack_ix == mgs->mgs_ss_ix)
2817 I32 popval = SSPOPINT;
2818 assert(popval == SAVEt_DESTRUCTOR_X);
2819 PL_savestack_ix -= 2;
2821 assert(popval == SAVEt_ALLOC);
2823 PL_savestack_ix -= popval;
2829 S_unwind_handler_stack(pTHX_ const void *p)
2832 const U32 flags = *(const U32*)p;
2835 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2836 #if !defined(PERL_IMPLICIT_CONTEXT)
2838 SvREFCNT_dec(PL_sig_sv);
2844 * c-indentation-style: bsd
2846 * indent-tabs-mode: t
2849 * ex: set ts=8 sts=4 sw=4 noet: