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)
87 assert(SvMAGICAL(sv));
88 #ifdef PERL_OLD_COPY_ON_WRITE
89 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
91 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_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)
118 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
119 const MGVTBL* const vtbl = mg->mg_virtual;
121 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
125 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
134 Do magic after a value is retrieved from the SV. See C<sv_magic>.
140 Perl_mg_get(pTHX_ SV *sv)
142 const I32 mgs_ix = SSNEW(sizeof(MGS));
143 const bool was_temp = (bool)SvTEMP(sv);
145 MAGIC *newmg, *head, *cur, *mg;
146 /* guard against sv having being freed midway by holding a private
149 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
150 cause the SV's buffer to get stolen (and maybe other stuff).
153 sv_2mortal(SvREFCNT_inc(sv));
158 save_magic(mgs_ix, sv);
160 /* We must call svt_get(sv, mg) for each valid entry in the linked
161 list of magic. svt_get() may delete the current entry, add new
162 magic to the head of the list, or upgrade the SV. AMS 20010810 */
164 newmg = cur = head = mg = SvMAGIC(sv);
166 const MGVTBL * const vtbl = mg->mg_virtual;
168 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
169 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
171 /* guard against magic having been deleted - eg FETCH calling
176 /* Don't restore the flags for this entry if it was deleted. */
177 if (mg->mg_flags & MGf_GSKIP)
178 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
181 mg = mg->mg_moremagic;
184 /* Have we finished with the new entries we saw? Start again
185 where we left off (unless there are more new entries). */
193 /* Were any new entries added? */
194 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
201 restore_magic(INT2PTR(void *, (IV)mgs_ix));
203 if (SvREFCNT(sv) == 1) {
204 /* We hold the last reference to this SV, which implies that the
205 SV was deleted as a side effect of the routines we called. */
214 Do magic after a value is assigned to the SV. See C<sv_magic>.
220 Perl_mg_set(pTHX_ SV *sv)
222 const I32 mgs_ix = SSNEW(sizeof(MGS));
226 save_magic(mgs_ix, sv);
228 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
229 const MGVTBL* vtbl = mg->mg_virtual;
230 nextmg = mg->mg_moremagic; /* it may delete itself */
231 if (mg->mg_flags & MGf_GSKIP) {
232 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
233 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
235 if (vtbl && vtbl->svt_set)
236 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
239 restore_magic(INT2PTR(void*, (IV)mgs_ix));
244 =for apidoc mg_length
246 Report on the SV's length. See C<sv_magic>.
252 Perl_mg_length(pTHX_ SV *sv)
257 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
258 const MGVTBL * const vtbl = mg->mg_virtual;
259 if (vtbl && vtbl->svt_len) {
260 const I32 mgs_ix = SSNEW(sizeof(MGS));
261 save_magic(mgs_ix, sv);
262 /* omit MGf_GSKIP -- not changed here */
263 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
264 restore_magic(INT2PTR(void*, (IV)mgs_ix));
270 const U8 *s = (U8*)SvPV_const(sv, len);
271 len = Perl_utf8_length(aTHX_ s, s + len);
274 (void)SvPV_const(sv, len);
279 Perl_mg_size(pTHX_ SV *sv)
283 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
284 const MGVTBL* const vtbl = mg->mg_virtual;
285 if (vtbl && vtbl->svt_len) {
286 const I32 mgs_ix = SSNEW(sizeof(MGS));
288 save_magic(mgs_ix, sv);
289 /* omit MGf_GSKIP -- not changed here */
290 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
291 restore_magic(INT2PTR(void*, (IV)mgs_ix));
298 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
302 Perl_croak(aTHX_ "Size magic not implemented");
311 Clear something magical that the SV represents. See C<sv_magic>.
317 Perl_mg_clear(pTHX_ SV *sv)
319 const I32 mgs_ix = SSNEW(sizeof(MGS));
322 save_magic(mgs_ix, sv);
324 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
325 const MGVTBL* const vtbl = mg->mg_virtual;
326 /* omit GSKIP -- never set here */
328 if (vtbl && vtbl->svt_clear)
329 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
332 restore_magic(INT2PTR(void*, (IV)mgs_ix));
339 Finds the magic pointer for type matching the SV. See C<sv_magic>.
345 Perl_mg_find(pTHX_ const SV *sv, int type)
349 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
350 if (mg->mg_type == type)
360 Copies the magic from one SV to another. See C<sv_magic>.
366 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
370 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
371 const MGVTBL* const vtbl = mg->mg_virtual;
372 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
373 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
376 const char type = mg->mg_type;
379 (type == PERL_MAGIC_tied)
381 : (type == PERL_MAGIC_regdata && mg->mg_obj)
384 toLOWER(type), key, klen);
393 =for apidoc mg_localize
395 Copy some of the magic from an existing SV to new localized version of
396 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
397 doesn't (eg taint, pos).
403 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
406 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
407 const MGVTBL* const vtbl = mg->mg_virtual;
408 switch (mg->mg_type) {
409 /* value magic types: don't copy */
412 case PERL_MAGIC_regex_global:
413 case PERL_MAGIC_nkeys:
414 #ifdef USE_LOCALE_COLLATE
415 case PERL_MAGIC_collxfrm:
418 case PERL_MAGIC_taint:
420 case PERL_MAGIC_vstring:
421 case PERL_MAGIC_utf8:
422 case PERL_MAGIC_substr:
423 case PERL_MAGIC_defelem:
424 case PERL_MAGIC_arylen:
426 case PERL_MAGIC_backref:
427 case PERL_MAGIC_arylen_p:
428 case PERL_MAGIC_rhash:
429 case PERL_MAGIC_symtab:
433 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
434 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
436 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
437 mg->mg_ptr, mg->mg_len);
439 /* container types should remain read-only across localization */
440 SvFLAGS(nsv) |= SvREADONLY(sv);
443 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
444 SvFLAGS(nsv) |= SvMAGICAL(sv);
454 Free any magic storage used by the SV. See C<sv_magic>.
460 Perl_mg_free(pTHX_ SV *sv)
464 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
465 const MGVTBL* const vtbl = mg->mg_virtual;
466 moremagic = mg->mg_moremagic;
467 if (vtbl && vtbl->svt_free)
468 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
469 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
470 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
471 Safefree(mg->mg_ptr);
472 else if (mg->mg_len == HEf_SVKEY)
473 SvREFCNT_dec((SV*)mg->mg_ptr);
475 if (mg->mg_flags & MGf_REFCOUNTED)
476 SvREFCNT_dec(mg->mg_obj);
479 SvMAGIC_set(sv, NULL);
486 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
491 register const REGEXP * const rx = PM_GETRE(PL_curpm);
494 ? rx->nparens /* @+ */
495 : rx->lastparen; /* @- */
503 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
506 register const REGEXP * const rx = PM_GETRE(PL_curpm);
508 register const I32 paren = mg->mg_len;
513 if (paren <= (I32)rx->nparens &&
514 (s = rx->startp[paren]) != -1 &&
515 (t = rx->endp[paren]) != -1)
518 if (mg->mg_obj) /* @+ */
523 if (i > 0 && RX_MATCH_UTF8(rx)) {
524 const char * const b = rx->subbeg;
526 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
537 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
539 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
540 Perl_croak(aTHX_ PL_no_modify);
541 NORETURN_FUNCTION_END;
545 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
549 register const REGEXP *rx;
552 switch (*mg->mg_ptr) {
553 case '1': case '2': case '3': case '4':
554 case '5': case '6': case '7': case '8': case '9': case '&':
555 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
557 paren = atoi(mg->mg_ptr); /* $& is in [0] */
559 if (paren <= (I32)rx->nparens &&
560 (s1 = rx->startp[paren]) != -1 &&
561 (t1 = rx->endp[paren]) != -1)
565 if (i > 0 && RX_MATCH_UTF8(rx)) {
566 const char * const s = rx->subbeg + s1;
571 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
575 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
579 if (ckWARN(WARN_UNINITIALIZED))
584 if (ckWARN(WARN_UNINITIALIZED))
589 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
590 paren = rx->lastparen;
595 case '\016': /* ^N */
596 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
597 paren = rx->lastcloseparen;
603 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
604 if (rx->startp[0] != -1) {
615 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
616 if (rx->endp[0] != -1) {
617 i = rx->sublen - rx->endp[0];
628 if (!SvPOK(sv) && SvNIOK(sv)) {
636 #define SvRTRIM(sv) STMT_START { \
637 STRLEN len = SvCUR(sv); \
638 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
640 SvCUR_set(sv, len); \
644 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
648 register char *s = NULL;
651 const char * const remaining = mg->mg_ptr + 1;
652 const char nextchar = *remaining;
654 switch (*mg->mg_ptr) {
655 case '\001': /* ^A */
656 sv_setsv(sv, PL_bodytarget);
658 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
659 if (nextchar == '\0') {
660 sv_setiv(sv, (IV)PL_minus_c);
662 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
663 sv_setiv(sv, (IV)STATUS_NATIVE);
667 case '\004': /* ^D */
668 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
670 case '\005': /* ^E */
671 if (nextchar == '\0') {
672 #ifdef MACOS_TRADITIONAL
676 sv_setnv(sv,(double)gMacPerl_OSErr);
677 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
682 # include <descrip.h>
683 # include <starlet.h>
685 $DESCRIPTOR(msgdsc,msg);
686 sv_setnv(sv,(NV) vaxc$errno);
687 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
688 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
694 if (!(_emx_env & 0x200)) { /* Under DOS */
695 sv_setnv(sv, (NV)errno);
696 sv_setpv(sv, errno ? Strerror(errno) : "");
698 if (errno != errno_isOS2) {
699 const int tmp = _syserrno();
700 if (tmp) /* 2nd call to _syserrno() makes it 0 */
703 sv_setnv(sv, (NV)Perl_rc);
704 sv_setpv(sv, os2error(Perl_rc));
709 DWORD dwErr = GetLastError();
710 sv_setnv(sv, (NV)dwErr);
712 PerlProc_GetOSError(sv, dwErr);
715 sv_setpvn(sv, "", 0);
720 const int saveerrno = errno;
721 sv_setnv(sv, (NV)errno);
722 sv_setpv(sv, errno ? Strerror(errno) : "");
730 SvNOK_on(sv); /* what a wonderful hack! */
732 else if (strEQ(remaining, "NCODING"))
733 sv_setsv(sv, PL_encoding);
735 case '\006': /* ^F */
736 sv_setiv(sv, (IV)PL_maxsysfd);
738 case '\010': /* ^H */
739 sv_setiv(sv, (IV)PL_hints);
741 case '\011': /* ^I */ /* NOT \t in EBCDIC */
743 sv_setpv(sv, PL_inplace);
745 sv_setsv(sv, &PL_sv_undef);
747 case '\017': /* ^O & ^OPEN */
748 if (nextchar == '\0') {
749 sv_setpv(sv, PL_osname);
752 else if (strEQ(remaining, "PEN")) {
753 if (!PL_compiling.cop_io)
754 sv_setsv(sv, &PL_sv_undef);
756 sv_setsv(sv, PL_compiling.cop_io);
760 case '\020': /* ^P */
761 sv_setiv(sv, (IV)PL_perldb);
763 case '\023': /* ^S */
764 if (nextchar == '\0') {
765 if (PL_lex_state != LEX_NOTPARSING)
768 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
773 case '\024': /* ^T */
774 if (nextchar == '\0') {
776 sv_setnv(sv, PL_basetime);
778 sv_setiv(sv, (IV)PL_basetime);
781 else if (strEQ(remaining, "AINT"))
782 sv_setiv(sv, PL_tainting
783 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
786 case '\025': /* $^UNICODE, $^UTF8LOCALE */
787 if (strEQ(remaining, "NICODE"))
788 sv_setuv(sv, (UV) PL_unicode);
789 else if (strEQ(remaining, "TF8LOCALE"))
790 sv_setuv(sv, (UV) PL_utf8locale);
792 case '\027': /* ^W & $^WARNING_BITS */
793 if (nextchar == '\0')
794 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
795 else if (strEQ(remaining, "ARNING_BITS")) {
796 if (PL_compiling.cop_warnings == pWARN_NONE) {
797 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
799 else if (PL_compiling.cop_warnings == pWARN_STD) {
802 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
806 else if (PL_compiling.cop_warnings == pWARN_ALL) {
807 /* Get the bit mask for $warnings::Bits{all}, because
808 * it could have been extended by warnings::register */
810 HV * const bits=get_hv("warnings::Bits", FALSE);
811 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
812 sv_setsv(sv, *bits_all);
815 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
819 sv_setsv(sv, PL_compiling.cop_warnings);
824 case '1': case '2': case '3': case '4':
825 case '5': case '6': case '7': case '8': case '9': case '&':
826 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
830 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
831 * XXX Does the new way break anything?
833 paren = atoi(mg->mg_ptr); /* $& is in [0] */
835 if (paren <= (I32)rx->nparens &&
836 (s1 = rx->startp[paren]) != -1 &&
837 (t1 = rx->endp[paren]) != -1)
846 const int oldtainted = PL_tainted;
849 PL_tainted = oldtainted;
850 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
855 if (RX_MATCH_TAINTED(rx)) {
856 MAGIC* const mg = SvMAGIC(sv);
859 SvMAGIC_set(sv, mg->mg_moremagic);
861 if ((mgt = SvMAGIC(sv))) {
862 mg->mg_moremagic = mgt;
872 sv_setsv(sv,&PL_sv_undef);
875 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
876 paren = rx->lastparen;
880 sv_setsv(sv,&PL_sv_undef);
882 case '\016': /* ^N */
883 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
884 paren = rx->lastcloseparen;
888 sv_setsv(sv,&PL_sv_undef);
891 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
892 if ((s = rx->subbeg) && rx->startp[0] != -1) {
897 sv_setsv(sv,&PL_sv_undef);
900 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
901 if (rx->subbeg && rx->endp[0] != -1) {
902 s = rx->subbeg + rx->endp[0];
903 i = rx->sublen - rx->endp[0];
907 sv_setsv(sv,&PL_sv_undef);
910 if (GvIO(PL_last_in_gv)) {
911 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
916 sv_setiv(sv, (IV)STATUS_CURRENT);
917 #ifdef COMPLEX_STATUS
918 LvTARGOFF(sv) = PL_statusvalue;
919 LvTARGLEN(sv) = PL_statusvalue_vms;
924 if (GvIOp(PL_defoutgv))
925 s = IoTOP_NAME(GvIOp(PL_defoutgv));
929 sv_setpv(sv,GvENAME(PL_defoutgv));
934 if (GvIOp(PL_defoutgv))
935 s = IoFMT_NAME(GvIOp(PL_defoutgv));
937 s = GvENAME(PL_defoutgv);
941 if (GvIOp(PL_defoutgv))
942 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
945 if (GvIOp(PL_defoutgv))
946 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
949 if (GvIOp(PL_defoutgv))
950 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
957 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
960 if (GvIOp(PL_defoutgv))
961 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
967 sv_copypv(sv, PL_ors_sv);
971 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
972 sv_setpv(sv, errno ? Strerror(errno) : "");
975 const int saveerrno = errno;
976 sv_setnv(sv, (NV)errno);
978 if (errno == errno_isOS2 || errno == errno_isOS2_set)
979 sv_setpv(sv, os2error(Perl_rc));
982 sv_setpv(sv, errno ? Strerror(errno) : "");
987 SvNOK_on(sv); /* what a wonderful hack! */
990 sv_setiv(sv, (IV)PL_uid);
993 sv_setiv(sv, (IV)PL_euid);
996 sv_setiv(sv, (IV)PL_gid);
998 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1002 sv_setiv(sv, (IV)PL_egid);
1003 #ifdef HAS_GETGROUPS
1004 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1007 #ifdef HAS_GETGROUPS
1009 Groups_t *gary = NULL;
1010 I32 num_groups = getgroups(0, gary);
1011 Newx(gary, num_groups, Groups_t);
1012 num_groups = getgroups(num_groups, gary);
1013 while (--num_groups >= 0)
1014 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1015 (long unsigned int)gary[num_groups]);
1019 (void)SvIOK_on(sv); /* what a wonderful hack! */
1021 #ifndef MACOS_TRADITIONAL
1030 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1032 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1034 if (uf && uf->uf_val)
1035 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1040 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1044 const char *s = SvPV_const(sv,len);
1045 const char * const ptr = MgPV_const(mg,klen);
1048 #ifdef DYNAMIC_ENV_FETCH
1049 /* We just undefd an environment var. Is a replacement */
1050 /* waiting in the wings? */
1052 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1054 s = SvPV_const(*valp, len);
1058 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1059 /* And you'll never guess what the dog had */
1060 /* in its mouth... */
1062 MgTAINTEDDIR_off(mg);
1064 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1065 char pathbuf[256], eltbuf[256], *cp, *elt;
1069 strncpy(eltbuf, s, 255);
1072 do { /* DCL$PATH may be a search list */
1073 while (1) { /* as may dev portion of any element */
1074 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1075 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1076 cando_by_name(S_IWUSR,0,elt) ) {
1077 MgTAINTEDDIR_on(mg);
1081 if ((cp = strchr(elt, ':')) != Nullch)
1083 if (my_trnlnm(elt, eltbuf, j++))
1089 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1092 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1093 const char * const strend = s + len;
1095 while (s < strend) {
1099 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1100 s, strend, ':', &i);
1102 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1104 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1105 MgTAINTEDDIR_on(mg);
1111 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1117 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1119 PERL_UNUSED_ARG(sv);
1120 my_setenv(MgPV_nolen_const(mg),Nullch);
1125 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1127 PERL_UNUSED_ARG(mg);
1129 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1131 if (PL_localizing) {
1134 hv_iterinit((HV*)sv);
1135 while ((entry = hv_iternext((HV*)sv))) {
1137 my_setenv(hv_iterkey(entry, &keylen),
1138 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1146 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1149 PERL_UNUSED_ARG(sv);
1150 PERL_UNUSED_ARG(mg);
1152 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1160 #ifdef HAS_SIGPROCMASK
1162 restore_sigmask(pTHX_ SV *save_sv)
1164 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1165 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1169 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1171 /* Are we fetching a signal entry? */
1172 const I32 i = whichsig(MgPV_nolen_const(mg));
1175 sv_setsv(sv,PL_psig_ptr[i]);
1177 Sighandler_t sigstate;
1178 sigstate = rsignal_state(i);
1179 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1180 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1182 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1185 /* cache state so we don't fetch it again */
1186 if(sigstate == (Sighandler_t) SIG_IGN)
1187 sv_setpv(sv,"IGNORE");
1189 sv_setsv(sv,&PL_sv_undef);
1190 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1197 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1199 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1200 * refactoring might be in order.
1203 register const char * const s = MgPV_nolen_const(mg);
1204 PERL_UNUSED_ARG(sv);
1207 if (strEQ(s,"__DIE__"))
1209 else if (strEQ(s,"__WARN__"))
1212 Perl_croak(aTHX_ "No such hook: %s", s);
1214 SV * const to_dec = *svp;
1216 SvREFCNT_dec(to_dec);
1220 /* Are we clearing a signal entry? */
1221 const I32 i = whichsig(s);
1223 #ifdef HAS_SIGPROCMASK
1226 /* Avoid having the signal arrive at a bad time, if possible. */
1229 sigprocmask(SIG_BLOCK, &set, &save);
1231 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1232 SAVEFREESV(save_sv);
1233 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1236 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1237 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1239 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1240 PL_sig_defaulting[i] = 1;
1241 (void)rsignal(i, PL_csighandlerp);
1243 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1245 if(PL_psig_name[i]) {
1246 SvREFCNT_dec(PL_psig_name[i]);
1249 if(PL_psig_ptr[i]) {
1250 SV *to_dec=PL_psig_ptr[i];
1253 SvREFCNT_dec(to_dec);
1263 S_raise_signal(pTHX_ int sig)
1265 /* Set a flag to say this signal is pending */
1266 PL_psig_pend[sig]++;
1267 /* And one to say _a_ signal is pending */
1272 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1273 Perl_csighandler(int sig, ...)
1275 Perl_csighandler(int sig)
1278 #ifdef PERL_GET_SIG_CONTEXT
1279 dTHXa(PERL_GET_SIG_CONTEXT);
1283 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1284 (void) rsignal(sig, PL_csighandlerp);
1285 if (PL_sig_ignoring[sig]) return;
1287 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1288 if (PL_sig_defaulting[sig])
1289 #ifdef KILL_BY_SIGPRC
1290 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1295 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1296 /* Call the perl level handler now--
1297 * with risk we may be in malloc() etc. */
1298 (*PL_sighandlerp)(sig);
1300 S_raise_signal(aTHX_ sig);
1303 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1305 Perl_csighandler_init(void)
1308 if (PL_sig_handlers_initted) return;
1310 for (sig = 1; sig < SIG_SIZE; sig++) {
1311 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313 PL_sig_defaulting[sig] = 1;
1314 (void) rsignal(sig, PL_csighandlerp);
1316 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1317 PL_sig_ignoring[sig] = 0;
1320 PL_sig_handlers_initted = 1;
1325 Perl_despatch_signals(pTHX)
1329 for (sig = 1; sig < SIG_SIZE; sig++) {
1330 if (PL_psig_pend[sig]) {
1331 PERL_BLOCKSIG_ADD(set, sig);
1332 PL_psig_pend[sig] = 0;
1333 PERL_BLOCKSIG_BLOCK(set);
1334 (*PL_sighandlerp)(sig);
1335 PERL_BLOCKSIG_UNBLOCK(set);
1341 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1346 /* Need to be careful with SvREFCNT_dec(), because that can have side
1347 * effects (due to closures). We must make sure that the new disposition
1348 * is in place before it is called.
1352 #ifdef HAS_SIGPROCMASK
1357 register const char *s = MgPV_const(mg,len);
1359 if (strEQ(s,"__DIE__"))
1361 else if (strEQ(s,"__WARN__"))
1364 Perl_croak(aTHX_ "No such hook: %s", s);
1372 i = whichsig(s); /* ...no, a brick */
1374 if (ckWARN(WARN_SIGNAL))
1375 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1378 #ifdef HAS_SIGPROCMASK
1379 /* Avoid having the signal arrive at a bad time, if possible. */
1382 sigprocmask(SIG_BLOCK, &set, &save);
1384 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1385 SAVEFREESV(save_sv);
1386 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1389 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1390 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1392 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1393 PL_sig_ignoring[i] = 0;
1395 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1396 PL_sig_defaulting[i] = 0;
1398 SvREFCNT_dec(PL_psig_name[i]);
1399 to_dec = PL_psig_ptr[i];
1400 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1401 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1402 PL_psig_name[i] = newSVpvn(s, len);
1403 SvREADONLY_on(PL_psig_name[i]);
1405 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1407 (void)rsignal(i, PL_csighandlerp);
1408 #ifdef HAS_SIGPROCMASK
1413 *svp = SvREFCNT_inc(sv);
1415 SvREFCNT_dec(to_dec);
1418 s = SvPV_force(sv,len);
1419 if (strEQ(s,"IGNORE")) {
1421 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1422 PL_sig_ignoring[i] = 1;
1423 (void)rsignal(i, PL_csighandlerp);
1425 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1429 else if (strEQ(s,"DEFAULT") || !*s) {
1431 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1433 PL_sig_defaulting[i] = 1;
1434 (void)rsignal(i, PL_csighandlerp);
1437 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1442 * We should warn if HINT_STRICT_REFS, but without
1443 * access to a known hint bit in a known OP, we can't
1444 * tell whether HINT_STRICT_REFS is in force or not.
1446 if (!strchr(s,':') && !strchr(s,'\''))
1447 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1449 (void)rsignal(i, PL_csighandlerp);
1451 *svp = SvREFCNT_inc(sv);
1453 #ifdef HAS_SIGPROCMASK
1458 SvREFCNT_dec(to_dec);
1461 #endif /* !PERL_MICRO */
1464 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1466 PERL_UNUSED_ARG(sv);
1467 PERL_UNUSED_ARG(mg);
1468 PL_sub_generation++;
1473 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1475 PERL_UNUSED_ARG(sv);
1476 PERL_UNUSED_ARG(mg);
1477 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1478 PL_amagic_generation++;
1484 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1486 HV * const hv = (HV*)LvTARG(sv);
1488 PERL_UNUSED_ARG(mg);
1491 (void) hv_iterinit(hv);
1492 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1495 while (hv_iternext(hv))
1500 sv_setiv(sv, (IV)i);
1505 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1507 PERL_UNUSED_ARG(mg);
1509 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1514 /* caller is responsible for stack switching/cleanup */
1516 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1522 PUSHs(SvTIED_obj(sv, mg));
1525 if (mg->mg_len >= 0)
1526 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1527 else if (mg->mg_len == HEf_SVKEY)
1528 PUSHs((SV*)mg->mg_ptr);
1530 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1531 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1539 return call_method(meth, flags);
1543 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1549 PUSHSTACKi(PERLSI_MAGIC);
1551 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1552 sv_setsv(sv, *PL_stack_sp--);
1562 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1565 mg->mg_flags |= MGf_GSKIP;
1566 magic_methpack(sv,mg,"FETCH");
1571 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1575 PUSHSTACKi(PERLSI_MAGIC);
1576 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1583 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1585 return magic_methpack(sv,mg,"DELETE");
1590 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1597 PUSHSTACKi(PERLSI_MAGIC);
1598 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1599 sv = *PL_stack_sp--;
1600 retval = (U32) SvIV(sv)-1;
1609 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1614 PUSHSTACKi(PERLSI_MAGIC);
1616 XPUSHs(SvTIED_obj(sv, mg));
1618 call_method("CLEAR", G_SCALAR|G_DISCARD);
1626 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1629 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1633 PUSHSTACKi(PERLSI_MAGIC);
1636 PUSHs(SvTIED_obj(sv, mg));
1641 if (call_method(meth, G_SCALAR))
1642 sv_setsv(key, *PL_stack_sp--);
1651 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1653 return magic_methpack(sv,mg,"EXISTS");
1657 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1660 SV *retval = &PL_sv_undef;
1661 SV * const tied = SvTIED_obj((SV*)hv, mg);
1662 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1664 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1666 if (HvEITER_get(hv))
1667 /* we are in an iteration so the hash cannot be empty */
1669 /* no xhv_eiter so now use FIRSTKEY */
1670 key = sv_newmortal();
1671 magic_nextpack((SV*)hv, mg, key);
1672 HvEITER_set(hv, NULL); /* need to reset iterator */
1673 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1676 /* there is a SCALAR method that we can call */
1678 PUSHSTACKi(PERLSI_MAGIC);
1684 if (call_method("SCALAR", G_SCALAR))
1685 retval = *PL_stack_sp--;
1692 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1694 GV * const gv = PL_DBline;
1695 const I32 i = SvTRUE(sv);
1696 SV ** const svp = av_fetch(GvAV(gv),
1697 atoi(MgPV_nolen_const(mg)), FALSE);
1698 if (svp && SvIOKp(*svp)) {
1699 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1701 /* set or clear breakpoint in the relevant control op */
1703 o->op_flags |= OPf_SPECIAL;
1705 o->op_flags &= ~OPf_SPECIAL;
1712 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1714 const AV * const obj = (AV*)mg->mg_obj;
1716 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1724 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1726 AV * const obj = (AV*)mg->mg_obj;
1728 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1730 if (ckWARN(WARN_MISC))
1731 Perl_warner(aTHX_ packWARN(WARN_MISC),
1732 "Attempt to set length of freed array");
1738 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1740 PERL_UNUSED_ARG(sv);
1741 /* during global destruction, mg_obj may already have been freed */
1742 if (PL_in_clean_all)
1745 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1748 /* arylen scalar holds a pointer back to the array, but doesn't own a
1749 reference. Hence the we (the array) are about to go away with it
1750 still pointing at us. Clear its pointer, else it would be pointing
1751 at free memory. See the comment in sv_magic about reference loops,
1752 and why it can't own a reference to us. */
1759 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1761 SV* const lsv = LvTARG(sv);
1763 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1764 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1765 if (mg && mg->mg_len >= 0) {
1768 sv_pos_b2u(lsv, &i);
1769 sv_setiv(sv, i + PL_curcop->cop_arybase);
1778 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1780 SV* const lsv = LvTARG(sv);
1787 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1788 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1792 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1793 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1795 else if (!SvOK(sv)) {
1799 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1801 pos = SvIV(sv) - PL_curcop->cop_arybase;
1804 ulen = sv_len_utf8(lsv);
1814 else if (pos > (SSize_t)len)
1819 sv_pos_u2b(lsv, &p, 0);
1824 mg->mg_flags &= ~MGf_MINMATCH;
1830 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1832 PERL_UNUSED_ARG(mg);
1833 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1835 gv_efullname3(sv,((GV*)sv), "*");
1839 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1844 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1847 PERL_UNUSED_ARG(mg);
1851 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1856 GvGP(sv) = gp_ref(GvGP(gv));
1861 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1864 SV * const lsv = LvTARG(sv);
1865 const char * const tmps = SvPV_const(lsv,len);
1866 I32 offs = LvTARGOFF(sv);
1867 I32 rem = LvTARGLEN(sv);
1868 PERL_UNUSED_ARG(mg);
1871 sv_pos_u2b(lsv, &offs, &rem);
1872 if (offs > (I32)len)
1874 if (rem + offs > (I32)len)
1876 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1883 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1886 const char *tmps = SvPV_const(sv, len);
1887 SV * const lsv = LvTARG(sv);
1888 I32 lvoff = LvTARGOFF(sv);
1889 I32 lvlen = LvTARGLEN(sv);
1890 PERL_UNUSED_ARG(mg);
1893 sv_utf8_upgrade(lsv);
1894 sv_pos_u2b(lsv, &lvoff, &lvlen);
1895 sv_insert(lsv, lvoff, lvlen, tmps, len);
1896 LvTARGLEN(sv) = sv_len_utf8(sv);
1899 else if (lsv && SvUTF8(lsv)) {
1900 sv_pos_u2b(lsv, &lvoff, &lvlen);
1901 LvTARGLEN(sv) = len;
1902 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1903 sv_insert(lsv, lvoff, lvlen, tmps, len);
1907 sv_insert(lsv, lvoff, lvlen, tmps, len);
1908 LvTARGLEN(sv) = len;
1916 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1918 PERL_UNUSED_ARG(sv);
1919 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1924 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1926 PERL_UNUSED_ARG(sv);
1927 /* update taint status unless we're restoring at scope exit */
1928 if (PL_localizing != 2) {
1938 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1940 SV * const lsv = LvTARG(sv);
1941 PERL_UNUSED_ARG(mg);
1948 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1953 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1955 PERL_UNUSED_ARG(mg);
1956 do_vecset(sv); /* XXX slurp this routine */
1961 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1964 if (LvTARGLEN(sv)) {
1966 SV * const ahv = LvTARG(sv);
1967 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1972 AV* const av = (AV*)LvTARG(sv);
1973 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1974 targ = AvARRAY(av)[LvTARGOFF(sv)];
1976 if (targ && targ != &PL_sv_undef) {
1977 /* somebody else defined it for us */
1978 SvREFCNT_dec(LvTARG(sv));
1979 LvTARG(sv) = SvREFCNT_inc(targ);
1981 SvREFCNT_dec(mg->mg_obj);
1982 mg->mg_obj = Nullsv;
1983 mg->mg_flags &= ~MGf_REFCOUNTED;
1988 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1993 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1995 PERL_UNUSED_ARG(mg);
1999 sv_setsv(LvTARG(sv), sv);
2000 SvSETMAGIC(LvTARG(sv));
2006 Perl_vivify_defelem(pTHX_ SV *sv)
2011 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2014 SV * const ahv = LvTARG(sv);
2015 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2018 if (!value || value == &PL_sv_undef)
2019 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2022 AV* const av = (AV*)LvTARG(sv);
2023 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2024 LvTARG(sv) = Nullsv; /* array can't be extended */
2026 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2027 if (!svp || (value = *svp) == &PL_sv_undef)
2028 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2031 (void)SvREFCNT_inc(value);
2032 SvREFCNT_dec(LvTARG(sv));
2035 SvREFCNT_dec(mg->mg_obj);
2036 mg->mg_obj = Nullsv;
2037 mg->mg_flags &= ~MGf_REFCOUNTED;
2041 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2043 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2047 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2055 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2057 PERL_UNUSED_ARG(mg);
2058 sv_unmagic(sv, PERL_MAGIC_bm);
2064 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2066 PERL_UNUSED_ARG(mg);
2067 sv_unmagic(sv, PERL_MAGIC_fm);
2073 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2075 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2077 if (uf && uf->uf_set)
2078 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2083 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2085 PERL_UNUSED_ARG(mg);
2086 sv_unmagic(sv, PERL_MAGIC_qr);
2091 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2093 regexp * const re = (regexp *)mg->mg_obj;
2094 PERL_UNUSED_ARG(sv);
2100 #ifdef USE_LOCALE_COLLATE
2102 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2105 * RenE<eacute> Descartes said "I think not."
2106 * and vanished with a faint plop.
2108 PERL_UNUSED_ARG(sv);
2110 Safefree(mg->mg_ptr);
2116 #endif /* USE_LOCALE_COLLATE */
2118 /* Just clear the UTF-8 cache data. */
2120 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2122 PERL_UNUSED_ARG(sv);
2123 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2125 mg->mg_len = -1; /* The mg_len holds the len cache. */
2130 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2132 register const char *s;
2135 switch (*mg->mg_ptr) {
2136 case '\001': /* ^A */
2137 sv_setsv(PL_bodytarget, sv);
2139 case '\003': /* ^C */
2140 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2143 case '\004': /* ^D */
2145 s = SvPV_nolen_const(sv);
2146 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2147 DEBUG_x(dump_all());
2149 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2152 case '\005': /* ^E */
2153 if (*(mg->mg_ptr+1) == '\0') {
2154 #ifdef MACOS_TRADITIONAL
2155 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2158 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2161 SetLastError( SvIV(sv) );
2164 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2166 /* will anyone ever use this? */
2167 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2173 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2175 SvREFCNT_dec(PL_encoding);
2176 if (SvOK(sv) || SvGMAGICAL(sv)) {
2177 PL_encoding = newSVsv(sv);
2180 PL_encoding = Nullsv;
2184 case '\006': /* ^F */
2185 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2187 case '\010': /* ^H */
2188 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2190 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2191 Safefree(PL_inplace);
2192 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2194 case '\017': /* ^O */
2195 if (*(mg->mg_ptr+1) == '\0') {
2196 Safefree(PL_osname);
2199 TAINT_PROPER("assigning to $^O");
2200 PL_osname = savesvpv(sv);
2203 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2204 if (!PL_compiling.cop_io)
2205 PL_compiling.cop_io = newSVsv(sv);
2207 sv_setsv(PL_compiling.cop_io,sv);
2210 case '\020': /* ^P */
2211 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2212 if (PL_perldb && !PL_DBsingle)
2215 case '\024': /* ^T */
2217 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2219 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2222 case '\027': /* ^W & $^WARNING_BITS */
2223 if (*(mg->mg_ptr+1) == '\0') {
2224 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2225 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2226 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2227 | (i ? G_WARN_ON : G_WARN_OFF) ;
2230 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2231 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2232 if (!SvPOK(sv) && PL_localizing) {
2233 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2234 PL_compiling.cop_warnings = pWARN_NONE;
2239 int accumulate = 0 ;
2240 int any_fatals = 0 ;
2241 const char * const ptr = SvPV_const(sv, len) ;
2242 for (i = 0 ; i < len ; ++i) {
2243 accumulate |= ptr[i] ;
2244 any_fatals |= (ptr[i] & 0xAA) ;
2247 PL_compiling.cop_warnings = pWARN_NONE;
2248 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2249 PL_compiling.cop_warnings = pWARN_ALL;
2250 PL_dowarn |= G_WARN_ONCE ;
2253 if (specialWARN(PL_compiling.cop_warnings))
2254 PL_compiling.cop_warnings = newSVsv(sv) ;
2256 sv_setsv(PL_compiling.cop_warnings, sv);
2257 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2258 PL_dowarn |= G_WARN_ONCE ;
2266 if (PL_localizing) {
2267 if (PL_localizing == 1)
2268 SAVESPTR(PL_last_in_gv);
2270 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2271 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2274 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2275 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2276 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2279 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2280 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2281 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2284 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2287 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2288 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2289 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2292 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2296 IO * const io = GvIOp(PL_defoutgv);
2299 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2300 IoFLAGS(io) &= ~IOf_FLUSH;
2302 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2303 PerlIO *ofp = IoOFP(io);
2305 (void)PerlIO_flush(ofp);
2306 IoFLAGS(io) |= IOf_FLUSH;
2312 SvREFCNT_dec(PL_rs);
2313 PL_rs = newSVsv(sv);
2317 SvREFCNT_dec(PL_ors_sv);
2318 if (SvOK(sv) || SvGMAGICAL(sv)) {
2319 PL_ors_sv = newSVsv(sv);
2327 SvREFCNT_dec(PL_ofs_sv);
2328 if (SvOK(sv) || SvGMAGICAL(sv)) {
2329 PL_ofs_sv = newSVsv(sv);
2336 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2339 #ifdef COMPLEX_STATUS
2340 if (PL_localizing == 2) {
2341 PL_statusvalue = LvTARGOFF(sv);
2342 PL_statusvalue_vms = LvTARGLEN(sv);
2346 #ifdef VMSISH_STATUS
2348 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2351 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2356 # define PERL_VMS_BANG vaxc$errno
2358 # define PERL_VMS_BANG 0
2360 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2361 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2365 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2366 if (PL_delaymagic) {
2367 PL_delaymagic |= DM_RUID;
2368 break; /* don't do magic till later */
2371 (void)setruid((Uid_t)PL_uid);
2374 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2376 #ifdef HAS_SETRESUID
2377 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2379 if (PL_uid == PL_euid) { /* special case $< = $> */
2381 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2382 if (PL_uid != 0 && PerlProc_getuid() == 0)
2383 (void)PerlProc_setuid(0);
2385 (void)PerlProc_setuid(PL_uid);
2387 PL_uid = PerlProc_getuid();
2388 Perl_croak(aTHX_ "setruid() not implemented");
2393 PL_uid = PerlProc_getuid();
2394 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2397 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2398 if (PL_delaymagic) {
2399 PL_delaymagic |= DM_EUID;
2400 break; /* don't do magic till later */
2403 (void)seteuid((Uid_t)PL_euid);
2406 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2408 #ifdef HAS_SETRESUID
2409 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2411 if (PL_euid == PL_uid) /* special case $> = $< */
2412 PerlProc_setuid(PL_euid);
2414 PL_euid = PerlProc_geteuid();
2415 Perl_croak(aTHX_ "seteuid() not implemented");
2420 PL_euid = PerlProc_geteuid();
2421 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2424 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2425 if (PL_delaymagic) {
2426 PL_delaymagic |= DM_RGID;
2427 break; /* don't do magic till later */
2430 (void)setrgid((Gid_t)PL_gid);
2433 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2435 #ifdef HAS_SETRESGID
2436 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2438 if (PL_gid == PL_egid) /* special case $( = $) */
2439 (void)PerlProc_setgid(PL_gid);
2441 PL_gid = PerlProc_getgid();
2442 Perl_croak(aTHX_ "setrgid() not implemented");
2447 PL_gid = PerlProc_getgid();
2448 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2451 #ifdef HAS_SETGROUPS
2453 const char *p = SvPV_const(sv, len);
2454 Groups_t *gary = NULL;
2459 for (i = 0; i < NGROUPS; ++i) {
2460 while (*p && !isSPACE(*p))
2467 Newx(gary, i + 1, Groups_t);
2469 Renew(gary, i + 1, Groups_t);
2473 (void)setgroups(i, gary);
2477 #else /* HAS_SETGROUPS */
2478 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2479 #endif /* HAS_SETGROUPS */
2480 if (PL_delaymagic) {
2481 PL_delaymagic |= DM_EGID;
2482 break; /* don't do magic till later */
2485 (void)setegid((Gid_t)PL_egid);
2488 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2490 #ifdef HAS_SETRESGID
2491 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2493 if (PL_egid == PL_gid) /* special case $) = $( */
2494 (void)PerlProc_setgid(PL_egid);
2496 PL_egid = PerlProc_getegid();
2497 Perl_croak(aTHX_ "setegid() not implemented");
2502 PL_egid = PerlProc_getegid();
2503 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2506 PL_chopset = SvPV_force(sv,len);
2508 #ifndef MACOS_TRADITIONAL
2510 LOCK_DOLLARZERO_MUTEX;
2511 #ifdef HAS_SETPROCTITLE
2512 /* The BSDs don't show the argv[] in ps(1) output, they
2513 * show a string from the process struct and provide
2514 * the setproctitle() routine to manipulate that. */
2516 s = SvPV_const(sv, len);
2517 # if __FreeBSD_version > 410001
2518 /* The leading "-" removes the "perl: " prefix,
2519 * but not the "(perl) suffix from the ps(1)
2520 * output, because that's what ps(1) shows if the
2521 * argv[] is modified. */
2522 setproctitle("-%s", s);
2523 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2524 /* This doesn't really work if you assume that
2525 * $0 = 'foobar'; will wipe out 'perl' from the $0
2526 * because in ps(1) output the result will be like
2527 * sprintf("perl: %s (perl)", s)
2528 * I guess this is a security feature:
2529 * one (a user process) cannot get rid of the original name.
2531 setproctitle("%s", s);
2535 #if defined(__hpux) && defined(PSTAT_SETCMD)
2538 s = SvPV_const(sv, len);
2539 un.pst_command = (char *)s;
2540 pstat(PSTAT_SETCMD, un, len, 0, 0);
2543 /* PL_origalen is set in perl_parse(). */
2544 s = SvPV_force(sv,len);
2545 if (len >= (STRLEN)PL_origalen-1) {
2546 /* Longer than original, will be truncated. We assume that
2547 * PL_origalen bytes are available. */
2548 Copy(s, PL_origargv[0], PL_origalen-1, char);
2551 /* Shorter than original, will be padded. */
2552 Copy(s, PL_origargv[0], len, char);
2553 PL_origargv[0][len] = 0;
2554 memset(PL_origargv[0] + len + 1,
2555 /* Is the space counterintuitive? Yes.
2556 * (You were expecting \0?)
2557 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2560 PL_origalen - len - 1);
2562 PL_origargv[0][PL_origalen-1] = 0;
2563 for (i = 1; i < PL_origargc; i++)
2565 UNLOCK_DOLLARZERO_MUTEX;
2573 Perl_whichsig(pTHX_ const char *sig)
2575 register char* const* sigv;
2577 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2578 if (strEQ(sig,*sigv))
2579 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2581 if (strEQ(sig,"CHLD"))
2585 if (strEQ(sig,"CLD"))
2592 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2593 Perl_sighandler(int sig, ...)
2595 Perl_sighandler(int sig)
2598 #ifdef PERL_GET_SIG_CONTEXT
2599 dTHXa(PERL_GET_SIG_CONTEXT);
2606 SV * const tSv = PL_Sv;
2610 XPV * const tXpv = PL_Xpv;
2612 if (PL_savestack_ix + 15 <= PL_savestack_max)
2614 if (PL_markstack_ptr < PL_markstack_max - 2)
2616 if (PL_scopestack_ix < PL_scopestack_max - 3)
2619 if (!PL_psig_ptr[sig]) {
2620 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2625 /* Max number of items pushed there is 3*n or 4. We cannot fix
2626 infinity, so we fix 4 (in fact 5): */
2628 PL_savestack_ix += 5; /* Protect save in progress. */
2629 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2632 PL_markstack_ptr++; /* Protect mark. */
2634 PL_scopestack_ix += 1;
2635 /* sv_2cv is too complicated, try a simpler variant first: */
2636 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2637 || SvTYPE(cv) != SVt_PVCV) {
2639 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2642 if (!cv || !CvROOT(cv)) {
2643 if (ckWARN(WARN_SIGNAL))
2644 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2645 PL_sig_name[sig], (gv ? GvENAME(gv)
2652 if(PL_psig_name[sig]) {
2653 sv = SvREFCNT_inc(PL_psig_name[sig]);
2655 #if !defined(PERL_IMPLICIT_CONTEXT)
2659 sv = sv_newmortal();
2660 sv_setpv(sv,PL_sig_name[sig]);
2663 PUSHSTACKi(PERLSI_SIGNAL);
2666 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2668 struct sigaction oact;
2670 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2674 va_start(args, sig);
2675 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2678 SV *rv = newRV_noinc((SV*)sih);
2679 /* The siginfo fields signo, code, errno, pid, uid,
2680 * addr, status, and band are defined by POSIX/SUSv3. */
2681 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2682 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2683 #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. */
2684 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2685 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2686 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2687 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2688 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2689 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2693 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2702 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2705 if (SvTRUE(ERRSV)) {
2707 #ifdef HAS_SIGPROCMASK
2708 /* Handler "died", for example to get out of a restart-able read().
2709 * Before we re-do that on its behalf re-enable the signal which was
2710 * blocked by the system when we entered.
2714 sigaddset(&set,sig);
2715 sigprocmask(SIG_UNBLOCK, &set, NULL);
2717 /* Not clear if this will work */
2718 (void)rsignal(sig, SIG_IGN);
2719 (void)rsignal(sig, PL_csighandlerp);
2721 #endif /* !PERL_MICRO */
2722 Perl_die(aTHX_ Nullch);
2726 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2730 PL_scopestack_ix -= 1;
2733 PL_op = myop; /* Apparently not needed... */
2735 PL_Sv = tSv; /* Restore global temporaries. */
2742 S_restore_magic(pTHX_ const void *p)
2744 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2745 SV* const sv = mgs->mgs_sv;
2750 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2752 #ifdef PERL_OLD_COPY_ON_WRITE
2753 /* While magic was saved (and off) sv_setsv may well have seen
2754 this SV as a prime candidate for COW. */
2756 sv_force_normal_flags(sv, 0);
2760 SvFLAGS(sv) |= mgs->mgs_flags;
2763 if (SvGMAGICAL(sv)) {
2764 /* downgrade public flags to private,
2765 and discard any other private flags */
2767 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2769 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2770 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2775 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2777 /* If we're still on top of the stack, pop us off. (That condition
2778 * will be satisfied if restore_magic was called explicitly, but *not*
2779 * if it's being called via leave_scope.)
2780 * The reason for doing this is that otherwise, things like sv_2cv()
2781 * may leave alloc gunk on the savestack, and some code
2782 * (e.g. sighandler) doesn't expect that...
2784 if (PL_savestack_ix == mgs->mgs_ss_ix)
2786 I32 popval = SSPOPINT;
2787 assert(popval == SAVEt_DESTRUCTOR_X);
2788 PL_savestack_ix -= 2;
2790 assert(popval == SAVEt_ALLOC);
2792 PL_savestack_ix -= popval;
2798 S_unwind_handler_stack(pTHX_ const void *p)
2801 const U32 flags = *(const U32*)p;
2804 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2805 #if !defined(PERL_IMPLICIT_CONTEXT)
2807 SvREFCNT_dec(PL_sig_sv);
2813 * c-indentation-style: bsd
2815 * indent-tabs-mode: t
2818 * ex: set ts=8 sts=4 sw=4 noet: