3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
120 const MGVTBL* const vtbl = mg->mg_virtual;
122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
135 Do magic after a value is retrieved from the SV. See C<sv_magic>.
141 Perl_mg_get(pTHX_ SV *sv)
144 const I32 mgs_ix = SSNEW(sizeof(MGS));
145 const bool was_temp = (bool)SvTEMP(sv);
147 MAGIC *newmg, *head, *cur, *mg;
148 /* guard against sv having being freed midway by holding a private
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
155 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
160 save_magic(mgs_ix, sv);
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
166 newmg = cur = head = mg = SvMAGIC(sv);
168 const MGVTBL * const vtbl = mg->mg_virtual;
170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
173 /* guard against magic having been deleted - eg FETCH calling
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
183 mg = mg->mg_moremagic;
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
195 /* Were any new entries added? */
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
216 Do magic after a value is assigned to the SV. See C<sv_magic>.
222 Perl_mg_set(pTHX_ SV *sv)
225 const I32 mgs_ix = SSNEW(sizeof(MGS));
229 save_magic(mgs_ix, sv);
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
232 const MGVTBL* vtbl = mg->mg_virtual;
233 nextmg = mg->mg_moremagic; /* it may delete itself */
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
238 if (vtbl && vtbl->svt_set)
239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
247 =for apidoc mg_length
249 Report on the SV's length. See C<sv_magic>.
255 Perl_mg_length(pTHX_ SV *sv)
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 const MGVTBL * const vtbl = mg->mg_virtual;
263 if (vtbl && vtbl->svt_len) {
264 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
266 /* omit MGf_GSKIP -- not changed here */
267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
274 const U8 *s = (U8*)SvPV_const(sv, len);
275 len = utf8_length(s, s + len);
278 (void)SvPV_const(sv, len);
283 Perl_mg_size(pTHX_ SV *sv)
287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
288 const MGVTBL* const vtbl = mg->mg_virtual;
289 if (vtbl && vtbl->svt_len) {
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 save_magic(mgs_ix, sv);
293 /* omit MGf_GSKIP -- not changed here */
294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
306 Perl_croak(aTHX_ "Size magic not implemented");
315 Clear something magical that the SV represents. See C<sv_magic>.
321 Perl_mg_clear(pTHX_ SV *sv)
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
326 save_magic(mgs_ix, sv);
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 /* omit GSKIP -- never set here */
332 if (vtbl && vtbl->svt_clear)
333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 Finds the magic pointer for type matching the SV. See C<sv_magic>.
349 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
381 const char type = mg->mg_type;
382 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
384 (type == PERL_MAGIC_tied)
386 : (type == PERL_MAGIC_regdata && mg->mg_obj)
389 toLOWER(type), key, klen);
398 =for apidoc mg_localize
400 Copy some of the magic from an existing SV to new localized version of
401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
402 doesn't (eg taint, pos).
408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 MGVTBL* const vtbl = mg->mg_virtual;
414 switch (mg->mg_type) {
415 /* value magic types: don't copy */
418 case PERL_MAGIC_regex_global:
419 case PERL_MAGIC_nkeys:
420 #ifdef USE_LOCALE_COLLATE
421 case PERL_MAGIC_collxfrm:
424 case PERL_MAGIC_taint:
426 case PERL_MAGIC_vstring:
427 case PERL_MAGIC_utf8:
428 case PERL_MAGIC_substr:
429 case PERL_MAGIC_defelem:
430 case PERL_MAGIC_arylen:
432 case PERL_MAGIC_backref:
433 case PERL_MAGIC_arylen_p:
434 case PERL_MAGIC_rhash:
435 case PERL_MAGIC_symtab:
439 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
440 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
442 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
443 mg->mg_ptr, mg->mg_len);
445 /* container types should remain read-only across localization */
446 SvFLAGS(nsv) |= SvREADONLY(sv);
449 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
450 SvFLAGS(nsv) |= SvMAGICAL(sv);
460 Free any magic storage used by the SV. See C<sv_magic>.
466 Perl_mg_free(pTHX_ SV *sv)
470 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 moremagic = mg->mg_moremagic;
473 if (vtbl && vtbl->svt_free)
474 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
475 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
476 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
477 Safefree(mg->mg_ptr);
478 else if (mg->mg_len == HEf_SVKEY)
479 SvREFCNT_dec((SV*)mg->mg_ptr);
481 if (mg->mg_flags & MGf_REFCOUNTED)
482 SvREFCNT_dec(mg->mg_obj);
485 SvMAGIC_set(sv, NULL);
492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
498 register const REGEXP * const rx = PM_GETRE(PL_curpm);
501 ? rx->nparens /* @+ */
502 : rx->lastparen; /* @- */
510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 register const I32 paren = mg->mg_len;
521 if (paren <= (I32)rx->nparens &&
522 (s = rx->startp[paren]) != -1 &&
523 (t = rx->endp[paren]) != -1)
526 if (mg->mg_obj) /* @+ */
531 if (i > 0 && RX_MATCH_UTF8(rx)) {
532 const char * const b = rx->subbeg;
534 i = utf8_length((U8*)b, (U8*)(b+i));
545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
549 Perl_croak(aTHX_ PL_no_modify);
550 NORETURN_FUNCTION_END;
554 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
559 register const REGEXP *rx;
562 switch (*mg->mg_ptr) {
563 case '1': case '2': case '3': case '4':
564 case '5': case '6': case '7': case '8': case '9': case '&':
565 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
567 paren = atoi(mg->mg_ptr); /* $& is in [0] */
569 if (paren <= (I32)rx->nparens &&
570 (s1 = rx->startp[paren]) != -1 &&
571 (t1 = rx->endp[paren]) != -1)
575 if (i > 0 && RX_MATCH_UTF8(rx)) {
576 const char * const s = rx->subbeg + s1;
581 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
585 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
589 if (ckWARN(WARN_UNINITIALIZED))
594 if (ckWARN(WARN_UNINITIALIZED))
599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
600 paren = rx->lastparen;
605 case '\016': /* ^N */
606 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
607 paren = rx->lastcloseparen;
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->startp[0] != -1) {
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 if (rx->endp[0] != -1) {
627 i = rx->sublen - rx->endp[0];
638 if (!SvPOK(sv) && SvNIOK(sv)) {
646 #define SvRTRIM(sv) STMT_START { \
648 STRLEN len = SvCUR(sv); \
649 char * const p = SvPVX(sv); \
650 while (len > 0 && isSPACE(p[len-1])) \
652 SvCUR_set(sv, len); \
658 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
662 register char *s = NULL;
665 const char * const remaining = mg->mg_ptr + 1;
666 const char nextchar = *remaining;
668 switch (*mg->mg_ptr) {
669 case '\001': /* ^A */
670 sv_setsv(sv, PL_bodytarget);
672 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
673 if (nextchar == '\0') {
674 sv_setiv(sv, (IV)PL_minus_c);
676 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
677 sv_setiv(sv, (IV)STATUS_NATIVE);
681 case '\004': /* ^D */
682 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
684 case '\005': /* ^E */
685 if (nextchar == '\0') {
686 #if defined(MACOS_TRADITIONAL)
690 sv_setnv(sv,(double)gMacPerl_OSErr);
691 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
695 # include <descrip.h>
696 # include <starlet.h>
698 $DESCRIPTOR(msgdsc,msg);
699 sv_setnv(sv,(NV) vaxc$errno);
700 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
701 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
706 if (!(_emx_env & 0x200)) { /* Under DOS */
707 sv_setnv(sv, (NV)errno);
708 sv_setpv(sv, errno ? Strerror(errno) : "");
710 if (errno != errno_isOS2) {
711 const int tmp = _syserrno();
712 if (tmp) /* 2nd call to _syserrno() makes it 0 */
715 sv_setnv(sv, (NV)Perl_rc);
716 sv_setpv(sv, os2error(Perl_rc));
720 const DWORD dwErr = GetLastError();
721 sv_setnv(sv, (NV)dwErr);
723 PerlProc_GetOSError(sv, dwErr);
726 sv_setpvn(sv, "", 0);
731 const int saveerrno = errno;
732 sv_setnv(sv, (NV)errno);
733 sv_setpv(sv, errno ? Strerror(errno) : "");
738 SvNOK_on(sv); /* what a wonderful hack! */
740 else if (strEQ(remaining, "NCODING"))
741 sv_setsv(sv, PL_encoding);
743 case '\006': /* ^F */
744 sv_setiv(sv, (IV)PL_maxsysfd);
746 case '\010': /* ^H */
747 sv_setiv(sv, (IV)PL_hints);
749 case '\011': /* ^I */ /* NOT \t in EBCDIC */
751 sv_setpv(sv, PL_inplace);
753 sv_setsv(sv, &PL_sv_undef);
755 case '\017': /* ^O & ^OPEN */
756 if (nextchar == '\0') {
757 sv_setpv(sv, PL_osname);
760 else if (strEQ(remaining, "PEN")) {
761 if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
762 sv_setsv(sv, &PL_sv_undef);
765 Perl_refcounted_he_fetch(aTHX_
766 PL_compiling.cop_hints_hash,
767 0, "open", 4, 0, 0));
771 case '\020': /* ^P */
772 sv_setiv(sv, (IV)PL_perldb);
774 case '\023': /* ^S */
775 if (nextchar == '\0') {
776 if (PL_lex_state != LEX_NOTPARSING)
779 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
784 case '\024': /* ^T */
785 if (nextchar == '\0') {
787 sv_setnv(sv, PL_basetime);
789 sv_setiv(sv, (IV)PL_basetime);
792 else if (strEQ(remaining, "AINT"))
793 sv_setiv(sv, PL_tainting
794 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
797 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
798 if (strEQ(remaining, "NICODE"))
799 sv_setuv(sv, (UV) PL_unicode);
800 else if (strEQ(remaining, "TF8LOCALE"))
801 sv_setuv(sv, (UV) PL_utf8locale);
802 else if (strEQ(remaining, "TF8CACHE"))
803 sv_setiv(sv, (IV) PL_utf8cache);
805 case '\027': /* ^W & $^WARNING_BITS */
806 if (nextchar == '\0')
807 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
808 else if (strEQ(remaining, "ARNING_BITS")) {
809 if (PL_compiling.cop_warnings == pWARN_NONE) {
810 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
812 else if (PL_compiling.cop_warnings == pWARN_STD) {
815 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
819 else if (PL_compiling.cop_warnings == pWARN_ALL) {
820 /* Get the bit mask for $warnings::Bits{all}, because
821 * it could have been extended by warnings::register */
822 HV * const bits=get_hv("warnings::Bits", FALSE);
824 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
826 sv_setsv(sv, *bits_all);
829 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
833 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
834 *PL_compiling.cop_warnings);
839 case '1': case '2': case '3': case '4':
840 case '5': case '6': case '7': case '8': case '9': case '&':
841 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
845 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
846 * XXX Does the new way break anything?
848 paren = atoi(mg->mg_ptr); /* $& is in [0] */
850 if (paren <= (I32)rx->nparens &&
851 (s1 = rx->startp[paren]) != -1 &&
852 (t1 = rx->endp[paren]) != -1)
857 assert(rx->sublen >= s1);
861 const int oldtainted = PL_tainted;
864 PL_tainted = oldtainted;
865 if ( (rx->reganch & ROPT_CANY_SEEN)
867 && (!i || is_utf8_string((U8*)s, i)))
868 : (RX_MATCH_UTF8(rx)) )
875 if (RX_MATCH_TAINTED(rx)) {
876 MAGIC* const mg = SvMAGIC(sv);
879 SvMAGIC_set(sv, mg->mg_moremagic);
881 if ((mgt = SvMAGIC(sv))) {
882 mg->mg_moremagic = mgt;
892 sv_setsv(sv,&PL_sv_undef);
895 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
896 paren = rx->lastparen;
900 sv_setsv(sv,&PL_sv_undef);
902 case '\016': /* ^N */
903 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
904 paren = rx->lastcloseparen;
908 sv_setsv(sv,&PL_sv_undef);
911 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
912 if ((s = rx->subbeg) && rx->startp[0] != -1) {
917 sv_setsv(sv,&PL_sv_undef);
920 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
921 if (rx->subbeg && rx->endp[0] != -1) {
922 s = rx->subbeg + rx->endp[0];
923 i = rx->sublen - rx->endp[0];
927 sv_setsv(sv,&PL_sv_undef);
930 if (GvIO(PL_last_in_gv)) {
931 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
936 sv_setiv(sv, (IV)STATUS_CURRENT);
937 #ifdef COMPLEX_STATUS
938 LvTARGOFF(sv) = PL_statusvalue;
939 LvTARGLEN(sv) = PL_statusvalue_vms;
944 if (GvIOp(PL_defoutgv))
945 s = IoTOP_NAME(GvIOp(PL_defoutgv));
949 sv_setpv(sv,GvENAME(PL_defoutgv));
954 if (GvIOp(PL_defoutgv))
955 s = IoFMT_NAME(GvIOp(PL_defoutgv));
957 s = GvENAME(PL_defoutgv);
961 if (GvIOp(PL_defoutgv))
962 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
965 if (GvIOp(PL_defoutgv))
966 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
969 if (GvIOp(PL_defoutgv))
970 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
977 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
980 if (GvIOp(PL_defoutgv))
981 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
987 sv_copypv(sv, PL_ors_sv);
991 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
992 sv_setpv(sv, errno ? Strerror(errno) : "");
995 const int saveerrno = errno;
996 sv_setnv(sv, (NV)errno);
998 if (errno == errno_isOS2 || errno == errno_isOS2_set)
999 sv_setpv(sv, os2error(Perl_rc));
1002 sv_setpv(sv, errno ? Strerror(errno) : "");
1007 SvNOK_on(sv); /* what a wonderful hack! */
1010 sv_setiv(sv, (IV)PL_uid);
1013 sv_setiv(sv, (IV)PL_euid);
1016 sv_setiv(sv, (IV)PL_gid);
1019 sv_setiv(sv, (IV)PL_egid);
1021 #ifdef HAS_GETGROUPS
1023 Groups_t *gary = NULL;
1024 I32 i, num_groups = getgroups(0, gary);
1025 Newx(gary, num_groups, Groups_t);
1026 num_groups = getgroups(num_groups, gary);
1027 for (i = 0; i < num_groups; i++)
1028 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1031 (void)SvIOK_on(sv); /* what a wonderful hack! */
1034 #ifndef MACOS_TRADITIONAL
1043 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1045 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1047 if (uf && uf->uf_val)
1048 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1053 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1056 STRLEN len = 0, klen;
1057 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1058 const char * const ptr = MgPV_const(mg,klen);
1061 #ifdef DYNAMIC_ENV_FETCH
1062 /* We just undefd an environment var. Is a replacement */
1063 /* waiting in the wings? */
1065 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1067 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1071 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1072 /* And you'll never guess what the dog had */
1073 /* in its mouth... */
1075 MgTAINTEDDIR_off(mg);
1077 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1078 char pathbuf[256], eltbuf[256], *cp, *elt;
1082 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1084 do { /* DCL$PATH may be a search list */
1085 while (1) { /* as may dev portion of any element */
1086 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1087 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1088 cando_by_name(S_IWUSR,0,elt) ) {
1089 MgTAINTEDDIR_on(mg);
1093 if ((cp = strchr(elt, ':')) != NULL)
1095 if (my_trnlnm(elt, eltbuf, j++))
1101 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1104 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1105 const char * const strend = s + len;
1107 while (s < strend) {
1111 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1112 const char path_sep = '|';
1114 const char path_sep = ':';
1116 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1117 s, strend, path_sep, &i);
1119 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1121 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1123 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1125 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1126 MgTAINTEDDIR_on(mg);
1132 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1138 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1140 PERL_UNUSED_ARG(sv);
1141 my_setenv(MgPV_nolen_const(mg),NULL);
1146 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1149 PERL_UNUSED_ARG(mg);
1151 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1153 if (PL_localizing) {
1156 hv_iterinit((HV*)sv);
1157 while ((entry = hv_iternext((HV*)sv))) {
1159 my_setenv(hv_iterkey(entry, &keylen),
1160 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1168 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1171 PERL_UNUSED_ARG(sv);
1172 PERL_UNUSED_ARG(mg);
1174 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1182 #ifdef HAS_SIGPROCMASK
1184 restore_sigmask(pTHX_ SV *save_sv)
1186 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1187 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1191 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1194 /* Are we fetching a signal entry? */
1195 const I32 i = whichsig(MgPV_nolen_const(mg));
1198 sv_setsv(sv,PL_psig_ptr[i]);
1200 Sighandler_t sigstate = rsignal_state(i);
1201 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1202 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1205 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1206 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1209 /* cache state so we don't fetch it again */
1210 if(sigstate == (Sighandler_t) SIG_IGN)
1211 sv_setpv(sv,"IGNORE");
1213 sv_setsv(sv,&PL_sv_undef);
1214 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1221 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1223 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1224 * refactoring might be in order.
1227 register const char * const s = MgPV_nolen_const(mg);
1228 PERL_UNUSED_ARG(sv);
1231 if (strEQ(s,"__DIE__"))
1233 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1236 SV *const to_dec = *svp;
1238 SvREFCNT_dec(to_dec);
1242 /* Are we clearing a signal entry? */
1243 const I32 i = whichsig(s);
1245 #ifdef HAS_SIGPROCMASK
1248 /* Avoid having the signal arrive at a bad time, if possible. */
1251 sigprocmask(SIG_BLOCK, &set, &save);
1253 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1254 SAVEFREESV(save_sv);
1255 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1258 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1259 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1261 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1262 PL_sig_defaulting[i] = 1;
1263 (void)rsignal(i, PL_csighandlerp);
1265 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1267 if(PL_psig_name[i]) {
1268 SvREFCNT_dec(PL_psig_name[i]);
1271 if(PL_psig_ptr[i]) {
1272 SV * const to_dec=PL_psig_ptr[i];
1275 SvREFCNT_dec(to_dec);
1285 S_raise_signal(pTHX_ int sig)
1288 /* Set a flag to say this signal is pending */
1289 PL_psig_pend[sig]++;
1290 /* And one to say _a_ signal is pending */
1295 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1296 Perl_csighandler(int sig, ...)
1298 Perl_csighandler(int sig)
1301 #ifdef PERL_GET_SIG_CONTEXT
1302 dTHXa(PERL_GET_SIG_CONTEXT);
1306 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1307 (void) rsignal(sig, PL_csighandlerp);
1308 if (PL_sig_ignoring[sig]) return;
1310 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1311 if (PL_sig_defaulting[sig])
1312 #ifdef KILL_BY_SIGPRC
1313 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1328 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1329 /* Call the perl level handler now--
1330 * with risk we may be in malloc() etc. */
1331 (*PL_sighandlerp)(sig);
1333 S_raise_signal(aTHX_ sig);
1336 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1338 Perl_csighandler_init(void)
1341 if (PL_sig_handlers_initted) return;
1343 for (sig = 1; sig < SIG_SIZE; sig++) {
1344 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1346 PL_sig_defaulting[sig] = 1;
1347 (void) rsignal(sig, PL_csighandlerp);
1349 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1350 PL_sig_ignoring[sig] = 0;
1353 PL_sig_handlers_initted = 1;
1358 Perl_despatch_signals(pTHX)
1363 for (sig = 1; sig < SIG_SIZE; sig++) {
1364 if (PL_psig_pend[sig]) {
1365 PERL_BLOCKSIG_ADD(set, sig);
1366 PL_psig_pend[sig] = 0;
1367 PERL_BLOCKSIG_BLOCK(set);
1368 (*PL_sighandlerp)(sig);
1369 PERL_BLOCKSIG_UNBLOCK(set);
1375 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1380 /* Need to be careful with SvREFCNT_dec(), because that can have side
1381 * effects (due to closures). We must make sure that the new disposition
1382 * is in place before it is called.
1386 #ifdef HAS_SIGPROCMASK
1391 register const char *s = MgPV_const(mg,len);
1393 if (strEQ(s,"__DIE__"))
1395 else if (strEQ(s,"__WARN__"))
1398 Perl_croak(aTHX_ "No such hook: %s", s);
1401 if (*svp != PERL_WARNHOOK_FATAL)
1407 i = whichsig(s); /* ...no, a brick */
1409 if (ckWARN(WARN_SIGNAL))
1410 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1413 #ifdef HAS_SIGPROCMASK
1414 /* Avoid having the signal arrive at a bad time, if possible. */
1417 sigprocmask(SIG_BLOCK, &set, &save);
1419 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1420 SAVEFREESV(save_sv);
1421 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1424 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1425 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1427 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1428 PL_sig_ignoring[i] = 0;
1430 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1431 PL_sig_defaulting[i] = 0;
1433 SvREFCNT_dec(PL_psig_name[i]);
1434 to_dec = PL_psig_ptr[i];
1435 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1436 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1437 PL_psig_name[i] = newSVpvn(s, len);
1438 SvREADONLY_on(PL_psig_name[i]);
1440 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1442 (void)rsignal(i, PL_csighandlerp);
1443 #ifdef HAS_SIGPROCMASK
1448 *svp = SvREFCNT_inc_simple_NN(sv);
1450 SvREFCNT_dec(to_dec);
1453 s = SvPV_force(sv,len);
1454 if (strEQ(s,"IGNORE")) {
1456 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1457 PL_sig_ignoring[i] = 1;
1458 (void)rsignal(i, PL_csighandlerp);
1460 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1464 else if (strEQ(s,"DEFAULT") || !*s) {
1466 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1468 PL_sig_defaulting[i] = 1;
1469 (void)rsignal(i, PL_csighandlerp);
1472 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1477 * We should warn if HINT_STRICT_REFS, but without
1478 * access to a known hint bit in a known OP, we can't
1479 * tell whether HINT_STRICT_REFS is in force or not.
1481 if (!strchr(s,':') && !strchr(s,'\''))
1482 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1484 (void)rsignal(i, PL_csighandlerp);
1486 *svp = SvREFCNT_inc_simple_NN(sv);
1488 #ifdef HAS_SIGPROCMASK
1493 SvREFCNT_dec(to_dec);
1496 #endif /* !PERL_MICRO */
1499 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1502 PERL_UNUSED_ARG(sv);
1503 PERL_UNUSED_ARG(mg);
1504 PL_sub_generation++;
1509 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1512 PERL_UNUSED_ARG(sv);
1513 PERL_UNUSED_ARG(mg);
1514 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1515 PL_amagic_generation++;
1521 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1523 HV * const hv = (HV*)LvTARG(sv);
1525 PERL_UNUSED_ARG(mg);
1528 (void) hv_iterinit(hv);
1529 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1532 while (hv_iternext(hv))
1537 sv_setiv(sv, (IV)i);
1542 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1544 PERL_UNUSED_ARG(mg);
1546 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1551 /* caller is responsible for stack switching/cleanup */
1553 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1560 PUSHs(SvTIED_obj(sv, mg));
1563 if (mg->mg_len >= 0)
1564 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1565 else if (mg->mg_len == HEf_SVKEY)
1566 PUSHs((SV*)mg->mg_ptr);
1568 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1569 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1577 return call_method(meth, flags);
1581 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1587 PUSHSTACKi(PERLSI_MAGIC);
1589 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1590 sv_setsv(sv, *PL_stack_sp--);
1600 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1603 mg->mg_flags |= MGf_GSKIP;
1604 magic_methpack(sv,mg,"FETCH");
1609 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1613 PUSHSTACKi(PERLSI_MAGIC);
1614 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1621 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1623 return magic_methpack(sv,mg,"DELETE");
1628 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1635 PUSHSTACKi(PERLSI_MAGIC);
1636 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1637 sv = *PL_stack_sp--;
1638 retval = (U32) SvIV(sv)-1;
1647 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1652 PUSHSTACKi(PERLSI_MAGIC);
1654 XPUSHs(SvTIED_obj(sv, mg));
1656 call_method("CLEAR", G_SCALAR|G_DISCARD);
1664 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1667 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1671 PUSHSTACKi(PERLSI_MAGIC);
1674 PUSHs(SvTIED_obj(sv, mg));
1679 if (call_method(meth, G_SCALAR))
1680 sv_setsv(key, *PL_stack_sp--);
1689 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1691 return magic_methpack(sv,mg,"EXISTS");
1695 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1699 SV * const tied = SvTIED_obj((SV*)hv, mg);
1700 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1702 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1704 if (HvEITER_get(hv))
1705 /* we are in an iteration so the hash cannot be empty */
1707 /* no xhv_eiter so now use FIRSTKEY */
1708 key = sv_newmortal();
1709 magic_nextpack((SV*)hv, mg, key);
1710 HvEITER_set(hv, NULL); /* need to reset iterator */
1711 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1714 /* there is a SCALAR method that we can call */
1716 PUSHSTACKi(PERLSI_MAGIC);
1722 if (call_method("SCALAR", G_SCALAR))
1723 retval = *PL_stack_sp--;
1725 retval = &PL_sv_undef;
1732 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1735 GV * const gv = PL_DBline;
1736 const I32 i = SvTRUE(sv);
1737 SV ** const svp = av_fetch(GvAV(gv),
1738 atoi(MgPV_nolen_const(mg)), FALSE);
1739 if (svp && SvIOKp(*svp)) {
1740 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1742 /* set or clear breakpoint in the relevant control op */
1744 o->op_flags |= OPf_SPECIAL;
1746 o->op_flags &= ~OPf_SPECIAL;
1753 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1756 const AV * const obj = (AV*)mg->mg_obj;
1758 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1766 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1769 AV * const obj = (AV*)mg->mg_obj;
1771 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1773 if (ckWARN(WARN_MISC))
1774 Perl_warner(aTHX_ packWARN(WARN_MISC),
1775 "Attempt to set length of freed array");
1781 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1784 PERL_UNUSED_ARG(sv);
1785 /* during global destruction, mg_obj may already have been freed */
1786 if (PL_in_clean_all)
1789 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1792 /* arylen scalar holds a pointer back to the array, but doesn't own a
1793 reference. Hence the we (the array) are about to go away with it
1794 still pointing at us. Clear its pointer, else it would be pointing
1795 at free memory. See the comment in sv_magic about reference loops,
1796 and why it can't own a reference to us. */
1803 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1806 SV* const lsv = LvTARG(sv);
1807 PERL_UNUSED_ARG(mg);
1809 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1810 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1811 if (found && found->mg_len >= 0) {
1812 I32 i = found->mg_len;
1814 sv_pos_b2u(lsv, &i);
1815 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1824 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1827 SV* const lsv = LvTARG(sv);
1833 PERL_UNUSED_ARG(mg);
1835 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1836 found = mg_find(lsv, PERL_MAGIC_regex_global);
1842 #ifdef PERL_OLD_COPY_ON_WRITE
1844 sv_force_normal_flags(lsv, 0);
1846 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1849 else if (!SvOK(sv)) {
1853 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1855 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1858 ulen = sv_len_utf8(lsv);
1868 else if (pos > (SSize_t)len)
1873 sv_pos_u2b(lsv, &p, 0);
1877 found->mg_len = pos;
1878 found->mg_flags &= ~MGf_MINMATCH;
1884 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1887 PERL_UNUSED_ARG(mg);
1891 if (SvFLAGS(sv) & SVp_SCREAM
1892 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1893 /* We're actually already a typeglob, so don't need the stuff below.
1897 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1902 GvGP(sv) = gp_ref(GvGP(gv));
1907 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1910 SV * const lsv = LvTARG(sv);
1911 const char * const tmps = SvPV_const(lsv,len);
1912 I32 offs = LvTARGOFF(sv);
1913 I32 rem = LvTARGLEN(sv);
1914 PERL_UNUSED_ARG(mg);
1917 sv_pos_u2b(lsv, &offs, &rem);
1918 if (offs > (I32)len)
1920 if (rem + offs > (I32)len)
1922 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1929 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1933 const char * const tmps = SvPV_const(sv, len);
1934 SV * const lsv = LvTARG(sv);
1935 I32 lvoff = LvTARGOFF(sv);
1936 I32 lvlen = LvTARGLEN(sv);
1937 PERL_UNUSED_ARG(mg);
1940 sv_utf8_upgrade(lsv);
1941 sv_pos_u2b(lsv, &lvoff, &lvlen);
1942 sv_insert(lsv, lvoff, lvlen, tmps, len);
1943 LvTARGLEN(sv) = sv_len_utf8(sv);
1946 else if (lsv && SvUTF8(lsv)) {
1948 sv_pos_u2b(lsv, &lvoff, &lvlen);
1949 LvTARGLEN(sv) = len;
1950 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1951 sv_insert(lsv, lvoff, lvlen, utf8, len);
1955 sv_insert(lsv, lvoff, lvlen, tmps, len);
1956 LvTARGLEN(sv) = len;
1964 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1967 PERL_UNUSED_ARG(sv);
1968 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1973 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1976 PERL_UNUSED_ARG(sv);
1977 /* update taint status unless we're restoring at scope exit */
1978 if (PL_localizing != 2) {
1988 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1990 SV * const lsv = LvTARG(sv);
1991 PERL_UNUSED_ARG(mg);
1994 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2002 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2004 PERL_UNUSED_ARG(mg);
2005 do_vecset(sv); /* XXX slurp this routine */
2010 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2014 if (LvTARGLEN(sv)) {
2016 SV * const ahv = LvTARG(sv);
2017 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2022 AV* const av = (AV*)LvTARG(sv);
2023 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2024 targ = AvARRAY(av)[LvTARGOFF(sv)];
2026 if (targ && (targ != &PL_sv_undef)) {
2027 /* somebody else defined it for us */
2028 SvREFCNT_dec(LvTARG(sv));
2029 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2031 SvREFCNT_dec(mg->mg_obj);
2033 mg->mg_flags &= ~MGf_REFCOUNTED;
2038 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2043 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2045 PERL_UNUSED_ARG(mg);
2049 sv_setsv(LvTARG(sv), sv);
2050 SvSETMAGIC(LvTARG(sv));
2056 Perl_vivify_defelem(pTHX_ SV *sv)
2062 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2065 SV * const ahv = LvTARG(sv);
2066 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2069 if (!value || value == &PL_sv_undef)
2070 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2073 AV* const av = (AV*)LvTARG(sv);
2074 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2075 LvTARG(sv) = NULL; /* array can't be extended */
2077 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2078 if (!svp || (value = *svp) == &PL_sv_undef)
2079 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2082 SvREFCNT_inc_simple_void(value);
2083 SvREFCNT_dec(LvTARG(sv));
2086 SvREFCNT_dec(mg->mg_obj);
2088 mg->mg_flags &= ~MGf_REFCOUNTED;
2092 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2094 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2098 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_UNUSED_CONTEXT;
2107 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2109 PERL_UNUSED_ARG(mg);
2110 sv_unmagic(sv, PERL_MAGIC_bm);
2116 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2118 PERL_UNUSED_ARG(mg);
2119 sv_unmagic(sv, PERL_MAGIC_fm);
2125 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2127 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2129 if (uf && uf->uf_set)
2130 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2135 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2137 PERL_UNUSED_ARG(mg);
2138 sv_unmagic(sv, PERL_MAGIC_qr);
2143 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2146 regexp * const re = (regexp *)mg->mg_obj;
2147 PERL_UNUSED_ARG(sv);
2153 #ifdef USE_LOCALE_COLLATE
2155 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2158 * RenE<eacute> Descartes said "I think not."
2159 * and vanished with a faint plop.
2161 PERL_UNUSED_CONTEXT;
2162 PERL_UNUSED_ARG(sv);
2164 Safefree(mg->mg_ptr);
2170 #endif /* USE_LOCALE_COLLATE */
2172 /* Just clear the UTF-8 cache data. */
2174 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2176 PERL_UNUSED_CONTEXT;
2177 PERL_UNUSED_ARG(sv);
2178 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2180 mg->mg_len = -1; /* The mg_len holds the len cache. */
2185 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2188 register const char *s;
2191 switch (*mg->mg_ptr) {
2192 case '\001': /* ^A */
2193 sv_setsv(PL_bodytarget, sv);
2195 case '\003': /* ^C */
2196 PL_minus_c = (bool)SvIV(sv);
2199 case '\004': /* ^D */
2201 s = SvPV_nolen_const(sv);
2202 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2203 DEBUG_x(dump_all());
2205 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2208 case '\005': /* ^E */
2209 if (*(mg->mg_ptr+1) == '\0') {
2210 #ifdef MACOS_TRADITIONAL
2211 gMacPerl_OSErr = SvIV(sv);
2214 set_vaxc_errno(SvIV(sv));
2217 SetLastError( SvIV(sv) );
2220 os2_setsyserrno(SvIV(sv));
2222 /* will anyone ever use this? */
2223 SETERRNO(SvIV(sv), 4);
2229 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2231 SvREFCNT_dec(PL_encoding);
2232 if (SvOK(sv) || SvGMAGICAL(sv)) {
2233 PL_encoding = newSVsv(sv);
2240 case '\006': /* ^F */
2241 PL_maxsysfd = SvIV(sv);
2243 case '\010': /* ^H */
2244 PL_hints = SvIV(sv);
2246 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2247 Safefree(PL_inplace);
2248 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2250 case '\017': /* ^O */
2251 if (*(mg->mg_ptr+1) == '\0') {
2252 Safefree(PL_osname);
2255 TAINT_PROPER("assigning to $^O");
2256 PL_osname = savesvpv(sv);
2259 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2260 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2261 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2262 PL_compiling.cop_hints_hash
2263 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2264 sv_2mortal(newSVpvs("open")), sv);
2267 case '\020': /* ^P */
2268 PL_perldb = SvIV(sv);
2269 if (PL_perldb && !PL_DBsingle)
2272 case '\024': /* ^T */
2274 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2276 PL_basetime = (Time_t)SvIV(sv);
2279 case '\025': /* ^UTF8CACHE */
2280 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2281 PL_utf8cache = (signed char) sv_2iv(sv);
2284 case '\027': /* ^W & $^WARNING_BITS */
2285 if (*(mg->mg_ptr+1) == '\0') {
2286 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2288 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2289 | (i ? G_WARN_ON : G_WARN_OFF) ;
2292 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2293 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2294 if (!SvPOK(sv) && PL_localizing) {
2295 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2296 PL_compiling.cop_warnings = pWARN_NONE;
2301 int accumulate = 0 ;
2302 int any_fatals = 0 ;
2303 const char * const ptr = SvPV_const(sv, len) ;
2304 for (i = 0 ; i < len ; ++i) {
2305 accumulate |= ptr[i] ;
2306 any_fatals |= (ptr[i] & 0xAA) ;
2309 if (!specialWARN(PL_compiling.cop_warnings))
2310 PerlMemShared_free(PL_compiling.cop_warnings);
2311 PL_compiling.cop_warnings = pWARN_NONE;
2313 /* Yuck. I can't see how to abstract this: */
2314 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2315 WARN_ALL) && !any_fatals) {
2316 if (!specialWARN(PL_compiling.cop_warnings))
2317 PerlMemShared_free(PL_compiling.cop_warnings);
2318 PL_compiling.cop_warnings = pWARN_ALL;
2319 PL_dowarn |= G_WARN_ONCE ;
2323 const char *const p = SvPV_const(sv, len);
2325 PL_compiling.cop_warnings
2326 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2329 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2330 PL_dowarn |= G_WARN_ONCE ;
2338 if (PL_localizing) {
2339 if (PL_localizing == 1)
2340 SAVESPTR(PL_last_in_gv);
2342 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2343 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2346 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2347 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2348 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2351 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2352 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2353 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2356 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2359 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2360 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2361 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2364 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2368 IO * const io = GvIOp(PL_defoutgv);
2371 if ((SvIV(sv)) == 0)
2372 IoFLAGS(io) &= ~IOf_FLUSH;
2374 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2375 PerlIO *ofp = IoOFP(io);
2377 (void)PerlIO_flush(ofp);
2378 IoFLAGS(io) |= IOf_FLUSH;
2384 SvREFCNT_dec(PL_rs);
2385 PL_rs = newSVsv(sv);
2389 SvREFCNT_dec(PL_ors_sv);
2390 if (SvOK(sv) || SvGMAGICAL(sv)) {
2391 PL_ors_sv = newSVsv(sv);
2399 SvREFCNT_dec(PL_ofs_sv);
2400 if (SvOK(sv) || SvGMAGICAL(sv)) {
2401 PL_ofs_sv = newSVsv(sv);
2408 CopARYBASE_set(&PL_compiling, SvIV(sv));
2411 #ifdef COMPLEX_STATUS
2412 if (PL_localizing == 2) {
2413 PL_statusvalue = LvTARGOFF(sv);
2414 PL_statusvalue_vms = LvTARGLEN(sv);
2418 #ifdef VMSISH_STATUS
2420 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2423 STATUS_UNIX_EXIT_SET(SvIV(sv));
2428 # define PERL_VMS_BANG vaxc$errno
2430 # define PERL_VMS_BANG 0
2432 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2433 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2438 if (PL_delaymagic) {
2439 PL_delaymagic |= DM_RUID;
2440 break; /* don't do magic till later */
2443 (void)setruid((Uid_t)PL_uid);
2446 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2448 #ifdef HAS_SETRESUID
2449 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2451 if (PL_uid == PL_euid) { /* special case $< = $> */
2453 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2454 if (PL_uid != 0 && PerlProc_getuid() == 0)
2455 (void)PerlProc_setuid(0);
2457 (void)PerlProc_setuid(PL_uid);
2459 PL_uid = PerlProc_getuid();
2460 Perl_croak(aTHX_ "setruid() not implemented");
2465 PL_uid = PerlProc_getuid();
2466 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2470 if (PL_delaymagic) {
2471 PL_delaymagic |= DM_EUID;
2472 break; /* don't do magic till later */
2475 (void)seteuid((Uid_t)PL_euid);
2478 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2480 #ifdef HAS_SETRESUID
2481 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2483 if (PL_euid == PL_uid) /* special case $> = $< */
2484 PerlProc_setuid(PL_euid);
2486 PL_euid = PerlProc_geteuid();
2487 Perl_croak(aTHX_ "seteuid() not implemented");
2492 PL_euid = PerlProc_geteuid();
2493 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2497 if (PL_delaymagic) {
2498 PL_delaymagic |= DM_RGID;
2499 break; /* don't do magic till later */
2502 (void)setrgid((Gid_t)PL_gid);
2505 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2507 #ifdef HAS_SETRESGID
2508 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2510 if (PL_gid == PL_egid) /* special case $( = $) */
2511 (void)PerlProc_setgid(PL_gid);
2513 PL_gid = PerlProc_getgid();
2514 Perl_croak(aTHX_ "setrgid() not implemented");
2519 PL_gid = PerlProc_getgid();
2520 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2523 #ifdef HAS_SETGROUPS
2525 const char *p = SvPV_const(sv, len);
2526 Groups_t *gary = NULL;
2531 for (i = 0; i < NGROUPS; ++i) {
2532 while (*p && !isSPACE(*p))
2539 Newx(gary, i + 1, Groups_t);
2541 Renew(gary, i + 1, Groups_t);
2545 (void)setgroups(i, gary);
2548 #else /* HAS_SETGROUPS */
2550 #endif /* HAS_SETGROUPS */
2551 if (PL_delaymagic) {
2552 PL_delaymagic |= DM_EGID;
2553 break; /* don't do magic till later */
2556 (void)setegid((Gid_t)PL_egid);
2559 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2561 #ifdef HAS_SETRESGID
2562 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2564 if (PL_egid == PL_gid) /* special case $) = $( */
2565 (void)PerlProc_setgid(PL_egid);
2567 PL_egid = PerlProc_getegid();
2568 Perl_croak(aTHX_ "setegid() not implemented");
2573 PL_egid = PerlProc_getegid();
2574 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2577 PL_chopset = SvPV_force(sv,len);
2579 #ifndef MACOS_TRADITIONAL
2581 LOCK_DOLLARZERO_MUTEX;
2582 #ifdef HAS_SETPROCTITLE
2583 /* The BSDs don't show the argv[] in ps(1) output, they
2584 * show a string from the process struct and provide
2585 * the setproctitle() routine to manipulate that. */
2586 if (PL_origalen != 1) {
2587 s = SvPV_const(sv, len);
2588 # if __FreeBSD_version > 410001
2589 /* The leading "-" removes the "perl: " prefix,
2590 * but not the "(perl) suffix from the ps(1)
2591 * output, because that's what ps(1) shows if the
2592 * argv[] is modified. */
2593 setproctitle("-%s", s);
2594 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2595 /* This doesn't really work if you assume that
2596 * $0 = 'foobar'; will wipe out 'perl' from the $0
2597 * because in ps(1) output the result will be like
2598 * sprintf("perl: %s (perl)", s)
2599 * I guess this is a security feature:
2600 * one (a user process) cannot get rid of the original name.
2602 setproctitle("%s", s);
2606 #if defined(__hpux) && defined(PSTAT_SETCMD)
2607 if (PL_origalen != 1) {
2609 s = SvPV_const(sv, len);
2610 un.pst_command = (char *)s;
2611 pstat(PSTAT_SETCMD, un, len, 0, 0);
2614 if (PL_origalen > 1) {
2615 /* PL_origalen is set in perl_parse(). */
2616 s = SvPV_force(sv,len);
2617 if (len >= (STRLEN)PL_origalen-1) {
2618 /* Longer than original, will be truncated. We assume that
2619 * PL_origalen bytes are available. */
2620 Copy(s, PL_origargv[0], PL_origalen-1, char);
2623 /* Shorter than original, will be padded. */
2624 Copy(s, PL_origargv[0], len, char);
2625 PL_origargv[0][len] = 0;
2626 memset(PL_origargv[0] + len + 1,
2627 /* Is the space counterintuitive? Yes.
2628 * (You were expecting \0?)
2629 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2632 PL_origalen - len - 1);
2634 PL_origargv[0][PL_origalen-1] = 0;
2635 for (i = 1; i < PL_origargc; i++)
2638 UNLOCK_DOLLARZERO_MUTEX;
2646 Perl_whichsig(pTHX_ const char *sig)
2648 register char* const* sigv;
2649 PERL_UNUSED_CONTEXT;
2651 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2652 if (strEQ(sig,*sigv))
2653 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2655 if (strEQ(sig,"CHLD"))
2659 if (strEQ(sig,"CLD"))
2666 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2667 Perl_sighandler(int sig, ...)
2669 Perl_sighandler(int sig)
2672 #ifdef PERL_GET_SIG_CONTEXT
2673 dTHXa(PERL_GET_SIG_CONTEXT);
2680 SV * const tSv = PL_Sv;
2684 XPV * const tXpv = PL_Xpv;
2686 if (PL_savestack_ix + 15 <= PL_savestack_max)
2688 if (PL_markstack_ptr < PL_markstack_max - 2)
2690 if (PL_scopestack_ix < PL_scopestack_max - 3)
2693 if (!PL_psig_ptr[sig]) {
2694 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2699 /* Max number of items pushed there is 3*n or 4. We cannot fix
2700 infinity, so we fix 4 (in fact 5): */
2702 PL_savestack_ix += 5; /* Protect save in progress. */
2703 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2706 PL_markstack_ptr++; /* Protect mark. */
2708 PL_scopestack_ix += 1;
2709 /* sv_2cv is too complicated, try a simpler variant first: */
2710 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2711 || SvTYPE(cv) != SVt_PVCV) {
2713 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2716 if (!cv || !CvROOT(cv)) {
2717 if (ckWARN(WARN_SIGNAL))
2718 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2719 PL_sig_name[sig], (gv ? GvENAME(gv)
2726 if(PL_psig_name[sig]) {
2727 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2729 #if !defined(PERL_IMPLICIT_CONTEXT)
2733 sv = sv_newmortal();
2734 sv_setpv(sv,PL_sig_name[sig]);
2737 PUSHSTACKi(PERLSI_SIGNAL);
2740 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2742 struct sigaction oact;
2744 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2748 va_start(args, sig);
2749 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2752 SV *rv = newRV_noinc((SV*)sih);
2753 /* The siginfo fields signo, code, errno, pid, uid,
2754 * addr, status, and band are defined by POSIX/SUSv3. */
2755 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2756 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2757 #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. */
2758 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2759 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2760 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2761 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2762 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2763 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2767 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2776 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2779 if (SvTRUE(ERRSV)) {
2781 #ifdef HAS_SIGPROCMASK
2782 /* Handler "died", for example to get out of a restart-able read().
2783 * Before we re-do that on its behalf re-enable the signal which was
2784 * blocked by the system when we entered.
2788 sigaddset(&set,sig);
2789 sigprocmask(SIG_UNBLOCK, &set, NULL);
2791 /* Not clear if this will work */
2792 (void)rsignal(sig, SIG_IGN);
2793 (void)rsignal(sig, PL_csighandlerp);
2795 #endif /* !PERL_MICRO */
2796 Perl_die(aTHX_ NULL);
2800 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2804 PL_scopestack_ix -= 1;
2807 PL_op = myop; /* Apparently not needed... */
2809 PL_Sv = tSv; /* Restore global temporaries. */
2816 S_restore_magic(pTHX_ const void *p)
2819 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2820 SV* const sv = mgs->mgs_sv;
2825 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2827 #ifdef PERL_OLD_COPY_ON_WRITE
2828 /* While magic was saved (and off) sv_setsv may well have seen
2829 this SV as a prime candidate for COW. */
2831 sv_force_normal_flags(sv, 0);
2835 SvFLAGS(sv) |= mgs->mgs_flags;
2838 if (SvGMAGICAL(sv)) {
2839 /* downgrade public flags to private,
2840 and discard any other private flags */
2842 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2844 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2845 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2850 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2852 /* If we're still on top of the stack, pop us off. (That condition
2853 * will be satisfied if restore_magic was called explicitly, but *not*
2854 * if it's being called via leave_scope.)
2855 * The reason for doing this is that otherwise, things like sv_2cv()
2856 * may leave alloc gunk on the savestack, and some code
2857 * (e.g. sighandler) doesn't expect that...
2859 if (PL_savestack_ix == mgs->mgs_ss_ix)
2861 I32 popval = SSPOPINT;
2862 assert(popval == SAVEt_DESTRUCTOR_X);
2863 PL_savestack_ix -= 2;
2865 assert(popval == SAVEt_ALLOC);
2867 PL_savestack_ix -= popval;
2873 S_unwind_handler_stack(pTHX_ const void *p)
2876 const U32 flags = *(const U32*)p;
2879 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2880 #if !defined(PERL_IMPLICIT_CONTEXT)
2882 SvREFCNT_dec(PL_sig_sv);
2887 =for apidoc magic_sethint
2889 Triggered by a store to %^H, records the key/value pair to
2890 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2891 anything that would need a deep copy. Maybe we should warn if we find a
2897 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2900 assert(mg->mg_len == HEf_SVKEY);
2902 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2903 an alternative leaf in there, with PL_compiling.cop_hints being used if
2904 it's NULL. If needed for threads, the alternative could lock a mutex,
2905 or take other more complex action. */
2907 /* Something changed in %^H, so it will need to be restored on scope exit.
2908 Doing this here saves a lot of doing it manually in perl code (and
2909 forgetting to do it, and consequent subtle errors. */
2910 PL_hints |= HINT_LOCALIZE_HH;
2911 PL_compiling.cop_hints_hash
2912 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2913 (SV *)mg->mg_ptr, sv);
2918 =for apidoc magic_sethint
2920 Triggered by a delete from %^H, records the key to
2921 C<PL_compiling.cop_hints_hash>.
2926 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2929 PERL_UNUSED_ARG(sv);
2931 assert(mg->mg_len == HEf_SVKEY);
2933 PERL_UNUSED_ARG(sv);
2935 PL_hints |= HINT_LOCALIZE_HH;
2936 PL_compiling.cop_hints_hash
2937 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2938 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2944 * c-indentation-style: bsd
2946 * indent-tabs-mode: t
2949 * ex: set ts=8 sts=4 sw=4 noet: