3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
120 const MGVTBL* const vtbl = mg->mg_virtual;
122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
135 Do magic after a value is retrieved from the SV. See C<sv_magic>.
141 Perl_mg_get(pTHX_ SV *sv)
144 const I32 mgs_ix = SSNEW(sizeof(MGS));
145 const bool was_temp = (bool)SvTEMP(sv);
147 MAGIC *newmg, *head, *cur, *mg;
148 /* guard against sv having being freed midway by holding a private
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
155 sv_2mortal(SvREFCNT_inc_simple(sv));
160 save_magic(mgs_ix, sv);
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
166 newmg = cur = head = mg = SvMAGIC(sv);
168 const MGVTBL * const vtbl = mg->mg_virtual;
170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
173 /* guard against magic having been deleted - eg FETCH calling
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
183 mg = mg->mg_moremagic;
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
195 /* Were any new entries added? */
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
216 Do magic after a value is assigned to the SV. See C<sv_magic>.
222 Perl_mg_set(pTHX_ SV *sv)
225 const I32 mgs_ix = SSNEW(sizeof(MGS));
229 save_magic(mgs_ix, sv);
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
232 const MGVTBL* vtbl = mg->mg_virtual;
233 nextmg = mg->mg_moremagic; /* it may delete itself */
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
238 if (vtbl && vtbl->svt_set)
239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
247 =for apidoc mg_length
249 Report on the SV's length. See C<sv_magic>.
255 Perl_mg_length(pTHX_ SV *sv)
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 const MGVTBL * const vtbl = mg->mg_virtual;
263 if (vtbl && vtbl->svt_len) {
264 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
266 /* omit MGf_GSKIP -- not changed here */
267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
274 const U8 *s = (U8*)SvPV_const(sv, len);
275 len = Perl_utf8_length(aTHX_ s, s + len);
278 (void)SvPV_const(sv, len);
283 Perl_mg_size(pTHX_ SV *sv)
287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
288 const MGVTBL* const vtbl = mg->mg_virtual;
289 if (vtbl && vtbl->svt_len) {
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 save_magic(mgs_ix, sv);
293 /* omit MGf_GSKIP -- not changed here */
294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
306 Perl_croak(aTHX_ "Size magic not implemented");
315 Clear something magical that the SV represents. See C<sv_magic>.
321 Perl_mg_clear(pTHX_ SV *sv)
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
326 save_magic(mgs_ix, sv);
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 /* omit GSKIP -- never set here */
332 if (vtbl && vtbl->svt_clear)
333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 Finds the magic pointer for type matching the SV. See C<sv_magic>.
349 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
381 const char type = mg->mg_type;
384 (type == PERL_MAGIC_tied)
386 : (type == PERL_MAGIC_regdata && mg->mg_obj)
389 toLOWER(type), key, klen);
398 =for apidoc mg_localize
400 Copy some of the magic from an existing SV to new localized version of
401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
402 doesn't (eg taint, pos).
408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 MGVTBL* const vtbl = mg->mg_virtual;
414 switch (mg->mg_type) {
415 /* value magic types: don't copy */
418 case PERL_MAGIC_regex_global:
419 case PERL_MAGIC_nkeys:
420 #ifdef USE_LOCALE_COLLATE
421 case PERL_MAGIC_collxfrm:
424 case PERL_MAGIC_taint:
426 case PERL_MAGIC_vstring:
427 case PERL_MAGIC_utf8:
428 case PERL_MAGIC_substr:
429 case PERL_MAGIC_defelem:
430 case PERL_MAGIC_arylen:
432 case PERL_MAGIC_backref:
433 case PERL_MAGIC_arylen_p:
434 case PERL_MAGIC_rhash:
435 case PERL_MAGIC_symtab:
439 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
440 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
442 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
443 mg->mg_ptr, mg->mg_len);
445 /* container types should remain read-only across localization */
446 SvFLAGS(nsv) |= SvREADONLY(sv);
449 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
450 SvFLAGS(nsv) |= SvMAGICAL(sv);
460 Free any magic storage used by the SV. See C<sv_magic>.
466 Perl_mg_free(pTHX_ SV *sv)
470 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 moremagic = mg->mg_moremagic;
473 if (vtbl && vtbl->svt_free)
474 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
475 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
476 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
477 Safefree(mg->mg_ptr);
478 else if (mg->mg_len == HEf_SVKEY)
479 SvREFCNT_dec((SV*)mg->mg_ptr);
481 if (mg->mg_flags & MGf_REFCOUNTED)
482 SvREFCNT_dec(mg->mg_obj);
485 SvMAGIC_set(sv, NULL);
492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
498 register const REGEXP * const rx = PM_GETRE(PL_curpm);
501 ? rx->nparens /* @+ */
502 : rx->lastparen; /* @- */
510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 register const I32 paren = mg->mg_len;
521 if (paren <= (I32)rx->nparens &&
522 (s = rx->startp[paren]) != -1 &&
523 (t = rx->endp[paren]) != -1)
526 if (mg->mg_obj) /* @+ */
531 if (i > 0 && RX_MATCH_UTF8(rx)) {
532 const char * const b = rx->subbeg;
534 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
547 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
548 Perl_croak(aTHX_ PL_no_modify);
549 NORETURN_FUNCTION_END;
553 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
558 register const REGEXP *rx;
561 switch (*mg->mg_ptr) {
562 case '1': case '2': case '3': case '4':
563 case '5': case '6': case '7': case '8': case '9': case '&':
564 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
566 paren = atoi(mg->mg_ptr); /* $& is in [0] */
568 if (paren <= (I32)rx->nparens &&
569 (s1 = rx->startp[paren]) != -1 &&
570 (t1 = rx->endp[paren]) != -1)
574 if (i > 0 && RX_MATCH_UTF8(rx)) {
575 const char * const s = rx->subbeg + s1;
580 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
584 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
588 if (ckWARN(WARN_UNINITIALIZED))
593 if (ckWARN(WARN_UNINITIALIZED))
598 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
599 paren = rx->lastparen;
604 case '\016': /* ^N */
605 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
606 paren = rx->lastcloseparen;
612 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
613 if (rx->startp[0] != -1) {
624 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
625 if (rx->endp[0] != -1) {
626 i = rx->sublen - rx->endp[0];
637 if (!SvPOK(sv) && SvNIOK(sv)) {
645 #define SvRTRIM(sv) STMT_START { \
647 STRLEN len = SvCUR(sv); \
648 char * const p = SvPVX(sv); \
649 while (len > 0 && isSPACE(p[len-1])) \
651 SvCUR_set(sv, len); \
657 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
661 register char *s = NULL;
664 const char * const remaining = mg->mg_ptr + 1;
665 const char nextchar = *remaining;
667 switch (*mg->mg_ptr) {
668 case '\001': /* ^A */
669 sv_setsv(sv, PL_bodytarget);
671 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
672 if (nextchar == '\0') {
673 sv_setiv(sv, (IV)PL_minus_c);
675 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
676 sv_setiv(sv, (IV)STATUS_NATIVE);
680 case '\004': /* ^D */
681 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
683 case '\005': /* ^E */
684 if (nextchar == '\0') {
685 #if defined(MACOS_TRADITIONAL)
689 sv_setnv(sv,(double)gMacPerl_OSErr);
690 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
694 # include <descrip.h>
695 # include <starlet.h>
697 $DESCRIPTOR(msgdsc,msg);
698 sv_setnv(sv,(NV) vaxc$errno);
699 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
700 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
705 if (!(_emx_env & 0x200)) { /* Under DOS */
706 sv_setnv(sv, (NV)errno);
707 sv_setpv(sv, errno ? Strerror(errno) : "");
709 if (errno != errno_isOS2) {
710 const int tmp = _syserrno();
711 if (tmp) /* 2nd call to _syserrno() makes it 0 */
714 sv_setnv(sv, (NV)Perl_rc);
715 sv_setpv(sv, os2error(Perl_rc));
719 DWORD dwErr = GetLastError();
720 sv_setnv(sv, (NV)dwErr);
722 PerlProc_GetOSError(sv, dwErr);
725 sv_setpvn(sv, "", 0);
730 const int saveerrno = errno;
731 sv_setnv(sv, (NV)errno);
732 sv_setpv(sv, errno ? Strerror(errno) : "");
737 SvNOK_on(sv); /* what a wonderful hack! */
739 else if (strEQ(remaining, "NCODING"))
740 sv_setsv(sv, PL_encoding);
742 case '\006': /* ^F */
743 sv_setiv(sv, (IV)PL_maxsysfd);
745 case '\010': /* ^H */
746 sv_setiv(sv, (IV)PL_hints);
748 case '\011': /* ^I */ /* NOT \t in EBCDIC */
750 sv_setpv(sv, PL_inplace);
752 sv_setsv(sv, &PL_sv_undef);
754 case '\017': /* ^O & ^OPEN */
755 if (nextchar == '\0') {
756 sv_setpv(sv, PL_osname);
759 else if (strEQ(remaining, "PEN")) {
760 if (!PL_compiling.cop_io)
761 sv_setsv(sv, &PL_sv_undef);
763 sv_setsv(sv, PL_compiling.cop_io);
767 case '\020': /* ^P */
768 sv_setiv(sv, (IV)PL_perldb);
770 case '\023': /* ^S */
771 if (nextchar == '\0') {
772 if (PL_lex_state != LEX_NOTPARSING)
775 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
780 case '\024': /* ^T */
781 if (nextchar == '\0') {
783 sv_setnv(sv, PL_basetime);
785 sv_setiv(sv, (IV)PL_basetime);
788 else if (strEQ(remaining, "AINT"))
789 sv_setiv(sv, PL_tainting
790 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
793 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
794 if (strEQ(remaining, "NICODE"))
795 sv_setuv(sv, (UV) PL_unicode);
796 else if (strEQ(remaining, "TF8LOCALE"))
797 sv_setuv(sv, (UV) PL_utf8locale);
798 else if (strEQ(remaining, "TF8CACHE"))
799 sv_setiv(sv, (IV) PL_utf8cache);
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_fetchs(bits, "all", 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)
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);
1007 sv_setiv(sv, (IV)PL_egid);
1009 #ifdef HAS_GETGROUPS
1011 Groups_t *gary = NULL;
1012 I32 i, num_groups = getgroups(0, gary);
1013 Newx(gary, num_groups, Groups_t);
1014 num_groups = getgroups(num_groups, gary);
1015 for (i = 0; i < num_groups; i++)
1016 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1019 (void)SvIOK_on(sv); /* what a wonderful hack! */
1022 #ifndef MACOS_TRADITIONAL
1031 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1033 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1035 if (uf && uf->uf_val)
1036 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1041 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1045 const char *s = SvPV_const(sv,len);
1046 const char * const ptr = MgPV_const(mg,klen);
1049 #ifdef DYNAMIC_ENV_FETCH
1050 /* We just undefd an environment var. Is a replacement */
1051 /* waiting in the wings? */
1053 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1055 s = SvPV_const(*valp, len);
1059 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1060 /* And you'll never guess what the dog had */
1061 /* in its mouth... */
1063 MgTAINTEDDIR_off(mg);
1065 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1066 char pathbuf[256], eltbuf[256], *cp, *elt;
1070 strncpy(eltbuf, s, 255);
1073 do { /* DCL$PATH may be a search list */
1074 while (1) { /* as may dev portion of any element */
1075 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1076 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1077 cando_by_name(S_IWUSR,0,elt) ) {
1078 MgTAINTEDDIR_on(mg);
1082 if ((cp = strchr(elt, ':')) != NULL)
1084 if (my_trnlnm(elt, eltbuf, j++))
1090 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1093 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1094 const char * const strend = s + len;
1096 while (s < strend) {
1100 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1101 s, strend, ':', &i);
1103 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1105 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1106 MgTAINTEDDIR_on(mg);
1112 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1118 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1120 PERL_UNUSED_ARG(sv);
1121 my_setenv(MgPV_nolen_const(mg),NULL);
1126 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1129 PERL_UNUSED_ARG(mg);
1131 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1133 if (PL_localizing) {
1136 hv_iterinit((HV*)sv);
1137 while ((entry = hv_iternext((HV*)sv))) {
1139 my_setenv(hv_iterkey(entry, &keylen),
1140 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1148 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1151 PERL_UNUSED_ARG(sv);
1152 PERL_UNUSED_ARG(mg);
1154 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1162 #ifdef HAS_SIGPROCMASK
1164 restore_sigmask(pTHX_ SV *save_sv)
1166 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1167 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1171 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1174 /* Are we fetching a signal entry? */
1175 const I32 i = whichsig(MgPV_nolen_const(mg));
1178 sv_setsv(sv,PL_psig_ptr[i]);
1180 Sighandler_t sigstate;
1181 sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1188 /* cache state so we don't fetch it again */
1189 if(sigstate == (Sighandler_t) SIG_IGN)
1190 sv_setpv(sv,"IGNORE");
1192 sv_setsv(sv,&PL_sv_undef);
1193 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1202 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203 * refactoring might be in order.
1206 register const char * const s = MgPV_nolen_const(mg);
1207 PERL_UNUSED_ARG(sv);
1210 if (strEQ(s,"__DIE__"))
1212 else if (strEQ(s,"__WARN__"))
1215 Perl_croak(aTHX_ "No such hook: %s", s);
1217 SV * const to_dec = *svp;
1219 SvREFCNT_dec(to_dec);
1223 /* Are we clearing a signal entry? */
1224 const I32 i = whichsig(s);
1226 #ifdef HAS_SIGPROCMASK
1229 /* Avoid having the signal arrive at a bad time, if possible. */
1232 sigprocmask(SIG_BLOCK, &set, &save);
1234 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235 SAVEFREESV(save_sv);
1236 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243 PL_sig_defaulting[i] = 1;
1244 (void)rsignal(i, PL_csighandlerp);
1246 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1248 if(PL_psig_name[i]) {
1249 SvREFCNT_dec(PL_psig_name[i]);
1252 if(PL_psig_ptr[i]) {
1253 SV * const to_dec=PL_psig_ptr[i];
1256 SvREFCNT_dec(to_dec);
1266 S_raise_signal(pTHX_ int sig)
1269 /* Set a flag to say this signal is pending */
1270 PL_psig_pend[sig]++;
1271 /* And one to say _a_ signal is pending */
1276 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1277 Perl_csighandler(int sig, ...)
1279 Perl_csighandler(int sig)
1282 #ifdef PERL_GET_SIG_CONTEXT
1283 dTHXa(PERL_GET_SIG_CONTEXT);
1287 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1288 (void) rsignal(sig, PL_csighandlerp);
1289 if (PL_sig_ignoring[sig]) return;
1291 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1292 if (PL_sig_defaulting[sig])
1293 #ifdef KILL_BY_SIGPRC
1294 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1299 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1300 /* Call the perl level handler now--
1301 * with risk we may be in malloc() etc. */
1302 (*PL_sighandlerp)(sig);
1304 S_raise_signal(aTHX_ sig);
1307 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1309 Perl_csighandler_init(void)
1312 if (PL_sig_handlers_initted) return;
1314 for (sig = 1; sig < SIG_SIZE; sig++) {
1315 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1317 PL_sig_defaulting[sig] = 1;
1318 (void) rsignal(sig, PL_csighandlerp);
1320 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1321 PL_sig_ignoring[sig] = 0;
1324 PL_sig_handlers_initted = 1;
1329 Perl_despatch_signals(pTHX)
1334 for (sig = 1; sig < SIG_SIZE; sig++) {
1335 if (PL_psig_pend[sig]) {
1336 PERL_BLOCKSIG_ADD(set, sig);
1337 PL_psig_pend[sig] = 0;
1338 PERL_BLOCKSIG_BLOCK(set);
1339 (*PL_sighandlerp)(sig);
1340 PERL_BLOCKSIG_UNBLOCK(set);
1346 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1351 /* Need to be careful with SvREFCNT_dec(), because that can have side
1352 * effects (due to closures). We must make sure that the new disposition
1353 * is in place before it is called.
1357 #ifdef HAS_SIGPROCMASK
1362 register const char *s = MgPV_const(mg,len);
1364 if (strEQ(s,"__DIE__"))
1366 else if (strEQ(s,"__WARN__"))
1369 Perl_croak(aTHX_ "No such hook: %s", s);
1377 i = whichsig(s); /* ...no, a brick */
1379 if (ckWARN(WARN_SIGNAL))
1380 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1383 #ifdef HAS_SIGPROCMASK
1384 /* Avoid having the signal arrive at a bad time, if possible. */
1387 sigprocmask(SIG_BLOCK, &set, &save);
1389 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1390 SAVEFREESV(save_sv);
1391 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1394 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1395 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1397 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1398 PL_sig_ignoring[i] = 0;
1400 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1401 PL_sig_defaulting[i] = 0;
1403 SvREFCNT_dec(PL_psig_name[i]);
1404 to_dec = PL_psig_ptr[i];
1405 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1406 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1407 PL_psig_name[i] = newSVpvn(s, len);
1408 SvREADONLY_on(PL_psig_name[i]);
1410 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1412 (void)rsignal(i, PL_csighandlerp);
1413 #ifdef HAS_SIGPROCMASK
1418 *svp = SvREFCNT_inc_simple_NN(sv);
1420 SvREFCNT_dec(to_dec);
1423 s = SvPV_force(sv,len);
1424 if (strEQ(s,"IGNORE")) {
1426 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1427 PL_sig_ignoring[i] = 1;
1428 (void)rsignal(i, PL_csighandlerp);
1430 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1434 else if (strEQ(s,"DEFAULT") || !*s) {
1436 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1438 PL_sig_defaulting[i] = 1;
1439 (void)rsignal(i, PL_csighandlerp);
1442 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1447 * We should warn if HINT_STRICT_REFS, but without
1448 * access to a known hint bit in a known OP, we can't
1449 * tell whether HINT_STRICT_REFS is in force or not.
1451 if (!strchr(s,':') && !strchr(s,'\''))
1452 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1454 (void)rsignal(i, PL_csighandlerp);
1456 *svp = SvREFCNT_inc_simple(sv);
1458 #ifdef HAS_SIGPROCMASK
1463 SvREFCNT_dec(to_dec);
1466 #endif /* !PERL_MICRO */
1469 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1472 PERL_UNUSED_ARG(sv);
1473 PERL_UNUSED_ARG(mg);
1474 PL_sub_generation++;
1479 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1482 PERL_UNUSED_ARG(sv);
1483 PERL_UNUSED_ARG(mg);
1484 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1485 PL_amagic_generation++;
1491 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1493 HV * const hv = (HV*)LvTARG(sv);
1495 PERL_UNUSED_ARG(mg);
1498 (void) hv_iterinit(hv);
1499 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1502 while (hv_iternext(hv))
1507 sv_setiv(sv, (IV)i);
1512 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1514 PERL_UNUSED_ARG(mg);
1516 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1521 /* caller is responsible for stack switching/cleanup */
1523 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1530 PUSHs(SvTIED_obj(sv, mg));
1533 if (mg->mg_len >= 0)
1534 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1535 else if (mg->mg_len == HEf_SVKEY)
1536 PUSHs((SV*)mg->mg_ptr);
1538 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1539 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1547 return call_method(meth, flags);
1551 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1557 PUSHSTACKi(PERLSI_MAGIC);
1559 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1560 sv_setsv(sv, *PL_stack_sp--);
1570 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1573 mg->mg_flags |= MGf_GSKIP;
1574 magic_methpack(sv,mg,"FETCH");
1579 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1583 PUSHSTACKi(PERLSI_MAGIC);
1584 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1591 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1593 return magic_methpack(sv,mg,"DELETE");
1598 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1605 PUSHSTACKi(PERLSI_MAGIC);
1606 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1607 sv = *PL_stack_sp--;
1608 retval = (U32) SvIV(sv)-1;
1617 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1622 PUSHSTACKi(PERLSI_MAGIC);
1624 XPUSHs(SvTIED_obj(sv, mg));
1626 call_method("CLEAR", G_SCALAR|G_DISCARD);
1634 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1637 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1641 PUSHSTACKi(PERLSI_MAGIC);
1644 PUSHs(SvTIED_obj(sv, mg));
1649 if (call_method(meth, G_SCALAR))
1650 sv_setsv(key, *PL_stack_sp--);
1659 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1661 return magic_methpack(sv,mg,"EXISTS");
1665 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1668 SV *retval = &PL_sv_undef;
1669 SV * const tied = SvTIED_obj((SV*)hv, mg);
1670 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1672 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1674 if (HvEITER_get(hv))
1675 /* we are in an iteration so the hash cannot be empty */
1677 /* no xhv_eiter so now use FIRSTKEY */
1678 key = sv_newmortal();
1679 magic_nextpack((SV*)hv, mg, key);
1680 HvEITER_set(hv, NULL); /* need to reset iterator */
1681 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1684 /* there is a SCALAR method that we can call */
1686 PUSHSTACKi(PERLSI_MAGIC);
1692 if (call_method("SCALAR", G_SCALAR))
1693 retval = *PL_stack_sp--;
1700 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1703 GV * const gv = PL_DBline;
1704 const I32 i = SvTRUE(sv);
1705 SV ** const svp = av_fetch(GvAV(gv),
1706 atoi(MgPV_nolen_const(mg)), FALSE);
1707 if (svp && SvIOKp(*svp)) {
1708 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1710 /* set or clear breakpoint in the relevant control op */
1712 o->op_flags |= OPf_SPECIAL;
1714 o->op_flags &= ~OPf_SPECIAL;
1721 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1724 const AV * const obj = (AV*)mg->mg_obj;
1726 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1734 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1737 AV * const obj = (AV*)mg->mg_obj;
1739 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1741 if (ckWARN(WARN_MISC))
1742 Perl_warner(aTHX_ packWARN(WARN_MISC),
1743 "Attempt to set length of freed array");
1749 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1752 PERL_UNUSED_ARG(sv);
1753 /* during global destruction, mg_obj may already have been freed */
1754 if (PL_in_clean_all)
1757 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1760 /* arylen scalar holds a pointer back to the array, but doesn't own a
1761 reference. Hence the we (the array) are about to go away with it
1762 still pointing at us. Clear its pointer, else it would be pointing
1763 at free memory. See the comment in sv_magic about reference loops,
1764 and why it can't own a reference to us. */
1771 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1774 SV* const lsv = LvTARG(sv);
1776 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1777 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1778 if (mg && mg->mg_len >= 0) {
1781 sv_pos_b2u(lsv, &i);
1782 sv_setiv(sv, i + PL_curcop->cop_arybase);
1791 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1794 SV* const lsv = LvTARG(sv);
1801 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1802 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1806 #ifdef PERL_OLD_COPY_ON_WRITE
1808 sv_force_normal_flags(lsv, 0);
1810 mg = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1813 else if (!SvOK(sv)) {
1817 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1819 pos = SvIV(sv) - PL_curcop->cop_arybase;
1822 ulen = sv_len_utf8(lsv);
1832 else if (pos > (SSize_t)len)
1837 sv_pos_u2b(lsv, &p, 0);
1842 mg->mg_flags &= ~MGf_MINMATCH;
1848 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_UNUSED_ARG(mg);
1855 if (SvFLAGS(sv) & SVp_SCREAM
1856 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1857 /* We're actually already a typeglob, so don't need the stuff below.
1861 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1866 GvGP(sv) = gp_ref(GvGP(gv));
1871 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1874 SV * const lsv = LvTARG(sv);
1875 const char * const tmps = SvPV_const(lsv,len);
1876 I32 offs = LvTARGOFF(sv);
1877 I32 rem = LvTARGLEN(sv);
1878 PERL_UNUSED_ARG(mg);
1881 sv_pos_u2b(lsv, &offs, &rem);
1882 if (offs > (I32)len)
1884 if (rem + offs > (I32)len)
1886 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1893 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1897 const char *tmps = SvPV_const(sv, len);
1898 SV * const lsv = LvTARG(sv);
1899 I32 lvoff = LvTARGOFF(sv);
1900 I32 lvlen = LvTARGLEN(sv);
1901 PERL_UNUSED_ARG(mg);
1904 sv_utf8_upgrade(lsv);
1905 sv_pos_u2b(lsv, &lvoff, &lvlen);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1907 LvTARGLEN(sv) = sv_len_utf8(sv);
1910 else if (lsv && SvUTF8(lsv)) {
1911 sv_pos_u2b(lsv, &lvoff, &lvlen);
1912 LvTARGLEN(sv) = len;
1913 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1914 sv_insert(lsv, lvoff, lvlen, tmps, len);
1918 sv_insert(lsv, lvoff, lvlen, tmps, len);
1919 LvTARGLEN(sv) = len;
1927 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1930 PERL_UNUSED_ARG(sv);
1931 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1936 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1939 PERL_UNUSED_ARG(sv);
1940 /* update taint status unless we're restoring at scope exit */
1941 if (PL_localizing != 2) {
1951 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1953 SV * const lsv = LvTARG(sv);
1954 PERL_UNUSED_ARG(mg);
1957 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1965 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1967 PERL_UNUSED_ARG(mg);
1968 do_vecset(sv); /* XXX slurp this routine */
1973 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1977 if (LvTARGLEN(sv)) {
1979 SV * const ahv = LvTARG(sv);
1980 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1985 AV* const av = (AV*)LvTARG(sv);
1986 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1987 targ = AvARRAY(av)[LvTARGOFF(sv)];
1989 if (targ && targ != &PL_sv_undef) {
1990 /* somebody else defined it for us */
1991 SvREFCNT_dec(LvTARG(sv));
1992 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
1994 SvREFCNT_dec(mg->mg_obj);
1996 mg->mg_flags &= ~MGf_REFCOUNTED;
2001 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2006 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2008 PERL_UNUSED_ARG(mg);
2012 sv_setsv(LvTARG(sv), sv);
2013 SvSETMAGIC(LvTARG(sv));
2019 Perl_vivify_defelem(pTHX_ SV *sv)
2025 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2028 SV * const ahv = LvTARG(sv);
2029 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2032 if (!value || value == &PL_sv_undef)
2033 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2036 AV* const av = (AV*)LvTARG(sv);
2037 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2038 LvTARG(sv) = NULL; /* array can't be extended */
2040 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2041 if (!svp || (value = *svp) == &PL_sv_undef)
2042 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2045 SvREFCNT_inc_simple_void(value);
2046 SvREFCNT_dec(LvTARG(sv));
2049 SvREFCNT_dec(mg->mg_obj);
2051 mg->mg_flags &= ~MGf_REFCOUNTED;
2055 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2057 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2061 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2063 PERL_UNUSED_CONTEXT;
2070 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2072 PERL_UNUSED_ARG(mg);
2073 sv_unmagic(sv, PERL_MAGIC_bm);
2079 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2081 PERL_UNUSED_ARG(mg);
2082 sv_unmagic(sv, PERL_MAGIC_fm);
2088 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2090 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2092 if (uf && uf->uf_set)
2093 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2098 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_UNUSED_ARG(mg);
2101 sv_unmagic(sv, PERL_MAGIC_qr);
2106 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2109 regexp * const re = (regexp *)mg->mg_obj;
2110 PERL_UNUSED_ARG(sv);
2116 #ifdef USE_LOCALE_COLLATE
2118 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2121 * RenE<eacute> Descartes said "I think not."
2122 * and vanished with a faint plop.
2124 PERL_UNUSED_CONTEXT;
2125 PERL_UNUSED_ARG(sv);
2127 Safefree(mg->mg_ptr);
2133 #endif /* USE_LOCALE_COLLATE */
2135 /* Just clear the UTF-8 cache data. */
2137 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2139 PERL_UNUSED_CONTEXT;
2140 PERL_UNUSED_ARG(sv);
2141 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2143 mg->mg_len = -1; /* The mg_len holds the len cache. */
2148 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2151 register const char *s;
2154 switch (*mg->mg_ptr) {
2155 case '\001': /* ^A */
2156 sv_setsv(PL_bodytarget, sv);
2158 case '\003': /* ^C */
2159 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2162 case '\004': /* ^D */
2164 s = SvPV_nolen_const(sv);
2165 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2166 DEBUG_x(dump_all());
2168 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2171 case '\005': /* ^E */
2172 if (*(mg->mg_ptr+1) == '\0') {
2173 #ifdef MACOS_TRADITIONAL
2174 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2177 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2180 SetLastError( SvIV(sv) );
2183 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2185 /* will anyone ever use this? */
2186 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2192 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2194 SvREFCNT_dec(PL_encoding);
2195 if (SvOK(sv) || SvGMAGICAL(sv)) {
2196 PL_encoding = newSVsv(sv);
2203 case '\006': /* ^F */
2204 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2206 case '\010': /* ^H */
2207 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2209 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2210 Safefree(PL_inplace);
2211 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2213 case '\017': /* ^O */
2214 if (*(mg->mg_ptr+1) == '\0') {
2215 Safefree(PL_osname);
2218 TAINT_PROPER("assigning to $^O");
2219 PL_osname = savesvpv(sv);
2222 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2223 if (!PL_compiling.cop_io)
2224 PL_compiling.cop_io = newSVsv(sv);
2226 sv_setsv(PL_compiling.cop_io,sv);
2229 case '\020': /* ^P */
2230 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2231 if (PL_perldb && !PL_DBsingle)
2234 case '\024': /* ^T */
2236 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2238 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2241 case '\025': /* ^UTF8CACHE */
2242 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2243 PL_utf8cache = (signed char) sv_2iv(sv);
2246 case '\027': /* ^W & $^WARNING_BITS */
2247 if (*(mg->mg_ptr+1) == '\0') {
2248 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2249 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2250 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2251 | (i ? G_WARN_ON : G_WARN_OFF) ;
2254 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2255 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2256 if (!SvPOK(sv) && PL_localizing) {
2257 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2258 PL_compiling.cop_warnings = pWARN_NONE;
2263 int accumulate = 0 ;
2264 int any_fatals = 0 ;
2265 const char * const ptr = SvPV_const(sv, len) ;
2266 for (i = 0 ; i < len ; ++i) {
2267 accumulate |= ptr[i] ;
2268 any_fatals |= (ptr[i] & 0xAA) ;
2271 PL_compiling.cop_warnings = pWARN_NONE;
2272 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2273 PL_compiling.cop_warnings = pWARN_ALL;
2274 PL_dowarn |= G_WARN_ONCE ;
2277 if (specialWARN(PL_compiling.cop_warnings))
2278 PL_compiling.cop_warnings = newSVsv(sv) ;
2280 sv_setsv(PL_compiling.cop_warnings, sv);
2281 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2282 PL_dowarn |= G_WARN_ONCE ;
2290 if (PL_localizing) {
2291 if (PL_localizing == 1)
2292 SAVESPTR(PL_last_in_gv);
2294 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2295 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2298 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2299 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2300 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2303 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2304 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2305 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2308 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2312 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2313 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2316 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2320 IO * const io = GvIOp(PL_defoutgv);
2323 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2324 IoFLAGS(io) &= ~IOf_FLUSH;
2326 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2327 PerlIO *ofp = IoOFP(io);
2329 (void)PerlIO_flush(ofp);
2330 IoFLAGS(io) |= IOf_FLUSH;
2336 SvREFCNT_dec(PL_rs);
2337 PL_rs = newSVsv(sv);
2341 SvREFCNT_dec(PL_ors_sv);
2342 if (SvOK(sv) || SvGMAGICAL(sv)) {
2343 PL_ors_sv = newSVsv(sv);
2351 SvREFCNT_dec(PL_ofs_sv);
2352 if (SvOK(sv) || SvGMAGICAL(sv)) {
2353 PL_ofs_sv = newSVsv(sv);
2360 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2363 #ifdef COMPLEX_STATUS
2364 if (PL_localizing == 2) {
2365 PL_statusvalue = LvTARGOFF(sv);
2366 PL_statusvalue_vms = LvTARGLEN(sv);
2370 #ifdef VMSISH_STATUS
2372 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2375 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2380 # define PERL_VMS_BANG vaxc$errno
2382 # define PERL_VMS_BANG 0
2384 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2385 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2389 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2390 if (PL_delaymagic) {
2391 PL_delaymagic |= DM_RUID;
2392 break; /* don't do magic till later */
2395 (void)setruid((Uid_t)PL_uid);
2398 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2400 #ifdef HAS_SETRESUID
2401 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2403 if (PL_uid == PL_euid) { /* special case $< = $> */
2405 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2406 if (PL_uid != 0 && PerlProc_getuid() == 0)
2407 (void)PerlProc_setuid(0);
2409 (void)PerlProc_setuid(PL_uid);
2411 PL_uid = PerlProc_getuid();
2412 Perl_croak(aTHX_ "setruid() not implemented");
2417 PL_uid = PerlProc_getuid();
2418 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2421 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2422 if (PL_delaymagic) {
2423 PL_delaymagic |= DM_EUID;
2424 break; /* don't do magic till later */
2427 (void)seteuid((Uid_t)PL_euid);
2430 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2432 #ifdef HAS_SETRESUID
2433 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2435 if (PL_euid == PL_uid) /* special case $> = $< */
2436 PerlProc_setuid(PL_euid);
2438 PL_euid = PerlProc_geteuid();
2439 Perl_croak(aTHX_ "seteuid() not implemented");
2444 PL_euid = PerlProc_geteuid();
2445 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2448 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2449 if (PL_delaymagic) {
2450 PL_delaymagic |= DM_RGID;
2451 break; /* don't do magic till later */
2454 (void)setrgid((Gid_t)PL_gid);
2457 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2459 #ifdef HAS_SETRESGID
2460 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2462 if (PL_gid == PL_egid) /* special case $( = $) */
2463 (void)PerlProc_setgid(PL_gid);
2465 PL_gid = PerlProc_getgid();
2466 Perl_croak(aTHX_ "setrgid() not implemented");
2471 PL_gid = PerlProc_getgid();
2472 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2475 #ifdef HAS_SETGROUPS
2477 const char *p = SvPV_const(sv, len);
2478 Groups_t *gary = NULL;
2483 for (i = 0; i < NGROUPS; ++i) {
2484 while (*p && !isSPACE(*p))
2491 Newx(gary, i + 1, Groups_t);
2493 Renew(gary, i + 1, Groups_t);
2497 (void)setgroups(i, gary);
2501 #else /* HAS_SETGROUPS */
2502 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2503 #endif /* HAS_SETGROUPS */
2504 if (PL_delaymagic) {
2505 PL_delaymagic |= DM_EGID;
2506 break; /* don't do magic till later */
2509 (void)setegid((Gid_t)PL_egid);
2512 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2514 #ifdef HAS_SETRESGID
2515 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2517 if (PL_egid == PL_gid) /* special case $) = $( */
2518 (void)PerlProc_setgid(PL_egid);
2520 PL_egid = PerlProc_getegid();
2521 Perl_croak(aTHX_ "setegid() not implemented");
2526 PL_egid = PerlProc_getegid();
2527 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530 PL_chopset = SvPV_force(sv,len);
2532 #ifndef MACOS_TRADITIONAL
2534 LOCK_DOLLARZERO_MUTEX;
2535 #ifdef HAS_SETPROCTITLE
2536 /* The BSDs don't show the argv[] in ps(1) output, they
2537 * show a string from the process struct and provide
2538 * the setproctitle() routine to manipulate that. */
2539 if (PL_origalen != 1) {
2540 s = SvPV_const(sv, len);
2541 # if __FreeBSD_version > 410001
2542 /* The leading "-" removes the "perl: " prefix,
2543 * but not the "(perl) suffix from the ps(1)
2544 * output, because that's what ps(1) shows if the
2545 * argv[] is modified. */
2546 setproctitle("-%s", s);
2547 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2548 /* This doesn't really work if you assume that
2549 * $0 = 'foobar'; will wipe out 'perl' from the $0
2550 * because in ps(1) output the result will be like
2551 * sprintf("perl: %s (perl)", s)
2552 * I guess this is a security feature:
2553 * one (a user process) cannot get rid of the original name.
2555 setproctitle("%s", s);
2559 #if defined(__hpux) && defined(PSTAT_SETCMD)
2560 if (PL_origalen != 1) {
2562 s = SvPV_const(sv, len);
2563 un.pst_command = (char *)s;
2564 pstat(PSTAT_SETCMD, un, len, 0, 0);
2567 if (PL_origalen > 1) {
2568 /* PL_origalen is set in perl_parse(). */
2569 s = SvPV_force(sv,len);
2570 if (len >= (STRLEN)PL_origalen-1) {
2571 /* Longer than original, will be truncated. We assume that
2572 * PL_origalen bytes are available. */
2573 Copy(s, PL_origargv[0], PL_origalen-1, char);
2576 /* Shorter than original, will be padded. */
2577 Copy(s, PL_origargv[0], len, char);
2578 PL_origargv[0][len] = 0;
2579 memset(PL_origargv[0] + len + 1,
2580 /* Is the space counterintuitive? Yes.
2581 * (You were expecting \0?)
2582 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2585 PL_origalen - len - 1);
2587 PL_origargv[0][PL_origalen-1] = 0;
2588 for (i = 1; i < PL_origargc; i++)
2591 UNLOCK_DOLLARZERO_MUTEX;
2599 Perl_whichsig(pTHX_ const char *sig)
2601 register char* const* sigv;
2602 PERL_UNUSED_CONTEXT;
2604 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2605 if (strEQ(sig,*sigv))
2606 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2608 if (strEQ(sig,"CHLD"))
2612 if (strEQ(sig,"CLD"))
2619 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2620 Perl_sighandler(int sig, ...)
2622 Perl_sighandler(int sig)
2625 #ifdef PERL_GET_SIG_CONTEXT
2626 dTHXa(PERL_GET_SIG_CONTEXT);
2633 SV * const tSv = PL_Sv;
2637 XPV * const tXpv = PL_Xpv;
2639 if (PL_savestack_ix + 15 <= PL_savestack_max)
2641 if (PL_markstack_ptr < PL_markstack_max - 2)
2643 if (PL_scopestack_ix < PL_scopestack_max - 3)
2646 if (!PL_psig_ptr[sig]) {
2647 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2652 /* Max number of items pushed there is 3*n or 4. We cannot fix
2653 infinity, so we fix 4 (in fact 5): */
2655 PL_savestack_ix += 5; /* Protect save in progress. */
2656 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2659 PL_markstack_ptr++; /* Protect mark. */
2661 PL_scopestack_ix += 1;
2662 /* sv_2cv is too complicated, try a simpler variant first: */
2663 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2664 || SvTYPE(cv) != SVt_PVCV) {
2666 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2669 if (!cv || !CvROOT(cv)) {
2670 if (ckWARN(WARN_SIGNAL))
2671 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2672 PL_sig_name[sig], (gv ? GvENAME(gv)
2679 if(PL_psig_name[sig]) {
2680 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2682 #if !defined(PERL_IMPLICIT_CONTEXT)
2686 sv = sv_newmortal();
2687 sv_setpv(sv,PL_sig_name[sig]);
2690 PUSHSTACKi(PERLSI_SIGNAL);
2693 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2695 struct sigaction oact;
2697 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2701 va_start(args, sig);
2702 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2705 SV *rv = newRV_noinc((SV*)sih);
2706 /* The siginfo fields signo, code, errno, pid, uid,
2707 * addr, status, and band are defined by POSIX/SUSv3. */
2708 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2709 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2710 #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. */
2711 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2712 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2713 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2714 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2715 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2716 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2720 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2729 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2732 if (SvTRUE(ERRSV)) {
2734 #ifdef HAS_SIGPROCMASK
2735 /* Handler "died", for example to get out of a restart-able read().
2736 * Before we re-do that on its behalf re-enable the signal which was
2737 * blocked by the system when we entered.
2741 sigaddset(&set,sig);
2742 sigprocmask(SIG_UNBLOCK, &set, NULL);
2744 /* Not clear if this will work */
2745 (void)rsignal(sig, SIG_IGN);
2746 (void)rsignal(sig, PL_csighandlerp);
2748 #endif /* !PERL_MICRO */
2749 Perl_die(aTHX_ NULL);
2753 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2757 PL_scopestack_ix -= 1;
2760 PL_op = myop; /* Apparently not needed... */
2762 PL_Sv = tSv; /* Restore global temporaries. */
2769 S_restore_magic(pTHX_ const void *p)
2772 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2773 SV* const sv = mgs->mgs_sv;
2778 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2780 #ifdef PERL_OLD_COPY_ON_WRITE
2781 /* While magic was saved (and off) sv_setsv may well have seen
2782 this SV as a prime candidate for COW. */
2784 sv_force_normal_flags(sv, 0);
2788 SvFLAGS(sv) |= mgs->mgs_flags;
2791 if (SvGMAGICAL(sv)) {
2792 /* downgrade public flags to private,
2793 and discard any other private flags */
2795 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2797 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2798 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2803 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2805 /* If we're still on top of the stack, pop us off. (That condition
2806 * will be satisfied if restore_magic was called explicitly, but *not*
2807 * if it's being called via leave_scope.)
2808 * The reason for doing this is that otherwise, things like sv_2cv()
2809 * may leave alloc gunk on the savestack, and some code
2810 * (e.g. sighandler) doesn't expect that...
2812 if (PL_savestack_ix == mgs->mgs_ss_ix)
2814 I32 popval = SSPOPINT;
2815 assert(popval == SAVEt_DESTRUCTOR_X);
2816 PL_savestack_ix -= 2;
2818 assert(popval == SAVEt_ALLOC);
2820 PL_savestack_ix -= popval;
2826 S_unwind_handler_stack(pTHX_ const void *p)
2829 const U32 flags = *(const U32*)p;
2832 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2833 #if !defined(PERL_IMPLICIT_CONTEXT)
2835 SvREFCNT_dec(PL_sig_sv);
2841 * c-indentation-style: bsd
2843 * indent-tabs-mode: t
2846 * ex: set ts=8 sts=4 sw=4 noet: