3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 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)
52 # include <sys/pstat.h>
55 Signal_t Perl_csighandler(int sig);
58 /* Missing protos on LynxOS */
59 void setruid(uid_t id);
60 void seteuid(uid_t id);
61 void setrgid(uid_t id);
62 void setegid(uid_t id);
66 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
74 /* MGS is typedef'ed to struct magic_state in perl.h */
77 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
80 assert(SvMAGICAL(sv));
81 #ifdef PERL_OLD_COPY_ON_WRITE
82 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
87 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
89 mgs = SSPTR(mgs_ix, MGS*);
91 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
92 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
96 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
100 =for apidoc mg_magical
102 Turns on the magical status of an SV. See C<sv_magic>.
108 Perl_mg_magical(pTHX_ SV *sv)
111 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
112 const MGVTBL* const vtbl = mg->mg_virtual;
114 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
118 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
127 Do magic after a value is retrieved from the SV. See C<sv_magic>.
133 Perl_mg_get(pTHX_ SV *sv)
135 const I32 mgs_ix = SSNEW(sizeof(MGS));
136 const bool was_temp = (bool)SvTEMP(sv);
138 MAGIC *newmg, *head, *cur, *mg;
139 /* guard against sv having being freed midway by holding a private
142 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
143 cause the SV's buffer to get stolen (and maybe other stuff).
146 sv_2mortal(SvREFCNT_inc(sv));
151 save_magic(mgs_ix, sv);
153 /* We must call svt_get(sv, mg) for each valid entry in the linked
154 list of magic. svt_get() may delete the current entry, add new
155 magic to the head of the list, or upgrade the SV. AMS 20010810 */
157 newmg = cur = head = mg = SvMAGIC(sv);
159 const MGVTBL * const vtbl = mg->mg_virtual;
161 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
162 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
164 /* guard against magic having been deleted - eg FETCH calling
169 /* Don't restore the flags for this entry if it was deleted. */
170 if (mg->mg_flags & MGf_GSKIP)
171 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
174 mg = mg->mg_moremagic;
177 /* Have we finished with the new entries we saw? Start again
178 where we left off (unless there are more new entries). */
186 /* Were any new entries added? */
187 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
194 restore_magic(INT2PTR(void *, (IV)mgs_ix));
196 if (SvREFCNT(sv) == 1) {
197 /* We hold the last reference to this SV, which implies that the
198 SV was deleted as a side effect of the routines we called. */
207 Do magic after a value is assigned to the SV. See C<sv_magic>.
213 Perl_mg_set(pTHX_ SV *sv)
215 const I32 mgs_ix = SSNEW(sizeof(MGS));
219 save_magic(mgs_ix, sv);
221 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
222 const MGVTBL* vtbl = mg->mg_virtual;
223 nextmg = mg->mg_moremagic; /* it may delete itself */
224 if (mg->mg_flags & MGf_GSKIP) {
225 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
226 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
228 if (vtbl && vtbl->svt_set)
229 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
232 restore_magic(INT2PTR(void*, (IV)mgs_ix));
237 =for apidoc mg_length
239 Report on the SV's length. See C<sv_magic>.
245 Perl_mg_length(pTHX_ SV *sv)
250 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
251 const MGVTBL * const vtbl = mg->mg_virtual;
252 if (vtbl && vtbl->svt_len) {
253 const I32 mgs_ix = SSNEW(sizeof(MGS));
254 save_magic(mgs_ix, sv);
255 /* omit MGf_GSKIP -- not changed here */
256 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
257 restore_magic(INT2PTR(void*, (IV)mgs_ix));
263 const U8 *s = (U8*)SvPV_const(sv, len);
264 len = Perl_utf8_length(aTHX_ s, s + len);
267 (void)SvPV_const(sv, len);
272 Perl_mg_size(pTHX_ SV *sv)
276 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
277 const MGVTBL* const vtbl = mg->mg_virtual;
278 if (vtbl && vtbl->svt_len) {
279 const I32 mgs_ix = SSNEW(sizeof(MGS));
281 save_magic(mgs_ix, sv);
282 /* omit MGf_GSKIP -- not changed here */
283 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
284 restore_magic(INT2PTR(void*, (IV)mgs_ix));
291 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
295 Perl_croak(aTHX_ "Size magic not implemented");
304 Clear something magical that the SV represents. See C<sv_magic>.
310 Perl_mg_clear(pTHX_ SV *sv)
312 const I32 mgs_ix = SSNEW(sizeof(MGS));
315 save_magic(mgs_ix, sv);
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 const MGVTBL* const vtbl = mg->mg_virtual;
319 /* omit GSKIP -- never set here */
321 if (vtbl && vtbl->svt_clear)
322 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
325 restore_magic(INT2PTR(void*, (IV)mgs_ix));
332 Finds the magic pointer for type matching the SV. See C<sv_magic>.
338 Perl_mg_find(pTHX_ const SV *sv, int type)
342 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
343 if (mg->mg_type == type)
353 Copies the magic from one SV to another. See C<sv_magic>.
359 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
363 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
364 const MGVTBL* const vtbl = mg->mg_virtual;
365 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
366 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
368 else if (isUPPER(mg->mg_type)) {
370 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
371 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
373 toLOWER(mg->mg_type), key, klen);
381 =for apidoc mg_localize
383 Copy some of the magic from an existing SV to new localized version of
384 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
385 doesn't (eg taint, pos).
391 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
394 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
395 const MGVTBL* const vtbl = mg->mg_virtual;
396 switch (mg->mg_type) {
397 /* value magic types: don't copy */
400 case PERL_MAGIC_regex_global:
401 case PERL_MAGIC_nkeys:
402 #ifdef USE_LOCALE_COLLATE
403 case PERL_MAGIC_collxfrm:
406 case PERL_MAGIC_taint:
408 case PERL_MAGIC_vstring:
409 case PERL_MAGIC_utf8:
410 case PERL_MAGIC_substr:
411 case PERL_MAGIC_defelem:
412 case PERL_MAGIC_arylen:
414 case PERL_MAGIC_backref:
415 case PERL_MAGIC_arylen_p:
416 case PERL_MAGIC_rhash:
417 case PERL_MAGIC_symtab:
421 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
422 /* XXX calling the copy method is probably not correct. DAPM */
423 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
424 mg->mg_ptr, mg->mg_len);
427 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
428 mg->mg_ptr, mg->mg_len);
430 /* container types should remain read-only across localization */
431 SvFLAGS(nsv) |= SvREADONLY(sv);
434 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
435 SvFLAGS(nsv) |= SvMAGICAL(sv);
445 Free any magic storage used by the SV. See C<sv_magic>.
451 Perl_mg_free(pTHX_ SV *sv)
455 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
456 const MGVTBL* const vtbl = mg->mg_virtual;
457 moremagic = mg->mg_moremagic;
458 if (vtbl && vtbl->svt_free)
459 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
460 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
461 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
462 Safefree(mg->mg_ptr);
463 else if (mg->mg_len == HEf_SVKEY)
464 SvREFCNT_dec((SV*)mg->mg_ptr);
466 if (mg->mg_flags & MGf_REFCOUNTED)
467 SvREFCNT_dec(mg->mg_obj);
470 SvMAGIC_set(sv, NULL);
477 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
479 register const REGEXP *rx;
482 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
483 if (mg->mg_obj) /* @+ */
486 return rx->lastparen;
493 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
497 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
498 register const I32 paren = mg->mg_len;
503 if (paren <= (I32)rx->nparens &&
504 (s = rx->startp[paren]) != -1 &&
505 (t = rx->endp[paren]) != -1)
508 if (mg->mg_obj) /* @+ */
513 if (i > 0 && RX_MATCH_UTF8(rx)) {
514 const char * const b = rx->subbeg;
516 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
526 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
528 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
529 Perl_croak(aTHX_ PL_no_modify);
530 NORETURN_FUNCTION_END;
534 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
538 register const REGEXP *rx;
541 switch (*mg->mg_ptr) {
542 case '1': case '2': case '3': case '4':
543 case '5': case '6': case '7': case '8': case '9': case '&':
544 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
546 paren = atoi(mg->mg_ptr); /* $& is in [0] */
548 if (paren <= (I32)rx->nparens &&
549 (s1 = rx->startp[paren]) != -1 &&
550 (t1 = rx->endp[paren]) != -1)
554 if (i > 0 && RX_MATCH_UTF8(rx)) {
555 const char * const s = rx->subbeg + s1;
560 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
564 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
568 if (ckWARN(WARN_UNINITIALIZED))
573 if (ckWARN(WARN_UNINITIALIZED))
578 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
579 paren = rx->lastparen;
584 case '\016': /* ^N */
585 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
586 paren = rx->lastcloseparen;
592 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 if (rx->startp[0] != -1) {
604 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
605 if (rx->endp[0] != -1) {
606 i = rx->sublen - rx->endp[0];
617 if (!SvPOK(sv) && SvNIOK(sv)) {
625 #define SvRTRIM(sv) STMT_START { \
626 STRLEN len = SvCUR(sv); \
627 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
629 SvCUR_set(sv, len); \
633 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
637 register char *s = NULL;
641 switch (*mg->mg_ptr) {
642 case '\001': /* ^A */
643 sv_setsv(sv, PL_bodytarget);
645 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
646 if (*(mg->mg_ptr+1) == '\0') {
647 sv_setiv(sv, (IV)PL_minus_c);
649 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
650 sv_setiv(sv, (IV)STATUS_NATIVE);
654 case '\004': /* ^D */
655 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
657 case '\005': /* ^E */
658 if (*(mg->mg_ptr+1) == '\0') {
659 #ifdef MACOS_TRADITIONAL
663 sv_setnv(sv,(double)gMacPerl_OSErr);
664 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
669 # include <descrip.h>
670 # include <starlet.h>
672 $DESCRIPTOR(msgdsc,msg);
673 sv_setnv(sv,(NV) vaxc$errno);
674 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
675 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
681 if (!(_emx_env & 0x200)) { /* Under DOS */
682 sv_setnv(sv, (NV)errno);
683 sv_setpv(sv, errno ? Strerror(errno) : "");
685 if (errno != errno_isOS2) {
686 int tmp = _syserrno();
687 if (tmp) /* 2nd call to _syserrno() makes it 0 */
690 sv_setnv(sv, (NV)Perl_rc);
691 sv_setpv(sv, os2error(Perl_rc));
696 DWORD dwErr = GetLastError();
697 sv_setnv(sv, (NV)dwErr);
700 PerlProc_GetOSError(sv, dwErr);
703 sv_setpvn(sv, "", 0);
708 const int saveerrno = errno;
709 sv_setnv(sv, (NV)errno);
710 sv_setpv(sv, errno ? Strerror(errno) : "");
718 SvNOK_on(sv); /* what a wonderful hack! */
720 else if (strEQ(mg->mg_ptr+1, "NCODING"))
721 sv_setsv(sv, PL_encoding);
723 case '\006': /* ^F */
724 sv_setiv(sv, (IV)PL_maxsysfd);
726 case '\010': /* ^H */
727 sv_setiv(sv, (IV)PL_hints);
729 case '\011': /* ^I */ /* NOT \t in EBCDIC */
731 sv_setpv(sv, PL_inplace);
733 sv_setsv(sv, &PL_sv_undef);
735 case '\017': /* ^O & ^OPEN */
736 if (*(mg->mg_ptr+1) == '\0') {
737 sv_setpv(sv, PL_osname);
740 else if (strEQ(mg->mg_ptr, "\017PEN")) {
741 if (!PL_compiling.cop_io)
742 sv_setsv(sv, &PL_sv_undef);
744 sv_setsv(sv, PL_compiling.cop_io);
748 case '\020': /* ^P */
749 sv_setiv(sv, (IV)PL_perldb);
751 case '\023': /* ^S */
752 if (*(mg->mg_ptr+1) == '\0') {
753 if (PL_lex_state != LEX_NOTPARSING)
756 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
761 case '\024': /* ^T */
762 if (*(mg->mg_ptr+1) == '\0') {
764 sv_setnv(sv, PL_basetime);
766 sv_setiv(sv, (IV)PL_basetime);
769 else if (strEQ(mg->mg_ptr, "\024AINT"))
770 sv_setiv(sv, PL_tainting
771 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
774 case '\025': /* $^UNICODE, $^UTF8LOCALE */
775 if (strEQ(mg->mg_ptr, "\025NICODE"))
776 sv_setuv(sv, (UV) PL_unicode);
777 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
778 sv_setuv(sv, (UV) PL_utf8locale);
780 case '\027': /* ^W & $^WARNING_BITS */
781 if (*(mg->mg_ptr+1) == '\0')
782 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
783 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
784 if (PL_compiling.cop_warnings == pWARN_NONE ||
785 PL_compiling.cop_warnings == pWARN_STD)
787 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
789 else if (PL_compiling.cop_warnings == pWARN_ALL) {
790 /* Get the bit mask for $warnings::Bits{all}, because
791 * it could have been extended by warnings::register */
793 HV *bits=get_hv("warnings::Bits", FALSE);
794 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
795 sv_setsv(sv, *bits_all);
798 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
802 sv_setsv(sv, PL_compiling.cop_warnings);
807 case '1': case '2': case '3': case '4':
808 case '5': case '6': case '7': case '8': case '9': case '&':
809 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
813 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
814 * XXX Does the new way break anything?
816 paren = atoi(mg->mg_ptr); /* $& is in [0] */
818 if (paren <= (I32)rx->nparens &&
819 (s1 = rx->startp[paren]) != -1 &&
820 (t1 = rx->endp[paren]) != -1)
830 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
835 if (RX_MATCH_TAINTED(rx)) {
836 MAGIC* mg = SvMAGIC(sv);
839 SvMAGIC_set(sv, mg->mg_moremagic);
841 if ((mgt = SvMAGIC(sv))) {
842 mg->mg_moremagic = mgt;
852 sv_setsv(sv,&PL_sv_undef);
855 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
856 paren = rx->lastparen;
860 sv_setsv(sv,&PL_sv_undef);
862 case '\016': /* ^N */
863 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
864 paren = rx->lastcloseparen;
868 sv_setsv(sv,&PL_sv_undef);
871 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
872 if ((s = rx->subbeg) && rx->startp[0] != -1) {
877 sv_setsv(sv,&PL_sv_undef);
880 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
881 if (rx->subbeg && rx->endp[0] != -1) {
882 s = rx->subbeg + rx->endp[0];
883 i = rx->sublen - rx->endp[0];
887 sv_setsv(sv,&PL_sv_undef);
890 if (GvIO(PL_last_in_gv)) {
891 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
896 sv_setiv(sv, (IV)STATUS_CURRENT);
897 #ifdef COMPLEX_STATUS
898 LvTARGOFF(sv) = PL_statusvalue;
899 LvTARGLEN(sv) = PL_statusvalue_vms;
904 if (GvIOp(PL_defoutgv))
905 s = IoTOP_NAME(GvIOp(PL_defoutgv));
909 sv_setpv(sv,GvENAME(PL_defoutgv));
914 if (GvIOp(PL_defoutgv))
915 s = IoFMT_NAME(GvIOp(PL_defoutgv));
917 s = GvENAME(PL_defoutgv);
921 if (GvIOp(PL_defoutgv))
922 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
925 if (GvIOp(PL_defoutgv))
926 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
929 if (GvIOp(PL_defoutgv))
930 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
937 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
940 if (GvIOp(PL_defoutgv))
941 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
947 sv_copypv(sv, PL_ors_sv);
951 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
952 sv_setpv(sv, errno ? Strerror(errno) : "");
955 const int saveerrno = errno;
956 sv_setnv(sv, (NV)errno);
958 if (errno == errno_isOS2 || errno == errno_isOS2_set)
959 sv_setpv(sv, os2error(Perl_rc));
962 sv_setpv(sv, errno ? Strerror(errno) : "");
967 SvNOK_on(sv); /* what a wonderful hack! */
970 sv_setiv(sv, (IV)PL_uid);
973 sv_setiv(sv, (IV)PL_euid);
976 sv_setiv(sv, (IV)PL_gid);
978 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
982 sv_setiv(sv, (IV)PL_egid);
984 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
989 Groups_t gary[NGROUPS];
990 I32 j = getgroups(NGROUPS,gary);
992 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
995 (void)SvIOK_on(sv); /* what a wonderful hack! */
997 #ifndef MACOS_TRADITIONAL
1006 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1008 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1010 if (uf && uf->uf_val)
1011 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1016 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1023 s = SvPV_const(sv,len);
1024 ptr = MgPV_const(mg,klen);
1027 #ifdef DYNAMIC_ENV_FETCH
1028 /* We just undefd an environment var. Is a replacement */
1029 /* waiting in the wings? */
1032 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1033 s = SvPV_const(*valp, len);
1037 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1038 /* And you'll never guess what the dog had */
1039 /* in its mouth... */
1041 MgTAINTEDDIR_off(mg);
1043 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1044 char pathbuf[256], eltbuf[256], *cp, *elt = s;
1048 do { /* DCL$PATH may be a search list */
1049 while (1) { /* as may dev portion of any element */
1050 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1051 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1052 cando_by_name(S_IWUSR,0,elt) ) {
1053 MgTAINTEDDIR_on(mg);
1057 if ((cp = strchr(elt, ':')) != Nullch)
1059 if (my_trnlnm(elt, eltbuf, j++))
1065 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1068 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1069 const char * const strend = s + len;
1071 while (s < strend) {
1075 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1076 s, strend, ':', &i);
1078 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1080 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1081 MgTAINTEDDIR_on(mg);
1087 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1093 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1095 PERL_UNUSED_ARG(sv);
1096 my_setenv(MgPV_nolen_const(mg),Nullch);
1101 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1103 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1104 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1106 if (PL_localizing) {
1108 magic_clear_all_env(sv,mg);
1109 hv_iterinit((HV*)sv);
1110 while ((entry = hv_iternext((HV*)sv))) {
1112 my_setenv(hv_iterkey(entry, &keylen),
1113 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1121 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1126 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1128 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1131 # ifdef USE_ENVIRON_ARRAY
1132 # if defined(USE_ITHREADS)
1133 /* only the parent thread can clobber the process environment */
1134 if (PL_curinterp == aTHX)
1137 # ifndef PERL_USE_SAFE_PUTENV
1138 if (!PL_use_safe_putenv) {
1141 if (environ == PL_origenviron)
1142 environ = (char**)safesysmalloc(sizeof(char*));
1144 for (i = 0; environ[i]; i++)
1145 safesysfree(environ[i]);
1147 # endif /* PERL_USE_SAFE_PUTENV */
1149 environ[0] = Nullch;
1151 # endif /* USE_ENVIRON_ARRAY */
1152 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1153 #endif /* VMS || EPOC */
1154 #endif /* !PERL_MICRO */
1155 PERL_UNUSED_ARG(sv);
1156 PERL_UNUSED_ARG(mg);
1161 #ifdef HAS_SIGPROCMASK
1163 restore_sigmask(pTHX_ SV *save_sv)
1165 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1166 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1170 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1172 /* Are we fetching a signal entry? */
1173 const I32 i = whichsig(MgPV_nolen_const(mg));
1176 sv_setsv(sv,PL_psig_ptr[i]);
1178 Sighandler_t sigstate;
1179 sigstate = rsignal_state(i);
1180 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1181 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1186 /* cache state so we don't fetch it again */
1187 if(sigstate == SIG_IGN)
1188 sv_setpv(sv,"IGNORE");
1190 sv_setsv(sv,&PL_sv_undef);
1191 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1198 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1200 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1201 * refactoring might be in order.
1204 register const char * const s = MgPV_nolen_const(mg);
1205 PERL_UNUSED_ARG(sv);
1208 if (strEQ(s,"__DIE__"))
1210 else if (strEQ(s,"__WARN__"))
1213 Perl_croak(aTHX_ "No such hook: %s", s);
1215 SV * const to_dec = *svp;
1217 SvREFCNT_dec(to_dec);
1221 /* Are we clearing a signal entry? */
1222 const I32 i = whichsig(s);
1224 #ifdef HAS_SIGPROCMASK
1227 /* Avoid having the signal arrive at a bad time, if possible. */
1230 sigprocmask(SIG_BLOCK, &set, &save);
1232 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1233 SAVEFREESV(save_sv);
1234 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1238 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1240 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1241 PL_sig_defaulting[i] = 1;
1242 (void)rsignal(i, PL_csighandlerp);
1244 (void)rsignal(i, SIG_DFL);
1246 if(PL_psig_name[i]) {
1247 SvREFCNT_dec(PL_psig_name[i]);
1250 if(PL_psig_ptr[i]) {
1251 SV *to_dec=PL_psig_ptr[i];
1254 SvREFCNT_dec(to_dec);
1264 S_raise_signal(pTHX_ int sig)
1266 /* Set a flag to say this signal is pending */
1267 PL_psig_pend[sig]++;
1268 /* And one to say _a_ signal is pending */
1273 Perl_csighandler(int sig)
1275 #ifdef PERL_GET_SIG_CONTEXT
1276 dTHXa(PERL_GET_SIG_CONTEXT);
1280 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1281 (void) rsignal(sig, PL_csighandlerp);
1282 if (PL_sig_ignoring[sig]) return;
1284 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1285 if (PL_sig_defaulting[sig])
1286 #ifdef KILL_BY_SIGPRC
1287 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1292 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1293 /* Call the perl level handler now--
1294 * with risk we may be in malloc() etc. */
1295 (*PL_sighandlerp)(sig);
1297 S_raise_signal(aTHX_ sig);
1300 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1302 Perl_csighandler_init(void)
1305 if (PL_sig_handlers_initted) return;
1307 for (sig = 1; sig < SIG_SIZE; sig++) {
1308 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1310 PL_sig_defaulting[sig] = 1;
1311 (void) rsignal(sig, PL_csighandlerp);
1313 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1314 PL_sig_ignoring[sig] = 0;
1317 PL_sig_handlers_initted = 1;
1322 Perl_despatch_signals(pTHX)
1326 for (sig = 1; sig < SIG_SIZE; sig++) {
1327 if (PL_psig_pend[sig]) {
1328 PERL_BLOCKSIG_ADD(set, sig);
1329 PL_psig_pend[sig] = 0;
1330 PERL_BLOCKSIG_BLOCK(set);
1331 (*PL_sighandlerp)(sig);
1332 PERL_BLOCKSIG_UNBLOCK(set);
1338 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1343 /* Need to be careful with SvREFCNT_dec(), because that can have side
1344 * effects (due to closures). We must make sure that the new disposition
1345 * is in place before it is called.
1349 #ifdef HAS_SIGPROCMASK
1354 register const char *s = MgPV_const(mg,len);
1356 if (strEQ(s,"__DIE__"))
1358 else if (strEQ(s,"__WARN__"))
1361 Perl_croak(aTHX_ "No such hook: %s", s);
1369 i = whichsig(s); /* ...no, a brick */
1371 if (ckWARN(WARN_SIGNAL))
1372 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1375 #ifdef HAS_SIGPROCMASK
1376 /* Avoid having the signal arrive at a bad time, if possible. */
1379 sigprocmask(SIG_BLOCK, &set, &save);
1381 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1382 SAVEFREESV(save_sv);
1383 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1386 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1387 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1389 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1390 PL_sig_ignoring[i] = 0;
1392 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1393 PL_sig_defaulting[i] = 0;
1395 SvREFCNT_dec(PL_psig_name[i]);
1396 to_dec = PL_psig_ptr[i];
1397 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1398 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1399 PL_psig_name[i] = newSVpvn(s, len);
1400 SvREADONLY_on(PL_psig_name[i]);
1402 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1404 (void)rsignal(i, PL_csighandlerp);
1405 #ifdef HAS_SIGPROCMASK
1410 *svp = SvREFCNT_inc(sv);
1412 SvREFCNT_dec(to_dec);
1415 s = SvPV_force(sv,len);
1416 if (strEQ(s,"IGNORE")) {
1418 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1419 PL_sig_ignoring[i] = 1;
1420 (void)rsignal(i, PL_csighandlerp);
1422 (void)rsignal(i, SIG_IGN);
1426 else if (strEQ(s,"DEFAULT") || !*s) {
1428 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1430 PL_sig_defaulting[i] = 1;
1431 (void)rsignal(i, PL_csighandlerp);
1434 (void)rsignal(i, SIG_DFL);
1439 * We should warn if HINT_STRICT_REFS, but without
1440 * access to a known hint bit in a known OP, we can't
1441 * tell whether HINT_STRICT_REFS is in force or not.
1443 if (!strchr(s,':') && !strchr(s,'\''))
1444 sv_insert(sv, 0, 0, "main::", 6);
1446 (void)rsignal(i, PL_csighandlerp);
1448 *svp = SvREFCNT_inc(sv);
1450 #ifdef HAS_SIGPROCMASK
1455 SvREFCNT_dec(to_dec);
1458 #endif /* !PERL_MICRO */
1461 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1463 PERL_UNUSED_ARG(sv);
1464 PERL_UNUSED_ARG(mg);
1465 PL_sub_generation++;
1470 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1472 PERL_UNUSED_ARG(sv);
1473 PERL_UNUSED_ARG(mg);
1474 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1475 PL_amagic_generation++;
1481 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1483 HV * const hv = (HV*)LvTARG(sv);
1485 PERL_UNUSED_ARG(mg);
1488 (void) hv_iterinit(hv);
1489 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1492 while (hv_iternext(hv))
1497 sv_setiv(sv, (IV)i);
1502 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1504 PERL_UNUSED_ARG(mg);
1506 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1511 /* caller is responsible for stack switching/cleanup */
1513 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1519 PUSHs(SvTIED_obj(sv, mg));
1522 if (mg->mg_len >= 0)
1523 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1524 else if (mg->mg_len == HEf_SVKEY)
1525 PUSHs((SV*)mg->mg_ptr);
1527 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1528 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1536 return call_method(meth, flags);
1540 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1546 PUSHSTACKi(PERLSI_MAGIC);
1548 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1549 sv_setsv(sv, *PL_stack_sp--);
1559 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1562 mg->mg_flags |= MGf_GSKIP;
1563 magic_methpack(sv,mg,"FETCH");
1568 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1572 PUSHSTACKi(PERLSI_MAGIC);
1573 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1580 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1582 return magic_methpack(sv,mg,"DELETE");
1587 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1594 PUSHSTACKi(PERLSI_MAGIC);
1595 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1596 sv = *PL_stack_sp--;
1597 retval = (U32) SvIV(sv)-1;
1606 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1611 PUSHSTACKi(PERLSI_MAGIC);
1613 XPUSHs(SvTIED_obj(sv, mg));
1615 call_method("CLEAR", G_SCALAR|G_DISCARD);
1623 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1626 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1630 PUSHSTACKi(PERLSI_MAGIC);
1633 PUSHs(SvTIED_obj(sv, mg));
1638 if (call_method(meth, G_SCALAR))
1639 sv_setsv(key, *PL_stack_sp--);
1648 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1650 return magic_methpack(sv,mg,"EXISTS");
1654 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1657 SV *retval = &PL_sv_undef;
1658 SV * const tied = SvTIED_obj((SV*)hv, mg);
1659 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1661 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1663 if (HvEITER_get(hv))
1664 /* we are in an iteration so the hash cannot be empty */
1666 /* no xhv_eiter so now use FIRSTKEY */
1667 key = sv_newmortal();
1668 magic_nextpack((SV*)hv, mg, key);
1669 HvEITER_set(hv, NULL); /* need to reset iterator */
1670 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1673 /* there is a SCALAR method that we can call */
1675 PUSHSTACKi(PERLSI_MAGIC);
1681 if (call_method("SCALAR", G_SCALAR))
1682 retval = *PL_stack_sp--;
1689 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1691 GV * const gv = PL_DBline;
1692 const I32 i = SvTRUE(sv);
1693 SV ** const svp = av_fetch(GvAV(gv),
1694 atoi(MgPV_nolen_const(mg)), FALSE);
1695 if (svp && SvIOKp(*svp)) {
1696 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1698 /* set or clear breakpoint in the relevant control op */
1700 o->op_flags |= OPf_SPECIAL;
1702 o->op_flags &= ~OPf_SPECIAL;
1709 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1711 const AV * const obj = (AV*)mg->mg_obj;
1713 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1721 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1723 AV * const obj = (AV*)mg->mg_obj;
1725 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1727 if (ckWARN(WARN_MISC))
1728 Perl_warner(aTHX_ packWARN(WARN_MISC),
1729 "Attempt to set length of freed array");
1735 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1737 PERL_UNUSED_ARG(sv);
1738 /* during global destruction, mg_obj may already have been freed */
1739 if (PL_in_clean_all)
1742 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1745 /* arylen scalar holds a pointer back to the array, but doesn't own a
1746 reference. Hence the we (the array) are about to go away with it
1747 still pointing at us. Clear its pointer, else it would be pointing
1748 at free memory. See the comment in sv_magic about reference loops,
1749 and why it can't own a reference to us. */
1756 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1758 SV* const lsv = LvTARG(sv);
1760 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1761 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1762 if (mg && mg->mg_len >= 0) {
1765 sv_pos_b2u(lsv, &i);
1766 sv_setiv(sv, i + PL_curcop->cop_arybase);
1775 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1777 SV* const lsv = LvTARG(sv);
1784 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1785 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1789 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1790 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1792 else if (!SvOK(sv)) {
1796 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1798 pos = SvIV(sv) - PL_curcop->cop_arybase;
1801 ulen = sv_len_utf8(lsv);
1811 else if (pos > (SSize_t)len)
1816 sv_pos_u2b(lsv, &p, 0);
1821 mg->mg_flags &= ~MGf_MINMATCH;
1827 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1829 PERL_UNUSED_ARG(mg);
1830 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1832 gv_efullname3(sv,((GV*)sv), "*");
1836 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1841 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1844 PERL_UNUSED_ARG(mg);
1848 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1853 GvGP(sv) = gp_ref(GvGP(gv));
1858 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1861 SV * const lsv = LvTARG(sv);
1862 const char * const tmps = SvPV_const(lsv,len);
1863 I32 offs = LvTARGOFF(sv);
1864 I32 rem = LvTARGLEN(sv);
1865 PERL_UNUSED_ARG(mg);
1868 sv_pos_u2b(lsv, &offs, &rem);
1869 if (offs > (I32)len)
1871 if (rem + offs > (I32)len)
1873 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1880 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1883 const char *tmps = SvPV_const(sv, len);
1884 SV * const lsv = LvTARG(sv);
1885 I32 lvoff = LvTARGOFF(sv);
1886 I32 lvlen = LvTARGLEN(sv);
1887 PERL_UNUSED_ARG(mg);
1890 sv_utf8_upgrade(lsv);
1891 sv_pos_u2b(lsv, &lvoff, &lvlen);
1892 sv_insert(lsv, lvoff, lvlen, tmps, len);
1893 LvTARGLEN(sv) = sv_len_utf8(sv);
1896 else if (lsv && SvUTF8(lsv)) {
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 LvTARGLEN(sv) = len;
1899 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1900 sv_insert(lsv, lvoff, lvlen, tmps, len);
1904 sv_insert(lsv, lvoff, lvlen, tmps, len);
1905 LvTARGLEN(sv) = len;
1913 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1915 PERL_UNUSED_ARG(sv);
1916 TAINT_IF(mg->mg_len & 1);
1921 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1923 PERL_UNUSED_ARG(sv);
1932 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1934 SV * const lsv = LvTARG(sv);
1935 PERL_UNUSED_ARG(mg);
1942 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1947 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1949 PERL_UNUSED_ARG(mg);
1950 do_vecset(sv); /* XXX slurp this routine */
1955 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1958 if (LvTARGLEN(sv)) {
1960 SV * const ahv = LvTARG(sv);
1961 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1966 AV* const av = (AV*)LvTARG(sv);
1967 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1968 targ = AvARRAY(av)[LvTARGOFF(sv)];
1970 if (targ && targ != &PL_sv_undef) {
1971 /* somebody else defined it for us */
1972 SvREFCNT_dec(LvTARG(sv));
1973 LvTARG(sv) = SvREFCNT_inc(targ);
1975 SvREFCNT_dec(mg->mg_obj);
1976 mg->mg_obj = Nullsv;
1977 mg->mg_flags &= ~MGf_REFCOUNTED;
1982 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1987 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1989 PERL_UNUSED_ARG(mg);
1993 sv_setsv(LvTARG(sv), sv);
1994 SvSETMAGIC(LvTARG(sv));
2000 Perl_vivify_defelem(pTHX_ SV *sv)
2005 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2008 SV * const ahv = LvTARG(sv);
2009 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2012 if (!value || value == &PL_sv_undef)
2013 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2016 AV* const av = (AV*)LvTARG(sv);
2017 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2018 LvTARG(sv) = Nullsv; /* array can't be extended */
2020 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2021 if (!svp || (value = *svp) == &PL_sv_undef)
2022 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2025 (void)SvREFCNT_inc(value);
2026 SvREFCNT_dec(LvTARG(sv));
2029 SvREFCNT_dec(mg->mg_obj);
2030 mg->mg_obj = Nullsv;
2031 mg->mg_flags &= ~MGf_REFCOUNTED;
2035 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2037 AV *const av = (AV*)mg->mg_obj;
2038 SV **svp = AvARRAY(av);
2039 PERL_UNUSED_ARG(sv);
2042 SV *const *const last = svp + AvFILLp(av);
2044 while (svp <= last) {
2046 SV *const referrer = *svp;
2047 if (SvWEAKREF(referrer)) {
2048 /* XXX Should we check that it hasn't changed? */
2049 SvRV_set(referrer, 0);
2051 SvWEAKREF_off(referrer);
2052 } else if (SvTYPE(referrer) == SVt_PVGV ||
2053 SvTYPE(referrer) == SVt_PVLV) {
2054 /* You lookin' at me? */
2055 assert(GvSTASH(referrer));
2056 assert(GvSTASH(referrer) == (HV*)sv);
2057 GvSTASH(referrer) = 0;
2060 "panic: magic_killbackrefs (flags=%"UVxf")",
2069 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2074 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2082 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2084 PERL_UNUSED_ARG(mg);
2085 sv_unmagic(sv, PERL_MAGIC_bm);
2091 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2093 PERL_UNUSED_ARG(mg);
2094 sv_unmagic(sv, PERL_MAGIC_fm);
2100 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2102 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2104 if (uf && uf->uf_set)
2105 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2110 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_UNUSED_ARG(mg);
2113 sv_unmagic(sv, PERL_MAGIC_qr);
2118 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)
2159 register const char *s;
2162 switch (*mg->mg_ptr) {
2163 case '\001': /* ^A */
2164 sv_setsv(PL_bodytarget, sv);
2166 case '\003': /* ^C */
2167 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2170 case '\004': /* ^D */
2172 s = SvPV_nolen_const(sv);
2173 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2174 DEBUG_x(dump_all());
2176 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2179 case '\005': /* ^E */
2180 if (*(mg->mg_ptr+1) == '\0') {
2181 #ifdef MACOS_TRADITIONAL
2182 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2185 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2188 SetLastError( SvIV(sv) );
2191 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2193 /* will anyone ever use this? */
2194 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2200 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2202 SvREFCNT_dec(PL_encoding);
2203 if (SvOK(sv) || SvGMAGICAL(sv)) {
2204 PL_encoding = newSVsv(sv);
2207 PL_encoding = Nullsv;
2211 case '\006': /* ^F */
2212 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2214 case '\010': /* ^H */
2215 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2217 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2219 Safefree(PL_inplace);
2221 PL_inplace = savesvpv(sv);
2223 PL_inplace = Nullch;
2225 case '\017': /* ^O */
2226 if (*(mg->mg_ptr+1) == '\0') {
2228 Safefree(PL_osname);
2232 TAINT_PROPER("assigning to $^O");
2233 PL_osname = savesvpv(sv);
2236 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2237 if (!PL_compiling.cop_io)
2238 PL_compiling.cop_io = newSVsv(sv);
2240 sv_setsv(PL_compiling.cop_io,sv);
2243 case '\020': /* ^P */
2244 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2245 if (PL_perldb && !PL_DBsingle)
2248 case '\024': /* ^T */
2250 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2252 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2255 case '\027': /* ^W & $^WARNING_BITS */
2256 if (*(mg->mg_ptr+1) == '\0') {
2257 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2258 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2259 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2260 | (i ? G_WARN_ON : G_WARN_OFF) ;
2263 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2264 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2265 if (!SvPOK(sv) && PL_localizing) {
2266 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2267 PL_compiling.cop_warnings = pWARN_NONE;
2272 int accumulate = 0 ;
2273 int any_fatals = 0 ;
2274 const char * const ptr = SvPV_const(sv, len) ;
2275 for (i = 0 ; i < len ; ++i) {
2276 accumulate |= ptr[i] ;
2277 any_fatals |= (ptr[i] & 0xAA) ;
2280 PL_compiling.cop_warnings = pWARN_NONE;
2281 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2282 PL_compiling.cop_warnings = pWARN_ALL;
2283 PL_dowarn |= G_WARN_ONCE ;
2286 if (specialWARN(PL_compiling.cop_warnings))
2287 PL_compiling.cop_warnings = newSVsv(sv) ;
2289 sv_setsv(PL_compiling.cop_warnings, sv);
2290 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2291 PL_dowarn |= G_WARN_ONCE ;
2299 if (PL_localizing) {
2300 if (PL_localizing == 1)
2301 SAVESPTR(PL_last_in_gv);
2303 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2304 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2307 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2308 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2309 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2312 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2313 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2314 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2317 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2320 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2321 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2322 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2325 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2329 IO * const io = GvIOp(PL_defoutgv);
2332 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2333 IoFLAGS(io) &= ~IOf_FLUSH;
2335 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2336 PerlIO *ofp = IoOFP(io);
2338 (void)PerlIO_flush(ofp);
2339 IoFLAGS(io) |= IOf_FLUSH;
2345 SvREFCNT_dec(PL_rs);
2346 PL_rs = newSVsv(sv);
2350 SvREFCNT_dec(PL_ors_sv);
2351 if (SvOK(sv) || SvGMAGICAL(sv)) {
2352 PL_ors_sv = newSVsv(sv);
2360 SvREFCNT_dec(PL_ofs_sv);
2361 if (SvOK(sv) || SvGMAGICAL(sv)) {
2362 PL_ofs_sv = newSVsv(sv);
2369 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2372 #ifdef COMPLEX_STATUS
2373 if (PL_localizing == 2) {
2374 PL_statusvalue = LvTARGOFF(sv);
2375 PL_statusvalue_vms = LvTARGLEN(sv);
2379 #ifdef VMSISH_STATUS
2381 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2384 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2389 # define PERL_VMS_BANG vaxc$errno
2391 # define PERL_VMS_BANG 0
2393 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2394 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2398 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2399 if (PL_delaymagic) {
2400 PL_delaymagic |= DM_RUID;
2401 break; /* don't do magic till later */
2404 (void)setruid((Uid_t)PL_uid);
2407 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2409 #ifdef HAS_SETRESUID
2410 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2412 if (PL_uid == PL_euid) { /* special case $< = $> */
2414 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2415 if (PL_uid != 0 && PerlProc_getuid() == 0)
2416 (void)PerlProc_setuid(0);
2418 (void)PerlProc_setuid(PL_uid);
2420 PL_uid = PerlProc_getuid();
2421 Perl_croak(aTHX_ "setruid() not implemented");
2426 PL_uid = PerlProc_getuid();
2427 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2430 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2431 if (PL_delaymagic) {
2432 PL_delaymagic |= DM_EUID;
2433 break; /* don't do magic till later */
2436 (void)seteuid((Uid_t)PL_euid);
2439 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2441 #ifdef HAS_SETRESUID
2442 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2444 if (PL_euid == PL_uid) /* special case $> = $< */
2445 PerlProc_setuid(PL_euid);
2447 PL_euid = PerlProc_geteuid();
2448 Perl_croak(aTHX_ "seteuid() not implemented");
2453 PL_euid = PerlProc_geteuid();
2454 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2457 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2458 if (PL_delaymagic) {
2459 PL_delaymagic |= DM_RGID;
2460 break; /* don't do magic till later */
2463 (void)setrgid((Gid_t)PL_gid);
2466 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2468 #ifdef HAS_SETRESGID
2469 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2471 if (PL_gid == PL_egid) /* special case $( = $) */
2472 (void)PerlProc_setgid(PL_gid);
2474 PL_gid = PerlProc_getgid();
2475 Perl_croak(aTHX_ "setrgid() not implemented");
2480 PL_gid = PerlProc_getgid();
2481 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2484 #ifdef HAS_SETGROUPS
2486 const char *p = SvPV_const(sv, len);
2487 Groups_t gary[NGROUPS];
2492 for (i = 0; i < NGROUPS; ++i) {
2493 while (*p && !isSPACE(*p))
2502 (void)setgroups(i, gary);
2504 #else /* HAS_SETGROUPS */
2505 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2506 #endif /* HAS_SETGROUPS */
2507 if (PL_delaymagic) {
2508 PL_delaymagic |= DM_EGID;
2509 break; /* don't do magic till later */
2512 (void)setegid((Gid_t)PL_egid);
2515 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2517 #ifdef HAS_SETRESGID
2518 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2520 if (PL_egid == PL_gid) /* special case $) = $( */
2521 (void)PerlProc_setgid(PL_egid);
2523 PL_egid = PerlProc_getegid();
2524 Perl_croak(aTHX_ "setegid() not implemented");
2529 PL_egid = PerlProc_getegid();
2530 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2533 PL_chopset = SvPV_force(sv,len);
2535 #ifndef MACOS_TRADITIONAL
2537 LOCK_DOLLARZERO_MUTEX;
2538 #ifdef HAS_SETPROCTITLE
2539 /* The BSDs don't show the argv[] in ps(1) output, they
2540 * show a string from the process struct and provide
2541 * the setproctitle() routine to manipulate that. */
2543 s = SvPV_const(sv, len);
2544 # if __FreeBSD_version > 410001
2545 /* The leading "-" removes the "perl: " prefix,
2546 * but not the "(perl) suffix from the ps(1)
2547 * output, because that's what ps(1) shows if the
2548 * argv[] is modified. */
2549 setproctitle("-%s", s);
2550 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2551 /* This doesn't really work if you assume that
2552 * $0 = 'foobar'; will wipe out 'perl' from the $0
2553 * because in ps(1) output the result will be like
2554 * sprintf("perl: %s (perl)", s)
2555 * I guess this is a security feature:
2556 * one (a user process) cannot get rid of the original name.
2558 setproctitle("%s", s);
2562 #if defined(__hpux) && defined(PSTAT_SETCMD)
2565 s = SvPV_const(sv, len);
2566 un.pst_command = (char *)s;
2567 pstat(PSTAT_SETCMD, un, len, 0, 0);
2570 /* PL_origalen is set in perl_parse(). */
2571 s = SvPV_force(sv,len);
2572 if (len >= (STRLEN)PL_origalen-1) {
2573 /* Longer than original, will be truncated. We assume that
2574 * PL_origalen bytes are available. */
2575 Copy(s, PL_origargv[0], PL_origalen-1, char);
2578 /* Shorter than original, will be padded. */
2579 Copy(s, PL_origargv[0], len, char);
2580 PL_origargv[0][len] = 0;
2581 memset(PL_origargv[0] + len + 1,
2582 /* Is the space counterintuitive? Yes.
2583 * (You were expecting \0?)
2584 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2587 PL_origalen - len - 1);
2589 PL_origargv[0][PL_origalen-1] = 0;
2590 for (i = 1; i < PL_origargc; i++)
2592 UNLOCK_DOLLARZERO_MUTEX;
2600 Perl_whichsig(pTHX_ const char *sig)
2602 register char* const* sigv;
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 Perl_sighandler(int sig)
2621 #ifdef PERL_GET_SIG_CONTEXT
2622 dTHXa(PERL_GET_SIG_CONTEXT);
2629 SV * const tSv = PL_Sv;
2633 XPV * const tXpv = PL_Xpv;
2635 if (PL_savestack_ix + 15 <= PL_savestack_max)
2637 if (PL_markstack_ptr < PL_markstack_max - 2)
2639 if (PL_scopestack_ix < PL_scopestack_max - 3)
2642 if (!PL_psig_ptr[sig]) {
2643 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2648 /* Max number of items pushed there is 3*n or 4. We cannot fix
2649 infinity, so we fix 4 (in fact 5): */
2651 PL_savestack_ix += 5; /* Protect save in progress. */
2652 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2655 PL_markstack_ptr++; /* Protect mark. */
2657 PL_scopestack_ix += 1;
2658 /* sv_2cv is too complicated, try a simpler variant first: */
2659 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2660 || SvTYPE(cv) != SVt_PVCV) {
2662 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2665 if (!cv || !CvROOT(cv)) {
2666 if (ckWARN(WARN_SIGNAL))
2667 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2668 PL_sig_name[sig], (gv ? GvENAME(gv)
2675 if(PL_psig_name[sig]) {
2676 sv = SvREFCNT_inc(PL_psig_name[sig]);
2678 #if !defined(PERL_IMPLICIT_CONTEXT)
2682 sv = sv_newmortal();
2683 sv_setpv(sv,PL_sig_name[sig]);
2686 PUSHSTACKi(PERLSI_SIGNAL);
2691 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2694 if (SvTRUE(ERRSV)) {
2696 #ifdef HAS_SIGPROCMASK
2697 /* Handler "died", for example to get out of a restart-able read().
2698 * Before we re-do that on its behalf re-enable the signal which was
2699 * blocked by the system when we entered.
2703 sigaddset(&set,sig);
2704 sigprocmask(SIG_UNBLOCK, &set, NULL);
2706 /* Not clear if this will work */
2707 (void)rsignal(sig, SIG_IGN);
2708 (void)rsignal(sig, PL_csighandlerp);
2710 #endif /* !PERL_MICRO */
2715 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2719 PL_scopestack_ix -= 1;
2722 PL_op = myop; /* Apparently not needed... */
2724 PL_Sv = tSv; /* Restore global temporaries. */
2731 S_restore_magic(pTHX_ const void *p)
2733 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2734 SV* const sv = mgs->mgs_sv;
2739 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2741 #ifdef PERL_OLD_COPY_ON_WRITE
2742 /* While magic was saved (and off) sv_setsv may well have seen
2743 this SV as a prime candidate for COW. */
2745 sv_force_normal(sv);
2749 SvFLAGS(sv) |= mgs->mgs_flags;
2753 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2756 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2758 /* If we're still on top of the stack, pop us off. (That condition
2759 * will be satisfied if restore_magic was called explicitly, but *not*
2760 * if it's being called via leave_scope.)
2761 * The reason for doing this is that otherwise, things like sv_2cv()
2762 * may leave alloc gunk on the savestack, and some code
2763 * (e.g. sighandler) doesn't expect that...
2765 if (PL_savestack_ix == mgs->mgs_ss_ix)
2767 I32 popval = SSPOPINT;
2768 assert(popval == SAVEt_DESTRUCTOR_X);
2769 PL_savestack_ix -= 2;
2771 assert(popval == SAVEt_ALLOC);
2773 PL_savestack_ix -= popval;
2779 S_unwind_handler_stack(pTHX_ const void *p)
2782 const U32 flags = *(const U32*)p;
2785 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2786 /* cxstack_ix-- Not needed, die already unwound it. */
2787 #if !defined(PERL_IMPLICIT_CONTEXT)
2789 SvREFCNT_dec(PL_sig_sv);
2795 * c-indentation-style: bsd
2797 * indent-tabs-mode: t
2800 * ex: set ts=8 sts=4 sw=4 noet: