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_COPY) && vtbl->svt_copy) {
434 /* XXX calling the copy method is probably not correct. DAPM */
435 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
436 mg->mg_ptr, mg->mg_len);
439 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
440 mg->mg_ptr, mg->mg_len);
442 /* container types should remain read-only across localization */
443 SvFLAGS(nsv) |= SvREADONLY(sv);
446 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
447 SvFLAGS(nsv) |= SvMAGICAL(sv);
457 Free any magic storage used by the SV. See C<sv_magic>.
463 Perl_mg_free(pTHX_ SV *sv)
467 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
468 const MGVTBL* const vtbl = mg->mg_virtual;
469 moremagic = mg->mg_moremagic;
470 if (vtbl && vtbl->svt_free)
471 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
472 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
473 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
474 Safefree(mg->mg_ptr);
475 else if (mg->mg_len == HEf_SVKEY)
476 SvREFCNT_dec((SV*)mg->mg_ptr);
478 if (mg->mg_flags & MGf_REFCOUNTED)
479 SvREFCNT_dec(mg->mg_obj);
482 SvMAGIC_set(sv, NULL);
489 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
494 register const REGEXP * const rx = PM_GETRE(PL_curpm);
497 ? rx->nparens /* @+ */
498 : rx->lastparen; /* @- */
506 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
509 register const REGEXP * const rx = PM_GETRE(PL_curpm);
511 register const I32 paren = mg->mg_len;
516 if (paren <= (I32)rx->nparens &&
517 (s = rx->startp[paren]) != -1 &&
518 (t = rx->endp[paren]) != -1)
521 if (mg->mg_obj) /* @+ */
526 if (i > 0 && RX_MATCH_UTF8(rx)) {
527 const char * const b = rx->subbeg;
529 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
540 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
542 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
543 Perl_croak(aTHX_ PL_no_modify);
544 NORETURN_FUNCTION_END;
548 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
552 register const REGEXP *rx;
555 switch (*mg->mg_ptr) {
556 case '1': case '2': case '3': case '4':
557 case '5': case '6': case '7': case '8': case '9': case '&':
558 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
560 paren = atoi(mg->mg_ptr); /* $& is in [0] */
562 if (paren <= (I32)rx->nparens &&
563 (s1 = rx->startp[paren]) != -1 &&
564 (t1 = rx->endp[paren]) != -1)
568 if (i > 0 && RX_MATCH_UTF8(rx)) {
569 const char * const s = rx->subbeg + s1;
574 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
578 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
582 if (ckWARN(WARN_UNINITIALIZED))
587 if (ckWARN(WARN_UNINITIALIZED))
592 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 paren = rx->lastparen;
598 case '\016': /* ^N */
599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
600 paren = rx->lastcloseparen;
606 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
607 if (rx->startp[0] != -1) {
618 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
619 if (rx->endp[0] != -1) {
620 i = rx->sublen - rx->endp[0];
631 if (!SvPOK(sv) && SvNIOK(sv)) {
639 #define SvRTRIM(sv) STMT_START { \
640 STRLEN len = SvCUR(sv); \
641 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
643 SvCUR_set(sv, len); \
647 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
651 register char *s = NULL;
654 const char * const remaining = mg->mg_ptr + 1;
655 const char nextchar = *remaining;
657 switch (*mg->mg_ptr) {
658 case '\001': /* ^A */
659 sv_setsv(sv, PL_bodytarget);
661 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
662 if (nextchar == '\0') {
663 sv_setiv(sv, (IV)PL_minus_c);
665 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
666 sv_setiv(sv, (IV)STATUS_NATIVE);
670 case '\004': /* ^D */
671 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
673 case '\005': /* ^E */
674 if (nextchar == '\0') {
675 #ifdef MACOS_TRADITIONAL
679 sv_setnv(sv,(double)gMacPerl_OSErr);
680 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
685 # include <descrip.h>
686 # include <starlet.h>
688 $DESCRIPTOR(msgdsc,msg);
689 sv_setnv(sv,(NV) vaxc$errno);
690 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
691 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
697 if (!(_emx_env & 0x200)) { /* Under DOS */
698 sv_setnv(sv, (NV)errno);
699 sv_setpv(sv, errno ? Strerror(errno) : "");
701 if (errno != errno_isOS2) {
702 const int tmp = _syserrno();
703 if (tmp) /* 2nd call to _syserrno() makes it 0 */
706 sv_setnv(sv, (NV)Perl_rc);
707 sv_setpv(sv, os2error(Perl_rc));
712 DWORD dwErr = GetLastError();
713 sv_setnv(sv, (NV)dwErr);
715 PerlProc_GetOSError(sv, dwErr);
718 sv_setpvn(sv, "", 0);
723 const int saveerrno = errno;
724 sv_setnv(sv, (NV)errno);
725 sv_setpv(sv, errno ? Strerror(errno) : "");
733 SvNOK_on(sv); /* what a wonderful hack! */
735 else if (strEQ(remaining, "NCODING"))
736 sv_setsv(sv, PL_encoding);
738 case '\006': /* ^F */
739 sv_setiv(sv, (IV)PL_maxsysfd);
741 case '\010': /* ^H */
742 sv_setiv(sv, (IV)PL_hints);
744 case '\011': /* ^I */ /* NOT \t in EBCDIC */
746 sv_setpv(sv, PL_inplace);
748 sv_setsv(sv, &PL_sv_undef);
750 case '\017': /* ^O & ^OPEN */
751 if (nextchar == '\0') {
752 sv_setpv(sv, PL_osname);
755 else if (strEQ(remaining, "PEN")) {
756 if (!PL_compiling.cop_io)
757 sv_setsv(sv, &PL_sv_undef);
759 sv_setsv(sv, PL_compiling.cop_io);
763 case '\020': /* ^P */
764 sv_setiv(sv, (IV)PL_perldb);
766 case '\023': /* ^S */
767 if (nextchar == '\0') {
768 if (PL_lex_state != LEX_NOTPARSING)
771 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
776 case '\024': /* ^T */
777 if (nextchar == '\0') {
779 sv_setnv(sv, PL_basetime);
781 sv_setiv(sv, (IV)PL_basetime);
784 else if (strEQ(remaining, "AINT"))
785 sv_setiv(sv, PL_tainting
786 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
789 case '\025': /* $^UNICODE, $^UTF8LOCALE */
790 if (strEQ(remaining, "NICODE"))
791 sv_setuv(sv, (UV) PL_unicode);
792 else if (strEQ(remaining, "TF8LOCALE"))
793 sv_setuv(sv, (UV) PL_utf8locale);
795 case '\027': /* ^W & $^WARNING_BITS */
796 if (nextchar == '\0')
797 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
798 else if (strEQ(remaining, "ARNING_BITS")) {
799 if (PL_compiling.cop_warnings == pWARN_NONE) {
800 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
802 else if (PL_compiling.cop_warnings == pWARN_STD) {
805 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
809 else if (PL_compiling.cop_warnings == pWARN_ALL) {
810 /* Get the bit mask for $warnings::Bits{all}, because
811 * it could have been extended by warnings::register */
813 HV * const bits=get_hv("warnings::Bits", FALSE);
814 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
815 sv_setsv(sv, *bits_all);
818 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
822 sv_setsv(sv, PL_compiling.cop_warnings);
827 case '1': case '2': case '3': case '4':
828 case '5': case '6': case '7': case '8': case '9': case '&':
829 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
833 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
834 * XXX Does the new way break anything?
836 paren = atoi(mg->mg_ptr); /* $& is in [0] */
838 if (paren <= (I32)rx->nparens &&
839 (s1 = rx->startp[paren]) != -1 &&
840 (t1 = rx->endp[paren]) != -1)
849 const int oldtainted = PL_tainted;
852 PL_tainted = oldtainted;
853 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
858 if (RX_MATCH_TAINTED(rx)) {
859 MAGIC* const mg = SvMAGIC(sv);
862 SvMAGIC_set(sv, mg->mg_moremagic);
864 if ((mgt = SvMAGIC(sv))) {
865 mg->mg_moremagic = mgt;
875 sv_setsv(sv,&PL_sv_undef);
878 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
879 paren = rx->lastparen;
883 sv_setsv(sv,&PL_sv_undef);
885 case '\016': /* ^N */
886 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
887 paren = rx->lastcloseparen;
891 sv_setsv(sv,&PL_sv_undef);
894 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
895 if ((s = rx->subbeg) && rx->startp[0] != -1) {
900 sv_setsv(sv,&PL_sv_undef);
903 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
904 if (rx->subbeg && rx->endp[0] != -1) {
905 s = rx->subbeg + rx->endp[0];
906 i = rx->sublen - rx->endp[0];
910 sv_setsv(sv,&PL_sv_undef);
913 if (GvIO(PL_last_in_gv)) {
914 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
919 sv_setiv(sv, (IV)STATUS_CURRENT);
920 #ifdef COMPLEX_STATUS
921 LvTARGOFF(sv) = PL_statusvalue;
922 LvTARGLEN(sv) = PL_statusvalue_vms;
927 if (GvIOp(PL_defoutgv))
928 s = IoTOP_NAME(GvIOp(PL_defoutgv));
932 sv_setpv(sv,GvENAME(PL_defoutgv));
937 if (GvIOp(PL_defoutgv))
938 s = IoFMT_NAME(GvIOp(PL_defoutgv));
940 s = GvENAME(PL_defoutgv);
944 if (GvIOp(PL_defoutgv))
945 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
948 if (GvIOp(PL_defoutgv))
949 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
952 if (GvIOp(PL_defoutgv))
953 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
960 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
963 if (GvIOp(PL_defoutgv))
964 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
970 sv_copypv(sv, PL_ors_sv);
974 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
975 sv_setpv(sv, errno ? Strerror(errno) : "");
978 const int saveerrno = errno;
979 sv_setnv(sv, (NV)errno);
981 if (errno == errno_isOS2 || errno == errno_isOS2_set)
982 sv_setpv(sv, os2error(Perl_rc));
985 sv_setpv(sv, errno ? Strerror(errno) : "");
990 SvNOK_on(sv); /* what a wonderful hack! */
993 sv_setiv(sv, (IV)PL_uid);
996 sv_setiv(sv, (IV)PL_euid);
999 sv_setiv(sv, (IV)PL_gid);
1000 #ifdef HAS_GETGROUPS
1001 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1005 sv_setiv(sv, (IV)PL_egid);
1006 #ifdef HAS_GETGROUPS
1007 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1010 #ifdef HAS_GETGROUPS
1012 Groups_t *gary = NULL;
1013 I32 num_groups = getgroups(0, gary);
1014 Newx(gary, num_groups, Groups_t);
1015 num_groups = getgroups(num_groups, gary);
1016 while (--num_groups >= 0)
1017 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1018 (long unsigned int)gary[num_groups]);
1022 (void)SvIOK_on(sv); /* what a wonderful hack! */
1024 #ifndef MACOS_TRADITIONAL
1033 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1035 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1037 if (uf && uf->uf_val)
1038 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1043 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1047 const char *s = SvPV_const(sv,len);
1048 const char * const ptr = MgPV_const(mg,klen);
1051 #ifdef DYNAMIC_ENV_FETCH
1052 /* We just undefd an environment var. Is a replacement */
1053 /* waiting in the wings? */
1055 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1057 s = SvPV_const(*valp, len);
1061 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1062 /* And you'll never guess what the dog had */
1063 /* in its mouth... */
1065 MgTAINTEDDIR_off(mg);
1067 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1068 char pathbuf[256], eltbuf[256], *cp, *elt;
1072 strncpy(eltbuf, s, 255);
1075 do { /* DCL$PATH may be a search list */
1076 while (1) { /* as may dev portion of any element */
1077 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079 cando_by_name(S_IWUSR,0,elt) ) {
1080 MgTAINTEDDIR_on(mg);
1084 if ((cp = strchr(elt, ':')) != Nullch)
1086 if (my_trnlnm(elt, eltbuf, j++))
1092 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1095 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1096 const char * const strend = s + len;
1098 while (s < strend) {
1102 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1103 s, strend, ':', &i);
1105 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1107 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1108 MgTAINTEDDIR_on(mg);
1114 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1120 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1122 PERL_UNUSED_ARG(sv);
1123 my_setenv(MgPV_nolen_const(mg),Nullch);
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1130 PERL_UNUSED_ARG(mg);
1132 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1134 if (PL_localizing) {
1137 hv_iterinit((HV*)sv);
1138 while ((entry = hv_iternext((HV*)sv))) {
1140 my_setenv(hv_iterkey(entry, &keylen),
1141 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1149 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1152 PERL_UNUSED_ARG(sv);
1153 PERL_UNUSED_ARG(mg);
1155 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1163 #ifdef HAS_SIGPROCMASK
1165 restore_sigmask(pTHX_ SV *save_sv)
1167 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1168 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1172 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1174 /* Are we fetching a signal entry? */
1175 const I32 i = whichsig(MgPV_nolen_const(mg));
1178 sv_setsv(sv,PL_psig_ptr[i]);
1180 Sighandler_t sigstate;
1181 sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1188 /* cache state so we don't fetch it again */
1189 if(sigstate == (Sighandler_t) SIG_IGN)
1190 sv_setpv(sv,"IGNORE");
1192 sv_setsv(sv,&PL_sv_undef);
1193 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1202 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203 * refactoring might be in order.
1206 register const char * const s = MgPV_nolen_const(mg);
1207 PERL_UNUSED_ARG(sv);
1210 if (strEQ(s,"__DIE__"))
1212 else if (strEQ(s,"__WARN__"))
1215 Perl_croak(aTHX_ "No such hook: %s", s);
1217 SV * const to_dec = *svp;
1219 SvREFCNT_dec(to_dec);
1223 /* Are we clearing a signal entry? */
1224 const I32 i = whichsig(s);
1226 #ifdef HAS_SIGPROCMASK
1229 /* Avoid having the signal arrive at a bad time, if possible. */
1232 sigprocmask(SIG_BLOCK, &set, &save);
1234 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235 SAVEFREESV(save_sv);
1236 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243 PL_sig_defaulting[i] = 1;
1244 (void)rsignal(i, PL_csighandlerp);
1246 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1248 if(PL_psig_name[i]) {
1249 SvREFCNT_dec(PL_psig_name[i]);
1252 if(PL_psig_ptr[i]) {
1253 SV *to_dec=PL_psig_ptr[i];
1256 SvREFCNT_dec(to_dec);
1266 S_raise_signal(pTHX_ int sig)
1268 /* Set a flag to say this signal is pending */
1269 PL_psig_pend[sig]++;
1270 /* And one to say _a_ signal is pending */
1275 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1276 Perl_csighandler(int sig, ...)
1278 Perl_csighandler(int sig)
1281 #ifdef PERL_GET_SIG_CONTEXT
1282 dTHXa(PERL_GET_SIG_CONTEXT);
1286 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1287 (void) rsignal(sig, PL_csighandlerp);
1288 if (PL_sig_ignoring[sig]) return;
1290 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1291 if (PL_sig_defaulting[sig])
1292 #ifdef KILL_BY_SIGPRC
1293 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1299 /* Call the perl level handler now--
1300 * with risk we may be in malloc() etc. */
1301 (*PL_sighandlerp)(sig);
1303 S_raise_signal(aTHX_ sig);
1306 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1308 Perl_csighandler_init(void)
1311 if (PL_sig_handlers_initted) return;
1313 for (sig = 1; sig < SIG_SIZE; sig++) {
1314 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1316 PL_sig_defaulting[sig] = 1;
1317 (void) rsignal(sig, PL_csighandlerp);
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320 PL_sig_ignoring[sig] = 0;
1323 PL_sig_handlers_initted = 1;
1328 Perl_despatch_signals(pTHX)
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333 if (PL_psig_pend[sig]) {
1334 PERL_BLOCKSIG_ADD(set, sig);
1335 PL_psig_pend[sig] = 0;
1336 PERL_BLOCKSIG_BLOCK(set);
1337 (*PL_sighandlerp)(sig);
1338 PERL_BLOCKSIG_UNBLOCK(set);
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1349 /* Need to be careful with SvREFCNT_dec(), because that can have side
1350 * effects (due to closures). We must make sure that the new disposition
1351 * is in place before it is called.
1355 #ifdef HAS_SIGPROCMASK
1360 register const char *s = MgPV_const(mg,len);
1362 if (strEQ(s,"__DIE__"))
1364 else if (strEQ(s,"__WARN__"))
1367 Perl_croak(aTHX_ "No such hook: %s", s);
1375 i = whichsig(s); /* ...no, a brick */
1377 if (ckWARN(WARN_SIGNAL))
1378 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1381 #ifdef HAS_SIGPROCMASK
1382 /* Avoid having the signal arrive at a bad time, if possible. */
1385 sigprocmask(SIG_BLOCK, &set, &save);
1387 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388 SAVEFREESV(save_sv);
1389 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396 PL_sig_ignoring[i] = 0;
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399 PL_sig_defaulting[i] = 0;
1401 SvREFCNT_dec(PL_psig_name[i]);
1402 to_dec = PL_psig_ptr[i];
1403 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1404 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405 PL_psig_name[i] = newSVpvn(s, len);
1406 SvREADONLY_on(PL_psig_name[i]);
1408 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1410 (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1416 *svp = SvREFCNT_inc(sv);
1418 SvREFCNT_dec(to_dec);
1421 s = SvPV_force(sv,len);
1422 if (strEQ(s,"IGNORE")) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425 PL_sig_ignoring[i] = 1;
1426 (void)rsignal(i, PL_csighandlerp);
1428 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1432 else if (strEQ(s,"DEFAULT") || !*s) {
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1436 PL_sig_defaulting[i] = 1;
1437 (void)rsignal(i, PL_csighandlerp);
1440 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1445 * We should warn if HINT_STRICT_REFS, but without
1446 * access to a known hint bit in a known OP, we can't
1447 * tell whether HINT_STRICT_REFS is in force or not.
1449 if (!strchr(s,':') && !strchr(s,'\''))
1450 sv_insert(sv, 0, 0, "main::", 6);
1452 (void)rsignal(i, PL_csighandlerp);
1454 *svp = SvREFCNT_inc(sv);
1456 #ifdef HAS_SIGPROCMASK
1461 SvREFCNT_dec(to_dec);
1464 #endif /* !PERL_MICRO */
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1469 PERL_UNUSED_ARG(sv);
1470 PERL_UNUSED_ARG(mg);
1471 PL_sub_generation++;
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_UNUSED_ARG(sv);
1479 PERL_UNUSED_ARG(mg);
1480 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1481 PL_amagic_generation++;
1487 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1489 HV * const hv = (HV*)LvTARG(sv);
1491 PERL_UNUSED_ARG(mg);
1494 (void) hv_iterinit(hv);
1495 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1498 while (hv_iternext(hv))
1503 sv_setiv(sv, (IV)i);
1508 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1510 PERL_UNUSED_ARG(mg);
1512 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1517 /* caller is responsible for stack switching/cleanup */
1519 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1525 PUSHs(SvTIED_obj(sv, mg));
1528 if (mg->mg_len >= 0)
1529 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1530 else if (mg->mg_len == HEf_SVKEY)
1531 PUSHs((SV*)mg->mg_ptr);
1533 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1534 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1542 return call_method(meth, flags);
1546 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1552 PUSHSTACKi(PERLSI_MAGIC);
1554 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1555 sv_setsv(sv, *PL_stack_sp--);
1565 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1568 mg->mg_flags |= MGf_GSKIP;
1569 magic_methpack(sv,mg,"FETCH");
1574 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1578 PUSHSTACKi(PERLSI_MAGIC);
1579 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1586 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1588 return magic_methpack(sv,mg,"DELETE");
1593 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1600 PUSHSTACKi(PERLSI_MAGIC);
1601 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1602 sv = *PL_stack_sp--;
1603 retval = (U32) SvIV(sv)-1;
1612 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1617 PUSHSTACKi(PERLSI_MAGIC);
1619 XPUSHs(SvTIED_obj(sv, mg));
1621 call_method("CLEAR", G_SCALAR|G_DISCARD);
1629 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1632 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1636 PUSHSTACKi(PERLSI_MAGIC);
1639 PUSHs(SvTIED_obj(sv, mg));
1644 if (call_method(meth, G_SCALAR))
1645 sv_setsv(key, *PL_stack_sp--);
1654 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1656 return magic_methpack(sv,mg,"EXISTS");
1660 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1663 SV *retval = &PL_sv_undef;
1664 SV * const tied = SvTIED_obj((SV*)hv, mg);
1665 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1667 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1669 if (HvEITER_get(hv))
1670 /* we are in an iteration so the hash cannot be empty */
1672 /* no xhv_eiter so now use FIRSTKEY */
1673 key = sv_newmortal();
1674 magic_nextpack((SV*)hv, mg, key);
1675 HvEITER_set(hv, NULL); /* need to reset iterator */
1676 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1679 /* there is a SCALAR method that we can call */
1681 PUSHSTACKi(PERLSI_MAGIC);
1687 if (call_method("SCALAR", G_SCALAR))
1688 retval = *PL_stack_sp--;
1695 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1697 GV * const gv = PL_DBline;
1698 const I32 i = SvTRUE(sv);
1699 SV ** const svp = av_fetch(GvAV(gv),
1700 atoi(MgPV_nolen_const(mg)), FALSE);
1701 if (svp && SvIOKp(*svp)) {
1702 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1704 /* set or clear breakpoint in the relevant control op */
1706 o->op_flags |= OPf_SPECIAL;
1708 o->op_flags &= ~OPf_SPECIAL;
1715 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1717 const AV * const obj = (AV*)mg->mg_obj;
1719 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1727 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1729 AV * const obj = (AV*)mg->mg_obj;
1731 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1733 if (ckWARN(WARN_MISC))
1734 Perl_warner(aTHX_ packWARN(WARN_MISC),
1735 "Attempt to set length of freed array");
1741 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1743 PERL_UNUSED_ARG(sv);
1744 /* during global destruction, mg_obj may already have been freed */
1745 if (PL_in_clean_all)
1748 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1751 /* arylen scalar holds a pointer back to the array, but doesn't own a
1752 reference. Hence the we (the array) are about to go away with it
1753 still pointing at us. Clear its pointer, else it would be pointing
1754 at free memory. See the comment in sv_magic about reference loops,
1755 and why it can't own a reference to us. */
1762 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1764 SV* const lsv = LvTARG(sv);
1766 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1767 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1768 if (mg && mg->mg_len >= 0) {
1771 sv_pos_b2u(lsv, &i);
1772 sv_setiv(sv, i + PL_curcop->cop_arybase);
1781 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1783 SV* const lsv = LvTARG(sv);
1790 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1791 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1795 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1796 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1798 else if (!SvOK(sv)) {
1802 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1804 pos = SvIV(sv) - PL_curcop->cop_arybase;
1807 ulen = sv_len_utf8(lsv);
1817 else if (pos > (SSize_t)len)
1822 sv_pos_u2b(lsv, &p, 0);
1827 mg->mg_flags &= ~MGf_MINMATCH;
1833 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1835 PERL_UNUSED_ARG(mg);
1836 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1838 gv_efullname3(sv,((GV*)sv), "*");
1842 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1847 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1850 PERL_UNUSED_ARG(mg);
1854 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1859 GvGP(sv) = gp_ref(GvGP(gv));
1864 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1867 SV * const lsv = LvTARG(sv);
1868 const char * const tmps = SvPV_const(lsv,len);
1869 I32 offs = LvTARGOFF(sv);
1870 I32 rem = LvTARGLEN(sv);
1871 PERL_UNUSED_ARG(mg);
1874 sv_pos_u2b(lsv, &offs, &rem);
1875 if (offs > (I32)len)
1877 if (rem + offs > (I32)len)
1879 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1886 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1889 const char *tmps = SvPV_const(sv, len);
1890 SV * const lsv = LvTARG(sv);
1891 I32 lvoff = LvTARGOFF(sv);
1892 I32 lvlen = LvTARGLEN(sv);
1893 PERL_UNUSED_ARG(mg);
1896 sv_utf8_upgrade(lsv);
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 sv_insert(lsv, lvoff, lvlen, tmps, len);
1899 LvTARGLEN(sv) = sv_len_utf8(sv);
1902 else if (lsv && SvUTF8(lsv)) {
1903 sv_pos_u2b(lsv, &lvoff, &lvlen);
1904 LvTARGLEN(sv) = len;
1905 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1910 sv_insert(lsv, lvoff, lvlen, tmps, len);
1911 LvTARGLEN(sv) = len;
1919 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1921 PERL_UNUSED_ARG(sv);
1922 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1929 PERL_UNUSED_ARG(sv);
1930 /* update taint status unless we're restoring at scope exit */
1931 if (PL_localizing != 2) {
1941 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1943 SV * const lsv = LvTARG(sv);
1944 PERL_UNUSED_ARG(mg);
1951 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1956 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1958 PERL_UNUSED_ARG(mg);
1959 do_vecset(sv); /* XXX slurp this routine */
1964 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1967 if (LvTARGLEN(sv)) {
1969 SV * const ahv = LvTARG(sv);
1970 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1975 AV* const av = (AV*)LvTARG(sv);
1976 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1977 targ = AvARRAY(av)[LvTARGOFF(sv)];
1979 if (targ && targ != &PL_sv_undef) {
1980 /* somebody else defined it for us */
1981 SvREFCNT_dec(LvTARG(sv));
1982 LvTARG(sv) = SvREFCNT_inc(targ);
1984 SvREFCNT_dec(mg->mg_obj);
1985 mg->mg_obj = Nullsv;
1986 mg->mg_flags &= ~MGf_REFCOUNTED;
1991 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1996 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1998 PERL_UNUSED_ARG(mg);
2002 sv_setsv(LvTARG(sv), sv);
2003 SvSETMAGIC(LvTARG(sv));
2009 Perl_vivify_defelem(pTHX_ SV *sv)
2014 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2017 SV * const ahv = LvTARG(sv);
2018 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2021 if (!value || value == &PL_sv_undef)
2022 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2025 AV* const av = (AV*)LvTARG(sv);
2026 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2027 LvTARG(sv) = Nullsv; /* array can't be extended */
2029 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2030 if (!svp || (value = *svp) == &PL_sv_undef)
2031 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2034 (void)SvREFCNT_inc(value);
2035 SvREFCNT_dec(LvTARG(sv));
2038 SvREFCNT_dec(mg->mg_obj);
2039 mg->mg_obj = Nullsv;
2040 mg->mg_flags &= ~MGf_REFCOUNTED;
2044 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2046 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2050 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2058 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2060 PERL_UNUSED_ARG(mg);
2061 sv_unmagic(sv, PERL_MAGIC_bm);
2067 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2069 PERL_UNUSED_ARG(mg);
2070 sv_unmagic(sv, PERL_MAGIC_fm);
2076 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2078 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2080 if (uf && uf->uf_set)
2081 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2086 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2088 PERL_UNUSED_ARG(mg);
2089 sv_unmagic(sv, PERL_MAGIC_qr);
2094 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2096 regexp * const re = (regexp *)mg->mg_obj;
2097 PERL_UNUSED_ARG(sv);
2103 #ifdef USE_LOCALE_COLLATE
2105 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2108 * RenE<eacute> Descartes said "I think not."
2109 * and vanished with a faint plop.
2111 PERL_UNUSED_ARG(sv);
2113 Safefree(mg->mg_ptr);
2119 #endif /* USE_LOCALE_COLLATE */
2121 /* Just clear the UTF-8 cache data. */
2123 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2125 PERL_UNUSED_ARG(sv);
2126 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2128 mg->mg_len = -1; /* The mg_len holds the len cache. */
2133 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2135 register const char *s;
2138 switch (*mg->mg_ptr) {
2139 case '\001': /* ^A */
2140 sv_setsv(PL_bodytarget, sv);
2142 case '\003': /* ^C */
2143 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2146 case '\004': /* ^D */
2148 s = SvPV_nolen_const(sv);
2149 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2150 DEBUG_x(dump_all());
2152 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2155 case '\005': /* ^E */
2156 if (*(mg->mg_ptr+1) == '\0') {
2157 #ifdef MACOS_TRADITIONAL
2158 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2161 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2164 SetLastError( SvIV(sv) );
2167 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2169 /* will anyone ever use this? */
2170 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2176 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2178 SvREFCNT_dec(PL_encoding);
2179 if (SvOK(sv) || SvGMAGICAL(sv)) {
2180 PL_encoding = newSVsv(sv);
2183 PL_encoding = Nullsv;
2187 case '\006': /* ^F */
2188 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2190 case '\010': /* ^H */
2191 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2193 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2194 Safefree(PL_inplace);
2195 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2197 case '\017': /* ^O */
2198 if (*(mg->mg_ptr+1) == '\0') {
2199 Safefree(PL_osname);
2202 TAINT_PROPER("assigning to $^O");
2203 PL_osname = savesvpv(sv);
2206 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2207 if (!PL_compiling.cop_io)
2208 PL_compiling.cop_io = newSVsv(sv);
2210 sv_setsv(PL_compiling.cop_io,sv);
2213 case '\020': /* ^P */
2214 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2215 if (PL_perldb && !PL_DBsingle)
2218 case '\024': /* ^T */
2220 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2222 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2225 case '\027': /* ^W & $^WARNING_BITS */
2226 if (*(mg->mg_ptr+1) == '\0') {
2227 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2228 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2229 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2230 | (i ? G_WARN_ON : G_WARN_OFF) ;
2233 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2234 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2235 if (!SvPOK(sv) && PL_localizing) {
2236 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2237 PL_compiling.cop_warnings = pWARN_NONE;
2242 int accumulate = 0 ;
2243 int any_fatals = 0 ;
2244 const char * const ptr = SvPV_const(sv, len) ;
2245 for (i = 0 ; i < len ; ++i) {
2246 accumulate |= ptr[i] ;
2247 any_fatals |= (ptr[i] & 0xAA) ;
2250 PL_compiling.cop_warnings = pWARN_NONE;
2251 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2252 PL_compiling.cop_warnings = pWARN_ALL;
2253 PL_dowarn |= G_WARN_ONCE ;
2256 if (specialWARN(PL_compiling.cop_warnings))
2257 PL_compiling.cop_warnings = newSVsv(sv) ;
2259 sv_setsv(PL_compiling.cop_warnings, sv);
2260 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2261 PL_dowarn |= G_WARN_ONCE ;
2269 if (PL_localizing) {
2270 if (PL_localizing == 1)
2271 SAVESPTR(PL_last_in_gv);
2273 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2274 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2277 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2278 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2279 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2282 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2283 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2284 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2287 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2290 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2291 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2292 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2295 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2299 IO * const io = GvIOp(PL_defoutgv);
2302 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2303 IoFLAGS(io) &= ~IOf_FLUSH;
2305 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2306 PerlIO *ofp = IoOFP(io);
2308 (void)PerlIO_flush(ofp);
2309 IoFLAGS(io) |= IOf_FLUSH;
2315 SvREFCNT_dec(PL_rs);
2316 PL_rs = newSVsv(sv);
2320 SvREFCNT_dec(PL_ors_sv);
2321 if (SvOK(sv) || SvGMAGICAL(sv)) {
2322 PL_ors_sv = newSVsv(sv);
2330 SvREFCNT_dec(PL_ofs_sv);
2331 if (SvOK(sv) || SvGMAGICAL(sv)) {
2332 PL_ofs_sv = newSVsv(sv);
2339 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2342 #ifdef COMPLEX_STATUS
2343 if (PL_localizing == 2) {
2344 PL_statusvalue = LvTARGOFF(sv);
2345 PL_statusvalue_vms = LvTARGLEN(sv);
2349 #ifdef VMSISH_STATUS
2351 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2354 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2359 # define PERL_VMS_BANG vaxc$errno
2361 # define PERL_VMS_BANG 0
2363 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2364 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2368 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2369 if (PL_delaymagic) {
2370 PL_delaymagic |= DM_RUID;
2371 break; /* don't do magic till later */
2374 (void)setruid((Uid_t)PL_uid);
2377 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2379 #ifdef HAS_SETRESUID
2380 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2382 if (PL_uid == PL_euid) { /* special case $< = $> */
2384 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2385 if (PL_uid != 0 && PerlProc_getuid() == 0)
2386 (void)PerlProc_setuid(0);
2388 (void)PerlProc_setuid(PL_uid);
2390 PL_uid = PerlProc_getuid();
2391 Perl_croak(aTHX_ "setruid() not implemented");
2396 PL_uid = PerlProc_getuid();
2397 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2400 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2401 if (PL_delaymagic) {
2402 PL_delaymagic |= DM_EUID;
2403 break; /* don't do magic till later */
2406 (void)seteuid((Uid_t)PL_euid);
2409 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2411 #ifdef HAS_SETRESUID
2412 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2414 if (PL_euid == PL_uid) /* special case $> = $< */
2415 PerlProc_setuid(PL_euid);
2417 PL_euid = PerlProc_geteuid();
2418 Perl_croak(aTHX_ "seteuid() not implemented");
2423 PL_euid = PerlProc_geteuid();
2424 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2427 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2428 if (PL_delaymagic) {
2429 PL_delaymagic |= DM_RGID;
2430 break; /* don't do magic till later */
2433 (void)setrgid((Gid_t)PL_gid);
2436 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2438 #ifdef HAS_SETRESGID
2439 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2441 if (PL_gid == PL_egid) /* special case $( = $) */
2442 (void)PerlProc_setgid(PL_gid);
2444 PL_gid = PerlProc_getgid();
2445 Perl_croak(aTHX_ "setrgid() not implemented");
2450 PL_gid = PerlProc_getgid();
2451 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2454 #ifdef HAS_SETGROUPS
2456 const char *p = SvPV_const(sv, len);
2457 Groups_t *gary = NULL;
2462 for (i = 0; i < NGROUPS; ++i) {
2463 while (*p && !isSPACE(*p))
2470 Newx(gary, i + 1, Groups_t);
2472 Renew(gary, i + 1, Groups_t);
2476 (void)setgroups(i, gary);
2480 #else /* HAS_SETGROUPS */
2481 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2482 #endif /* HAS_SETGROUPS */
2483 if (PL_delaymagic) {
2484 PL_delaymagic |= DM_EGID;
2485 break; /* don't do magic till later */
2488 (void)setegid((Gid_t)PL_egid);
2491 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2493 #ifdef HAS_SETRESGID
2494 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2496 if (PL_egid == PL_gid) /* special case $) = $( */
2497 (void)PerlProc_setgid(PL_egid);
2499 PL_egid = PerlProc_getegid();
2500 Perl_croak(aTHX_ "setegid() not implemented");
2505 PL_egid = PerlProc_getegid();
2506 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2509 PL_chopset = SvPV_force(sv,len);
2511 #ifndef MACOS_TRADITIONAL
2513 LOCK_DOLLARZERO_MUTEX;
2514 #ifdef HAS_SETPROCTITLE
2515 /* The BSDs don't show the argv[] in ps(1) output, they
2516 * show a string from the process struct and provide
2517 * the setproctitle() routine to manipulate that. */
2519 s = SvPV_const(sv, len);
2520 # if __FreeBSD_version > 410001
2521 /* The leading "-" removes the "perl: " prefix,
2522 * but not the "(perl) suffix from the ps(1)
2523 * output, because that's what ps(1) shows if the
2524 * argv[] is modified. */
2525 setproctitle("-%s", s);
2526 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2527 /* This doesn't really work if you assume that
2528 * $0 = 'foobar'; will wipe out 'perl' from the $0
2529 * because in ps(1) output the result will be like
2530 * sprintf("perl: %s (perl)", s)
2531 * I guess this is a security feature:
2532 * one (a user process) cannot get rid of the original name.
2534 setproctitle("%s", s);
2538 #if defined(__hpux) && defined(PSTAT_SETCMD)
2541 s = SvPV_const(sv, len);
2542 un.pst_command = (char *)s;
2543 pstat(PSTAT_SETCMD, un, len, 0, 0);
2546 /* PL_origalen is set in perl_parse(). */
2547 s = SvPV_force(sv,len);
2548 if (len >= (STRLEN)PL_origalen-1) {
2549 /* Longer than original, will be truncated. We assume that
2550 * PL_origalen bytes are available. */
2551 Copy(s, PL_origargv[0], PL_origalen-1, char);
2554 /* Shorter than original, will be padded. */
2555 Copy(s, PL_origargv[0], len, char);
2556 PL_origargv[0][len] = 0;
2557 memset(PL_origargv[0] + len + 1,
2558 /* Is the space counterintuitive? Yes.
2559 * (You were expecting \0?)
2560 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2563 PL_origalen - len - 1);
2565 PL_origargv[0][PL_origalen-1] = 0;
2566 for (i = 1; i < PL_origargc; i++)
2568 UNLOCK_DOLLARZERO_MUTEX;
2576 Perl_whichsig(pTHX_ const char *sig)
2578 register char* const* sigv;
2580 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2581 if (strEQ(sig,*sigv))
2582 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2584 if (strEQ(sig,"CHLD"))
2588 if (strEQ(sig,"CLD"))
2595 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2596 Perl_sighandler(int sig, ...)
2598 Perl_sighandler(int sig)
2601 #ifdef PERL_GET_SIG_CONTEXT
2602 dTHXa(PERL_GET_SIG_CONTEXT);
2609 SV * const tSv = PL_Sv;
2613 XPV * const tXpv = PL_Xpv;
2615 if (PL_savestack_ix + 15 <= PL_savestack_max)
2617 if (PL_markstack_ptr < PL_markstack_max - 2)
2619 if (PL_scopestack_ix < PL_scopestack_max - 3)
2622 if (!PL_psig_ptr[sig]) {
2623 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2628 /* Max number of items pushed there is 3*n or 4. We cannot fix
2629 infinity, so we fix 4 (in fact 5): */
2631 PL_savestack_ix += 5; /* Protect save in progress. */
2632 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2635 PL_markstack_ptr++; /* Protect mark. */
2637 PL_scopestack_ix += 1;
2638 /* sv_2cv is too complicated, try a simpler variant first: */
2639 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2640 || SvTYPE(cv) != SVt_PVCV) {
2642 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2645 if (!cv || !CvROOT(cv)) {
2646 if (ckWARN(WARN_SIGNAL))
2647 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2648 PL_sig_name[sig], (gv ? GvENAME(gv)
2655 if(PL_psig_name[sig]) {
2656 sv = SvREFCNT_inc(PL_psig_name[sig]);
2658 #if !defined(PERL_IMPLICIT_CONTEXT)
2662 sv = sv_newmortal();
2663 sv_setpv(sv,PL_sig_name[sig]);
2666 PUSHSTACKi(PERLSI_SIGNAL);
2669 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2671 struct sigaction oact;
2673 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2677 va_start(args, sig);
2678 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2681 SV *rv = newRV_noinc((SV*)sih);
2682 /* The siginfo fields signo, code, errno, pid, uid,
2683 * addr, status, and band are defined by POSIX/SUSv3. */
2684 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2685 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2686 #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. */
2687 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2688 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2689 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2690 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2691 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2692 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2696 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2705 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2708 if (SvTRUE(ERRSV)) {
2710 #ifdef HAS_SIGPROCMASK
2711 /* Handler "died", for example to get out of a restart-able read().
2712 * Before we re-do that on its behalf re-enable the signal which was
2713 * blocked by the system when we entered.
2717 sigaddset(&set,sig);
2718 sigprocmask(SIG_UNBLOCK, &set, NULL);
2720 /* Not clear if this will work */
2721 (void)rsignal(sig, SIG_IGN);
2722 (void)rsignal(sig, PL_csighandlerp);
2724 #endif /* !PERL_MICRO */
2725 Perl_die(aTHX_ Nullch);
2729 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2733 PL_scopestack_ix -= 1;
2736 PL_op = myop; /* Apparently not needed... */
2738 PL_Sv = tSv; /* Restore global temporaries. */
2745 S_restore_magic(pTHX_ const void *p)
2747 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2748 SV* const sv = mgs->mgs_sv;
2753 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2755 #ifdef PERL_OLD_COPY_ON_WRITE
2756 /* While magic was saved (and off) sv_setsv may well have seen
2757 this SV as a prime candidate for COW. */
2759 sv_force_normal_flags(sv, 0);
2763 SvFLAGS(sv) |= mgs->mgs_flags;
2766 if (SvGMAGICAL(sv)) {
2767 /* downgrade public flags to private,
2768 and discard any other private flags */
2770 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2772 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2773 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2778 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2780 /* If we're still on top of the stack, pop us off. (That condition
2781 * will be satisfied if restore_magic was called explicitly, but *not*
2782 * if it's being called via leave_scope.)
2783 * The reason for doing this is that otherwise, things like sv_2cv()
2784 * may leave alloc gunk on the savestack, and some code
2785 * (e.g. sighandler) doesn't expect that...
2787 if (PL_savestack_ix == mgs->mgs_ss_ix)
2789 I32 popval = SSPOPINT;
2790 assert(popval == SAVEt_DESTRUCTOR_X);
2791 PL_savestack_ix -= 2;
2793 assert(popval == SAVEt_ALLOC);
2795 PL_savestack_ix -= popval;
2801 S_unwind_handler_stack(pTHX_ const void *p)
2804 const U32 flags = *(const U32*)p;
2807 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2808 #if !defined(PERL_IMPLICIT_CONTEXT)
2810 SvREFCNT_dec(PL_sig_sv);
2816 * c-indentation-style: bsd
2818 * indent-tabs-mode: t
2821 * ex: set ts=8 sts=4 sw=4 noet: