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 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
648 SvCUR_set(sv, len); \
652 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
656 register char *s = NULL;
659 const char * const remaining = mg->mg_ptr + 1;
660 const char nextchar = *remaining;
662 switch (*mg->mg_ptr) {
663 case '\001': /* ^A */
664 sv_setsv(sv, PL_bodytarget);
666 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
667 if (nextchar == '\0') {
668 sv_setiv(sv, (IV)PL_minus_c);
670 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
671 sv_setiv(sv, (IV)STATUS_NATIVE);
675 case '\004': /* ^D */
676 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
678 case '\005': /* ^E */
679 if (nextchar == '\0') {
680 #ifdef MACOS_TRADITIONAL
684 sv_setnv(sv,(double)gMacPerl_OSErr);
685 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
690 # include <descrip.h>
691 # include <starlet.h>
693 $DESCRIPTOR(msgdsc,msg);
694 sv_setnv(sv,(NV) vaxc$errno);
695 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
696 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
702 if (!(_emx_env & 0x200)) { /* Under DOS */
703 sv_setnv(sv, (NV)errno);
704 sv_setpv(sv, errno ? Strerror(errno) : "");
706 if (errno != errno_isOS2) {
707 const int tmp = _syserrno();
708 if (tmp) /* 2nd call to _syserrno() makes it 0 */
711 sv_setnv(sv, (NV)Perl_rc);
712 sv_setpv(sv, os2error(Perl_rc));
717 DWORD dwErr = GetLastError();
718 sv_setnv(sv, (NV)dwErr);
720 PerlProc_GetOSError(sv, dwErr);
723 sv_setpvn(sv, "", 0);
728 const int saveerrno = errno;
729 sv_setnv(sv, (NV)errno);
730 sv_setpv(sv, errno ? Strerror(errno) : "");
738 SvNOK_on(sv); /* what a wonderful hack! */
740 else if (strEQ(remaining, "NCODING"))
741 sv_setsv(sv, PL_encoding);
743 case '\006': /* ^F */
744 sv_setiv(sv, (IV)PL_maxsysfd);
746 case '\010': /* ^H */
747 sv_setiv(sv, (IV)PL_hints);
749 case '\011': /* ^I */ /* NOT \t in EBCDIC */
751 sv_setpv(sv, PL_inplace);
753 sv_setsv(sv, &PL_sv_undef);
755 case '\017': /* ^O & ^OPEN */
756 if (nextchar == '\0') {
757 sv_setpv(sv, PL_osname);
760 else if (strEQ(remaining, "PEN")) {
761 if (!PL_compiling.cop_io)
762 sv_setsv(sv, &PL_sv_undef);
764 sv_setsv(sv, PL_compiling.cop_io);
768 case '\020': /* ^P */
769 sv_setiv(sv, (IV)PL_perldb);
771 case '\023': /* ^S */
772 if (nextchar == '\0') {
773 if (PL_lex_state != LEX_NOTPARSING)
776 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
781 case '\024': /* ^T */
782 if (nextchar == '\0') {
784 sv_setnv(sv, PL_basetime);
786 sv_setiv(sv, (IV)PL_basetime);
789 else if (strEQ(remaining, "AINT"))
790 sv_setiv(sv, PL_tainting
791 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
794 case '\025': /* $^UNICODE, $^UTF8LOCALE */
795 if (strEQ(remaining, "NICODE"))
796 sv_setuv(sv, (UV) PL_unicode);
797 else if (strEQ(remaining, "TF8LOCALE"))
798 sv_setuv(sv, (UV) PL_utf8locale);
800 case '\027': /* ^W & $^WARNING_BITS */
801 if (nextchar == '\0')
802 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
803 else if (strEQ(remaining, "ARNING_BITS")) {
804 if (PL_compiling.cop_warnings == pWARN_NONE) {
805 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
807 else if (PL_compiling.cop_warnings == pWARN_STD) {
810 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
814 else if (PL_compiling.cop_warnings == pWARN_ALL) {
815 /* Get the bit mask for $warnings::Bits{all}, because
816 * it could have been extended by warnings::register */
818 HV * const bits=get_hv("warnings::Bits", FALSE);
819 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
820 sv_setsv(sv, *bits_all);
823 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
827 sv_setsv(sv, PL_compiling.cop_warnings);
832 case '1': case '2': case '3': case '4':
833 case '5': case '6': case '7': case '8': case '9': case '&':
834 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
838 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
839 * XXX Does the new way break anything?
841 paren = atoi(mg->mg_ptr); /* $& is in [0] */
843 if (paren <= (I32)rx->nparens &&
844 (s1 = rx->startp[paren]) != -1 &&
845 (t1 = rx->endp[paren]) != -1)
854 const int oldtainted = PL_tainted;
857 PL_tainted = oldtainted;
858 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
863 if (RX_MATCH_TAINTED(rx)) {
864 MAGIC* const mg = SvMAGIC(sv);
867 SvMAGIC_set(sv, mg->mg_moremagic);
869 if ((mgt = SvMAGIC(sv))) {
870 mg->mg_moremagic = mgt;
880 sv_setsv(sv,&PL_sv_undef);
883 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
884 paren = rx->lastparen;
888 sv_setsv(sv,&PL_sv_undef);
890 case '\016': /* ^N */
891 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
892 paren = rx->lastcloseparen;
896 sv_setsv(sv,&PL_sv_undef);
899 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
900 if ((s = rx->subbeg) && rx->startp[0] != -1) {
905 sv_setsv(sv,&PL_sv_undef);
908 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
909 if (rx->subbeg && rx->endp[0] != -1) {
910 s = rx->subbeg + rx->endp[0];
911 i = rx->sublen - rx->endp[0];
915 sv_setsv(sv,&PL_sv_undef);
918 if (GvIO(PL_last_in_gv)) {
919 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
924 sv_setiv(sv, (IV)STATUS_CURRENT);
925 #ifdef COMPLEX_STATUS
926 LvTARGOFF(sv) = PL_statusvalue;
927 LvTARGLEN(sv) = PL_statusvalue_vms;
932 if (GvIOp(PL_defoutgv))
933 s = IoTOP_NAME(GvIOp(PL_defoutgv));
937 sv_setpv(sv,GvENAME(PL_defoutgv));
942 if (GvIOp(PL_defoutgv))
943 s = IoFMT_NAME(GvIOp(PL_defoutgv));
945 s = GvENAME(PL_defoutgv);
949 if (GvIOp(PL_defoutgv))
950 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
953 if (GvIOp(PL_defoutgv))
954 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
957 if (GvIOp(PL_defoutgv))
958 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
965 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
968 if (GvIOp(PL_defoutgv))
969 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
975 sv_copypv(sv, PL_ors_sv);
979 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
980 sv_setpv(sv, errno ? Strerror(errno) : "");
983 const int saveerrno = errno;
984 sv_setnv(sv, (NV)errno);
986 if (errno == errno_isOS2 || errno == errno_isOS2_set)
987 sv_setpv(sv, os2error(Perl_rc));
990 sv_setpv(sv, errno ? Strerror(errno) : "");
995 SvNOK_on(sv); /* what a wonderful hack! */
998 sv_setiv(sv, (IV)PL_uid);
1001 sv_setiv(sv, (IV)PL_euid);
1004 sv_setiv(sv, (IV)PL_gid);
1005 #ifdef HAS_GETGROUPS
1006 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
1010 sv_setiv(sv, (IV)PL_egid);
1011 #ifdef HAS_GETGROUPS
1012 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
1015 #ifdef HAS_GETGROUPS
1017 Groups_t *gary = NULL;
1018 I32 num_groups = getgroups(0, gary);
1019 Newx(gary, num_groups, Groups_t);
1020 num_groups = getgroups(num_groups, gary);
1021 while (--num_groups >= 0)
1022 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1027 (void)SvIOK_on(sv); /* what a wonderful hack! */
1029 #ifndef MACOS_TRADITIONAL
1038 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1040 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1042 if (uf && uf->uf_val)
1043 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1048 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1052 const char *s = SvPV_const(sv,len);
1053 const char * const ptr = MgPV_const(mg,klen);
1056 #ifdef DYNAMIC_ENV_FETCH
1057 /* We just undefd an environment var. Is a replacement */
1058 /* waiting in the wings? */
1060 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1062 s = SvPV_const(*valp, len);
1066 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1067 /* And you'll never guess what the dog had */
1068 /* in its mouth... */
1070 MgTAINTEDDIR_off(mg);
1072 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1073 char pathbuf[256], eltbuf[256], *cp, *elt;
1077 strncpy(eltbuf, s, 255);
1080 do { /* DCL$PATH may be a search list */
1081 while (1) { /* as may dev portion of any element */
1082 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1083 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1084 cando_by_name(S_IWUSR,0,elt) ) {
1085 MgTAINTEDDIR_on(mg);
1089 if ((cp = strchr(elt, ':')) != Nullch)
1091 if (my_trnlnm(elt, eltbuf, j++))
1097 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1100 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1101 const char * const strend = s + len;
1103 while (s < strend) {
1107 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1108 s, strend, ':', &i);
1110 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1112 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1113 MgTAINTEDDIR_on(mg);
1119 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1125 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1127 PERL_UNUSED_ARG(sv);
1128 my_setenv(MgPV_nolen_const(mg),Nullch);
1133 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1136 PERL_UNUSED_ARG(mg);
1138 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1140 if (PL_localizing) {
1143 hv_iterinit((HV*)sv);
1144 while ((entry = hv_iternext((HV*)sv))) {
1146 my_setenv(hv_iterkey(entry, &keylen),
1147 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1155 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1158 PERL_UNUSED_ARG(sv);
1159 PERL_UNUSED_ARG(mg);
1161 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1169 #ifdef HAS_SIGPROCMASK
1171 restore_sigmask(pTHX_ SV *save_sv)
1173 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1174 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1178 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1181 /* Are we fetching a signal entry? */
1182 const I32 i = whichsig(MgPV_nolen_const(mg));
1185 sv_setsv(sv,PL_psig_ptr[i]);
1187 Sighandler_t sigstate;
1188 sigstate = rsignal_state(i);
1189 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1190 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1192 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1193 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1195 /* cache state so we don't fetch it again */
1196 if(sigstate == (Sighandler_t) SIG_IGN)
1197 sv_setpv(sv,"IGNORE");
1199 sv_setsv(sv,&PL_sv_undef);
1200 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1207 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1209 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1210 * refactoring might be in order.
1213 register const char * const s = MgPV_nolen_const(mg);
1214 PERL_UNUSED_ARG(sv);
1217 if (strEQ(s,"__DIE__"))
1219 else if (strEQ(s,"__WARN__"))
1222 Perl_croak(aTHX_ "No such hook: %s", s);
1224 SV * const to_dec = *svp;
1226 SvREFCNT_dec(to_dec);
1230 /* Are we clearing a signal entry? */
1231 const I32 i = whichsig(s);
1233 #ifdef HAS_SIGPROCMASK
1236 /* Avoid having the signal arrive at a bad time, if possible. */
1239 sigprocmask(SIG_BLOCK, &set, &save);
1241 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1242 SAVEFREESV(save_sv);
1243 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1246 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1247 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1249 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1250 PL_sig_defaulting[i] = 1;
1251 (void)rsignal(i, PL_csighandlerp);
1253 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1255 if(PL_psig_name[i]) {
1256 SvREFCNT_dec(PL_psig_name[i]);
1259 if(PL_psig_ptr[i]) {
1260 SV *to_dec=PL_psig_ptr[i];
1263 SvREFCNT_dec(to_dec);
1273 S_raise_signal(pTHX_ int sig)
1276 /* Set a flag to say this signal is pending */
1277 PL_psig_pend[sig]++;
1278 /* And one to say _a_ signal is pending */
1283 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1284 Perl_csighandler(int sig, ...)
1286 Perl_csighandler(int sig)
1289 #ifdef PERL_GET_SIG_CONTEXT
1290 dTHXa(PERL_GET_SIG_CONTEXT);
1294 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1295 (void) rsignal(sig, PL_csighandlerp);
1296 if (PL_sig_ignoring[sig]) return;
1298 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1299 if (PL_sig_defaulting[sig])
1300 #ifdef KILL_BY_SIGPRC
1301 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1306 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1307 /* Call the perl level handler now--
1308 * with risk we may be in malloc() etc. */
1309 (*PL_sighandlerp)(sig);
1311 S_raise_signal(aTHX_ sig);
1314 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1316 Perl_csighandler_init(void)
1319 if (PL_sig_handlers_initted) return;
1321 for (sig = 1; sig < SIG_SIZE; sig++) {
1322 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1324 PL_sig_defaulting[sig] = 1;
1325 (void) rsignal(sig, PL_csighandlerp);
1327 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1328 PL_sig_ignoring[sig] = 0;
1331 PL_sig_handlers_initted = 1;
1336 Perl_despatch_signals(pTHX)
1341 for (sig = 1; sig < SIG_SIZE; sig++) {
1342 if (PL_psig_pend[sig]) {
1343 PERL_BLOCKSIG_ADD(set, sig);
1344 PL_psig_pend[sig] = 0;
1345 PERL_BLOCKSIG_BLOCK(set);
1346 (*PL_sighandlerp)(sig);
1347 PERL_BLOCKSIG_UNBLOCK(set);
1353 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1358 /* Need to be careful with SvREFCNT_dec(), because that can have side
1359 * effects (due to closures). We must make sure that the new disposition
1360 * is in place before it is called.
1364 #ifdef HAS_SIGPROCMASK
1369 register const char *s = MgPV_const(mg,len);
1371 if (strEQ(s,"__DIE__"))
1373 else if (strEQ(s,"__WARN__"))
1376 Perl_croak(aTHX_ "No such hook: %s", s);
1384 i = whichsig(s); /* ...no, a brick */
1386 if (ckWARN(WARN_SIGNAL))
1387 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1390 #ifdef HAS_SIGPROCMASK
1391 /* Avoid having the signal arrive at a bad time, if possible. */
1394 sigprocmask(SIG_BLOCK, &set, &save);
1396 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1397 SAVEFREESV(save_sv);
1398 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1401 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1402 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1404 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1405 PL_sig_ignoring[i] = 0;
1407 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1408 PL_sig_defaulting[i] = 0;
1410 SvREFCNT_dec(PL_psig_name[i]);
1411 to_dec = PL_psig_ptr[i];
1412 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1413 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1414 PL_psig_name[i] = newSVpvn(s, len);
1415 SvREADONLY_on(PL_psig_name[i]);
1417 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1419 (void)rsignal(i, PL_csighandlerp);
1420 #ifdef HAS_SIGPROCMASK
1425 *svp = SvREFCNT_inc(sv);
1427 SvREFCNT_dec(to_dec);
1430 s = SvPV_force(sv,len);
1431 if (strEQ(s,"IGNORE")) {
1433 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1434 PL_sig_ignoring[i] = 1;
1435 (void)rsignal(i, PL_csighandlerp);
1437 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1441 else if (strEQ(s,"DEFAULT") || !*s) {
1443 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1445 PL_sig_defaulting[i] = 1;
1446 (void)rsignal(i, PL_csighandlerp);
1449 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1454 * We should warn if HINT_STRICT_REFS, but without
1455 * access to a known hint bit in a known OP, we can't
1456 * tell whether HINT_STRICT_REFS is in force or not.
1458 if (!strchr(s,':') && !strchr(s,'\''))
1459 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1461 (void)rsignal(i, PL_csighandlerp);
1463 *svp = SvREFCNT_inc(sv);
1465 #ifdef HAS_SIGPROCMASK
1470 SvREFCNT_dec(to_dec);
1473 #endif /* !PERL_MICRO */
1476 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1479 PERL_UNUSED_ARG(sv);
1480 PERL_UNUSED_ARG(mg);
1481 PL_sub_generation++;
1486 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1489 PERL_UNUSED_ARG(sv);
1490 PERL_UNUSED_ARG(mg);
1491 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1492 PL_amagic_generation++;
1498 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1500 HV * const hv = (HV*)LvTARG(sv);
1502 PERL_UNUSED_ARG(mg);
1505 (void) hv_iterinit(hv);
1506 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1509 while (hv_iternext(hv))
1514 sv_setiv(sv, (IV)i);
1519 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1521 PERL_UNUSED_ARG(mg);
1523 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1528 /* caller is responsible for stack switching/cleanup */
1530 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1537 PUSHs(SvTIED_obj(sv, mg));
1540 if (mg->mg_len >= 0)
1541 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1542 else if (mg->mg_len == HEf_SVKEY)
1543 PUSHs((SV*)mg->mg_ptr);
1545 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1546 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1554 return call_method(meth, flags);
1558 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1564 PUSHSTACKi(PERLSI_MAGIC);
1566 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1567 sv_setsv(sv, *PL_stack_sp--);
1577 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1580 mg->mg_flags |= MGf_GSKIP;
1581 magic_methpack(sv,mg,"FETCH");
1586 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1590 PUSHSTACKi(PERLSI_MAGIC);
1591 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1598 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1600 return magic_methpack(sv,mg,"DELETE");
1605 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1612 PUSHSTACKi(PERLSI_MAGIC);
1613 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1614 sv = *PL_stack_sp--;
1615 retval = (U32) SvIV(sv)-1;
1624 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1629 PUSHSTACKi(PERLSI_MAGIC);
1631 XPUSHs(SvTIED_obj(sv, mg));
1633 call_method("CLEAR", G_SCALAR|G_DISCARD);
1641 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1644 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1648 PUSHSTACKi(PERLSI_MAGIC);
1651 PUSHs(SvTIED_obj(sv, mg));
1656 if (call_method(meth, G_SCALAR))
1657 sv_setsv(key, *PL_stack_sp--);
1666 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1668 return magic_methpack(sv,mg,"EXISTS");
1672 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1675 SV *retval = &PL_sv_undef;
1676 SV * const tied = SvTIED_obj((SV*)hv, mg);
1677 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1679 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1681 if (HvEITER_get(hv))
1682 /* we are in an iteration so the hash cannot be empty */
1684 /* no xhv_eiter so now use FIRSTKEY */
1685 key = sv_newmortal();
1686 magic_nextpack((SV*)hv, mg, key);
1687 HvEITER_set(hv, NULL); /* need to reset iterator */
1688 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1691 /* there is a SCALAR method that we can call */
1693 PUSHSTACKi(PERLSI_MAGIC);
1699 if (call_method("SCALAR", G_SCALAR))
1700 retval = *PL_stack_sp--;
1707 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1710 GV * const gv = PL_DBline;
1711 const I32 i = SvTRUE(sv);
1712 SV ** const svp = av_fetch(GvAV(gv),
1713 atoi(MgPV_nolen_const(mg)), FALSE);
1714 if (svp && SvIOKp(*svp)) {
1715 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1717 /* set or clear breakpoint in the relevant control op */
1719 o->op_flags |= OPf_SPECIAL;
1721 o->op_flags &= ~OPf_SPECIAL;
1728 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1731 const AV * const obj = (AV*)mg->mg_obj;
1733 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1741 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1744 AV * const obj = (AV*)mg->mg_obj;
1746 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1748 if (ckWARN(WARN_MISC))
1749 Perl_warner(aTHX_ packWARN(WARN_MISC),
1750 "Attempt to set length of freed array");
1756 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1759 PERL_UNUSED_ARG(sv);
1760 /* during global destruction, mg_obj may already have been freed */
1761 if (PL_in_clean_all)
1764 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1767 /* arylen scalar holds a pointer back to the array, but doesn't own a
1768 reference. Hence the we (the array) are about to go away with it
1769 still pointing at us. Clear its pointer, else it would be pointing
1770 at free memory. See the comment in sv_magic about reference loops,
1771 and why it can't own a reference to us. */
1778 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1781 SV* const lsv = LvTARG(sv);
1783 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1784 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1785 if (mg && mg->mg_len >= 0) {
1788 sv_pos_b2u(lsv, &i);
1789 sv_setiv(sv, i + PL_curcop->cop_arybase);
1798 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1801 SV* const lsv = LvTARG(sv);
1808 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1809 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1813 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1814 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1816 else if (!SvOK(sv)) {
1820 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1822 pos = SvIV(sv) - PL_curcop->cop_arybase;
1825 ulen = sv_len_utf8(lsv);
1835 else if (pos > (SSize_t)len)
1840 sv_pos_u2b(lsv, &p, 0);
1845 mg->mg_flags &= ~MGf_MINMATCH;
1851 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1853 PERL_UNUSED_ARG(mg);
1854 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1856 gv_efullname3(sv,((GV*)sv), "*");
1860 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1865 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1868 PERL_UNUSED_ARG(mg);
1872 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1877 GvGP(sv) = gp_ref(GvGP(gv));
1882 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1885 SV * const lsv = LvTARG(sv);
1886 const char * const tmps = SvPV_const(lsv,len);
1887 I32 offs = LvTARGOFF(sv);
1888 I32 rem = LvTARGLEN(sv);
1889 PERL_UNUSED_ARG(mg);
1892 sv_pos_u2b(lsv, &offs, &rem);
1893 if (offs > (I32)len)
1895 if (rem + offs > (I32)len)
1897 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1904 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1908 const char *tmps = SvPV_const(sv, len);
1909 SV * const lsv = LvTARG(sv);
1910 I32 lvoff = LvTARGOFF(sv);
1911 I32 lvlen = LvTARGLEN(sv);
1912 PERL_UNUSED_ARG(mg);
1915 sv_utf8_upgrade(lsv);
1916 sv_pos_u2b(lsv, &lvoff, &lvlen);
1917 sv_insert(lsv, lvoff, lvlen, tmps, len);
1918 LvTARGLEN(sv) = sv_len_utf8(sv);
1921 else if (lsv && SvUTF8(lsv)) {
1922 sv_pos_u2b(lsv, &lvoff, &lvlen);
1923 LvTARGLEN(sv) = len;
1924 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1925 sv_insert(lsv, lvoff, lvlen, tmps, len);
1929 sv_insert(lsv, lvoff, lvlen, tmps, len);
1930 LvTARGLEN(sv) = len;
1938 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1941 PERL_UNUSED_ARG(sv);
1942 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1947 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1950 PERL_UNUSED_ARG(sv);
1951 /* update taint status unless we're restoring at scope exit */
1952 if (PL_localizing != 2) {
1962 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1964 SV * const lsv = LvTARG(sv);
1965 PERL_UNUSED_ARG(mg);
1972 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 /* PL_origalen is set in perl_parse(). */
2572 s = SvPV_force(sv,len);
2573 if (len >= (STRLEN)PL_origalen-1) {
2574 /* Longer than original, will be truncated. We assume that
2575 * PL_origalen bytes are available. */
2576 Copy(s, PL_origargv[0], PL_origalen-1, char);
2579 /* Shorter than original, will be padded. */
2580 Copy(s, PL_origargv[0], len, char);
2581 PL_origargv[0][len] = 0;
2582 memset(PL_origargv[0] + len + 1,
2583 /* Is the space counterintuitive? Yes.
2584 * (You were expecting \0?)
2585 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2588 PL_origalen - len - 1);
2590 PL_origargv[0][PL_origalen-1] = 0;
2591 for (i = 1; i < PL_origargc; i++)
2593 UNLOCK_DOLLARZERO_MUTEX;
2601 Perl_whichsig(pTHX_ const char *sig)
2603 register char* const* sigv;
2605 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2606 if (strEQ(sig,*sigv))
2607 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2609 if (strEQ(sig,"CHLD"))
2613 if (strEQ(sig,"CLD"))
2620 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2621 Perl_sighandler(int sig, ...)
2623 Perl_sighandler(int sig)
2626 #ifdef PERL_GET_SIG_CONTEXT
2627 dTHXa(PERL_GET_SIG_CONTEXT);
2634 SV * const tSv = PL_Sv;
2638 XPV * const tXpv = PL_Xpv;
2640 if (PL_savestack_ix + 15 <= PL_savestack_max)
2642 if (PL_markstack_ptr < PL_markstack_max - 2)
2644 if (PL_scopestack_ix < PL_scopestack_max - 3)
2647 if (!PL_psig_ptr[sig]) {
2648 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2653 /* Max number of items pushed there is 3*n or 4. We cannot fix
2654 infinity, so we fix 4 (in fact 5): */
2656 PL_savestack_ix += 5; /* Protect save in progress. */
2657 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2660 PL_markstack_ptr++; /* Protect mark. */
2662 PL_scopestack_ix += 1;
2663 /* sv_2cv is too complicated, try a simpler variant first: */
2664 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2665 || SvTYPE(cv) != SVt_PVCV) {
2667 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2670 if (!cv || !CvROOT(cv)) {
2671 if (ckWARN(WARN_SIGNAL))
2672 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2673 PL_sig_name[sig], (gv ? GvENAME(gv)
2680 if(PL_psig_name[sig]) {
2681 sv = SvREFCNT_inc(PL_psig_name[sig]);
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2687 sv = sv_newmortal();
2688 sv_setpv(sv,PL_sig_name[sig]);
2691 PUSHSTACKi(PERLSI_SIGNAL);
2694 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2696 struct sigaction oact;
2698 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2702 va_start(args, sig);
2703 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2706 SV *rv = newRV_noinc((SV*)sih);
2707 /* The siginfo fields signo, code, errno, pid, uid,
2708 * addr, status, and band are defined by POSIX/SUSv3. */
2709 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2710 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2711 #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. */
2712 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2713 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2714 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2715 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2716 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2717 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2721 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2730 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2733 if (SvTRUE(ERRSV)) {
2735 #ifdef HAS_SIGPROCMASK
2736 /* Handler "died", for example to get out of a restart-able read().
2737 * Before we re-do that on its behalf re-enable the signal which was
2738 * blocked by the system when we entered.
2742 sigaddset(&set,sig);
2743 sigprocmask(SIG_UNBLOCK, &set, NULL);
2745 /* Not clear if this will work */
2746 (void)rsignal(sig, SIG_IGN);
2747 (void)rsignal(sig, PL_csighandlerp);
2749 #endif /* !PERL_MICRO */
2750 Perl_die(aTHX_ Nullch);
2754 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2758 PL_scopestack_ix -= 1;
2761 PL_op = myop; /* Apparently not needed... */
2763 PL_Sv = tSv; /* Restore global temporaries. */
2770 S_restore_magic(pTHX_ const void *p)
2773 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2774 SV* const sv = mgs->mgs_sv;
2779 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2781 #ifdef PERL_OLD_COPY_ON_WRITE
2782 /* While magic was saved (and off) sv_setsv may well have seen
2783 this SV as a prime candidate for COW. */
2785 sv_force_normal_flags(sv, 0);
2789 SvFLAGS(sv) |= mgs->mgs_flags;
2792 if (SvGMAGICAL(sv)) {
2793 /* downgrade public flags to private,
2794 and discard any other private flags */
2796 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2798 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2799 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2804 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2806 /* If we're still on top of the stack, pop us off. (That condition
2807 * will be satisfied if restore_magic was called explicitly, but *not*
2808 * if it's being called via leave_scope.)
2809 * The reason for doing this is that otherwise, things like sv_2cv()
2810 * may leave alloc gunk on the savestack, and some code
2811 * (e.g. sighandler) doesn't expect that...
2813 if (PL_savestack_ix == mgs->mgs_ss_ix)
2815 I32 popval = SSPOPINT;
2816 assert(popval == SAVEt_DESTRUCTOR_X);
2817 PL_savestack_ix -= 2;
2819 assert(popval == SAVEt_ALLOC);
2821 PL_savestack_ix -= popval;
2827 S_unwind_handler_stack(pTHX_ const void *p)
2830 const U32 flags = *(const U32*)p;
2833 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2834 #if !defined(PERL_IMPLICIT_CONTEXT)
2836 SvREFCNT_dec(PL_sig_sv);
2842 * c-indentation-style: bsd
2844 * indent-tabs-mode: t
2847 * ex: set ts=8 sts=4 sw=4 noet: