3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
20 "Magic" is special data attached to SV structures in order to give them
21 "magical" properties. When any Perl code tries to read from, or assign to,
22 an SV marked as magical, it calls the 'get' or 'set' function associated
23 with that SV's magic. A get is called prior to reading an SV, in order to
24 give it a chance to update its internal value (get on $. writes the line
25 number of the last read filehandle into the SV's IV slot), while
26 set is called after an SV has been written to, in order to allow it to make
27 use of its changed value (set on $/ copies the SV's new value to the
28 PL_rs global variable).
30 Magic is implemented as a linked list of MAGIC structures attached to the
31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
32 of functions that implement the get(), set(), length() etc functions,
33 plus space for some flags and pointers. For example, a tied variable has
34 a MAGIC structure that contains a pointer to the object associated with the
45 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
51 #if defined(HAS_SETGROUPS)
58 # include <sys/pstat.h>
61 #ifdef HAS_PRCTL_SET_NAME
62 # include <sys/prctl.h>
65 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
66 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
68 Signal_t Perl_csighandler(int sig);
72 /* Missing protos on LynxOS */
73 void setruid(uid_t id);
74 void seteuid(uid_t id);
75 void setrgid(uid_t id);
76 void setegid(uid_t id);
80 * Pre-magic setup and post-magic takedown.
81 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
91 /* MGS is typedef'ed to struct magic_state in perl.h */
94 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
100 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
102 assert(SvMAGICAL(sv));
104 /* we shouldn't really be called here with RC==0, but it can sometimes
105 * happen via mg_clear() (which also shouldn't be called when RC==0,
106 * but it can happen). Handle this case gracefully(ish) by not RC++
107 * and thus avoiding the resultant double free */
108 if (SvREFCNT(sv) > 0) {
109 /* guard against sv getting freed midway through the mg clearing,
110 * by holding a private reference for the duration. */
111 SvREFCNT_inc_simple_void_NN(sv);
115 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
117 mgs = SSPTR(mgs_ix, MGS*);
119 mgs->mgs_magical = SvMAGICAL(sv);
120 mgs->mgs_readonly = SvREADONLY(sv) != 0;
121 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
122 mgs->mgs_bumped = bumped;
124 SvFLAGS(sv) &= ~flags;
128 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
131 =for apidoc mg_magical
133 Turns on the magical status of an SV. See C<sv_magic>.
139 Perl_mg_magical(SV *sv)
142 PERL_ARGS_ASSERT_MG_MAGICAL;
145 if ((mg = SvMAGIC(sv))) {
147 const MGVTBL* const vtbl = mg->mg_virtual;
149 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
156 } while ((mg = mg->mg_moremagic));
157 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
165 Do magic before a value is retrieved from the SV. The type of SV must
166 be >= SVt_PVMG. See C<sv_magic>.
172 Perl_mg_get(pTHX_ SV *sv)
175 const I32 mgs_ix = SSNEW(sizeof(MGS));
178 MAGIC *newmg, *head, *cur, *mg;
180 PERL_ARGS_ASSERT_MG_GET;
182 if (PL_localizing == 1 && sv == DEFSV) return 0;
184 /* We must call svt_get(sv, mg) for each valid entry in the linked
185 list of magic. svt_get() may delete the current entry, add new
186 magic to the head of the list, or upgrade the SV. AMS 20010810 */
188 newmg = cur = head = mg = SvMAGIC(sv);
190 const MGVTBL * const vtbl = mg->mg_virtual;
191 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
193 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
195 /* taint's mg get is so dumb it doesn't need flag saving */
196 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
197 save_magic(mgs_ix, sv);
201 vtbl->svt_get(aTHX_ sv, mg);
203 /* guard against magic having been deleted - eg FETCH calling
206 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
210 /* recalculate flags if this entry was deleted. */
211 if (mg->mg_flags & MGf_GSKIP)
212 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
214 else if (vtbl == &PL_vtbl_utf8) {
215 /* get-magic can reallocate the PV */
216 magic_setutf8(sv, mg);
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
231 /* Were any new entries added? */
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
241 restore_magic(INT2PTR(void *, (IV)mgs_ix));
249 Do magic after a value is assigned to the SV. See C<sv_magic>.
255 Perl_mg_set(pTHX_ SV *sv)
258 const I32 mgs_ix = SSNEW(sizeof(MGS));
262 PERL_ARGS_ASSERT_MG_SET;
264 if (PL_localizing == 2 && sv == DEFSV) return 0;
266 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
268 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
269 const MGVTBL* vtbl = mg->mg_virtual;
270 nextmg = mg->mg_moremagic; /* it may delete itself */
271 if (mg->mg_flags & MGf_GSKIP) {
272 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
273 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
275 if (PL_localizing == 2
276 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
278 if (vtbl && vtbl->svt_set)
279 vtbl->svt_set(aTHX_ sv, mg);
282 restore_magic(INT2PTR(void*, (IV)mgs_ix));
287 =for apidoc mg_length
289 Reports on the SV's length in bytes, calling length magic if available,
290 but does not set the UTF8 flag on the sv. It will fall back to 'get'
291 magic if there is no 'length' magic, but with no indication as to
292 whether it called 'get' magic. It assumes the sv is a PVMG or
293 higher. Use sv_len() instead.
299 Perl_mg_length(pTHX_ SV *sv)
305 PERL_ARGS_ASSERT_MG_LENGTH;
307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
308 const MGVTBL * const vtbl = mg->mg_virtual;
309 if (vtbl && vtbl->svt_len) {
310 const I32 mgs_ix = SSNEW(sizeof(MGS));
311 save_magic(mgs_ix, sv);
312 /* omit MGf_GSKIP -- not changed here */
313 len = vtbl->svt_len(aTHX_ sv, mg);
314 restore_magic(INT2PTR(void*, (IV)mgs_ix));
319 (void)SvPV_const(sv, len);
324 Perl_mg_size(pTHX_ SV *sv)
328 PERL_ARGS_ASSERT_MG_SIZE;
330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
331 const MGVTBL* const vtbl = mg->mg_virtual;
332 if (vtbl && vtbl->svt_len) {
333 const I32 mgs_ix = SSNEW(sizeof(MGS));
335 save_magic(mgs_ix, sv);
336 /* omit MGf_GSKIP -- not changed here */
337 len = vtbl->svt_len(aTHX_ sv, mg);
338 restore_magic(INT2PTR(void*, (IV)mgs_ix));
345 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
349 Perl_croak(aTHX_ "Size magic not implemented");
352 NOT_REACHED; /* NOTREACHED */
358 Clear something magical that the SV represents. See C<sv_magic>.
364 Perl_mg_clear(pTHX_ SV *sv)
366 const I32 mgs_ix = SSNEW(sizeof(MGS));
370 PERL_ARGS_ASSERT_MG_CLEAR;
372 save_magic(mgs_ix, sv);
374 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
375 const MGVTBL* const vtbl = mg->mg_virtual;
376 /* omit GSKIP -- never set here */
378 nextmg = mg->mg_moremagic; /* it may delete itself */
380 if (vtbl && vtbl->svt_clear)
381 vtbl->svt_clear(aTHX_ sv, mg);
384 restore_magic(INT2PTR(void*, (IV)mgs_ix));
389 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
396 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
398 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
399 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
411 Finds the magic pointer for type matching the SV. See C<sv_magic>.
417 Perl_mg_find(const SV *sv, int type)
419 return S_mg_findext_flags(sv, type, NULL, 0);
423 =for apidoc mg_findext
425 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
432 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
434 return S_mg_findext_flags(sv, type, vtbl, 1);
438 Perl_mg_find_mglob(pTHX_ SV *sv)
440 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
441 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
442 /* This sv is only a delegate. //g magic must be attached to
447 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
448 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
455 Copies the magic from one SV to another. See C<sv_magic>.
461 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
466 PERL_ARGS_ASSERT_MG_COPY;
468 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
469 const MGVTBL* const vtbl = mg->mg_virtual;
470 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
471 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
474 const char type = mg->mg_type;
475 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
477 (type == PERL_MAGIC_tied)
479 : (type == PERL_MAGIC_regdata && mg->mg_obj)
482 toLOWER(type), key, klen);
491 =for apidoc mg_localize
493 Copy some of the magic from an existing SV to new localized version of that
494 SV. Container magic (eg %ENV, $1, tie)
495 gets copied, value magic doesn't (eg
498 If setmagic is false then no set magic will be called on the new (empty) SV.
499 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
500 and that will handle the magic.
506 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
511 PERL_ARGS_ASSERT_MG_LOCALIZE;
516 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
517 const MGVTBL* const vtbl = mg->mg_virtual;
518 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
521 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
522 (void)vtbl->svt_local(aTHX_ nsv, mg);
524 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
525 mg->mg_ptr, mg->mg_len);
527 /* container types should remain read-only across localization */
528 SvFLAGS(nsv) |= SvREADONLY(sv);
531 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
532 SvFLAGS(nsv) |= SvMAGICAL(sv);
541 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
543 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
545 const MGVTBL* const vtbl = mg->mg_virtual;
546 if (vtbl && vtbl->svt_free)
547 vtbl->svt_free(aTHX_ sv, mg);
548 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
549 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
550 Safefree(mg->mg_ptr);
551 else if (mg->mg_len == HEf_SVKEY)
552 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
554 if (mg->mg_flags & MGf_REFCOUNTED)
555 SvREFCNT_dec(mg->mg_obj);
562 Free any magic storage used by the SV. See C<sv_magic>.
568 Perl_mg_free(pTHX_ SV *sv)
573 PERL_ARGS_ASSERT_MG_FREE;
575 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
576 moremagic = mg->mg_moremagic;
577 mg_free_struct(sv, mg);
578 SvMAGIC_set(sv, moremagic);
580 SvMAGIC_set(sv, NULL);
586 =for apidoc Am|void|mg_free_type|SV *sv|int how
588 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
594 Perl_mg_free_type(pTHX_ SV *sv, int how)
596 MAGIC *mg, *prevmg, *moremg;
597 PERL_ARGS_ASSERT_MG_FREE_TYPE;
598 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
600 moremg = mg->mg_moremagic;
601 if (mg->mg_type == how) {
602 /* temporarily move to the head of the magic chain, in case
603 custom free code relies on this historical aspect of mg_free */
605 prevmg->mg_moremagic = moremg;
606 mg->mg_moremagic = SvMAGIC(sv);
609 newhead = mg->mg_moremagic;
610 mg_free_struct(sv, mg);
611 SvMAGIC_set(sv, newhead);
621 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
626 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
629 const REGEXP * const rx = PM_GETRE(PL_curpm);
631 if (mg->mg_obj) { /* @+ */
632 /* return the number possible */
633 return RX_NPARENS(rx);
635 I32 paren = RX_LASTPAREN(rx);
637 /* return the last filled */
639 && (RX_OFFS(rx)[paren].start == -1
640 || RX_OFFS(rx)[paren].end == -1) )
653 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
657 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
660 const REGEXP * const rx = PM_GETRE(PL_curpm);
662 const I32 paren = mg->mg_len;
667 if (paren <= (I32)RX_NPARENS(rx) &&
668 (s = RX_OFFS(rx)[paren].start) != -1 &&
669 (t = RX_OFFS(rx)[paren].end) != -1)
672 if (mg->mg_obj) /* @+ */
677 if (RX_MATCH_UTF8(rx)) {
678 const char * const b = RX_SUBBEG(rx);
680 i = RX_SUBCOFFSET(rx) +
682 (U8*)(b-RX_SUBOFFSET(rx)+i));
697 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
699 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
703 Perl_croak_no_modify();
704 NORETURN_FUNCTION_END;
707 #define SvRTRIM(sv) STMT_START { \
709 STRLEN len = SvCUR(sv); \
710 char * const p = SvPVX(sv); \
711 while (len > 0 && isSPACE(p[len-1])) \
713 SvCUR_set(sv, len); \
719 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
721 PERL_ARGS_ASSERT_EMULATE_COP_IO;
723 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
724 sv_setsv(sv, &PL_sv_undef);
728 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
729 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
734 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
735 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
743 S_fixup_errno_string(pTHX_ SV* sv)
745 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
748 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
752 if(strEQ(SvPVX(sv), "")) {
753 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
757 /* In some locales the error string may come back as UTF-8, in which
758 * case we should turn on that flag. This didn't use to happen, and to
759 * avoid as many possible backward compatibility issues as possible, we
760 * don't turn on the flag unless we have to. So the flag stays off for
761 * an entirely ASCII string. We assume that if the string looks like
762 * UTF-8, it really is UTF-8: "text in any other encoding that uses
763 * bytes with the high bit set is extremely unlikely to pass a UTF-8
764 * validity test" (http://en.wikipedia.org/wiki/Charset_detection).
765 * There is a potential that we will get it wrong however, especially
766 * on short error message text. (If it turns out to be necessary, we
767 * could also keep track if the current LC_MESSAGES locale is UTF-8) */
768 if (! IN_BYTES /* respect 'use bytes' */
769 && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
770 && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
783 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
787 const char *s = NULL;
789 const char * const remaining = mg->mg_ptr + 1;
792 PERL_ARGS_ASSERT_MAGIC_GET;
796 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
798 CALLREG_NUMBUF_FETCH(rx,paren,sv);
800 sv_setsv(sv,&PL_sv_undef);
805 nextchar = *remaining;
806 switch (*mg->mg_ptr) {
807 case '\001': /* ^A */
808 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
809 else sv_setsv(sv, &PL_sv_undef);
810 if (SvTAINTED(PL_bodytarget))
813 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
814 if (nextchar == '\0') {
815 sv_setiv(sv, (IV)PL_minus_c);
817 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
818 sv_setiv(sv, (IV)STATUS_NATIVE);
822 case '\004': /* ^D */
823 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
825 case '\005': /* ^E */
826 if (nextchar != '\0') {
827 if (strEQ(remaining, "NCODING"))
828 sv_setsv(sv, PL_encoding);
832 #if defined(VMS) || defined(OS2) || defined(WIN32)
836 $DESCRIPTOR(msgdsc,msg);
837 sv_setnv(sv,(NV) vaxc$errno);
838 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
839 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
844 if (!(_emx_env & 0x200)) { /* Under DOS */
845 sv_setnv(sv, (NV)errno);
846 sv_setpv(sv, errno ? my_strerror(errno) : "");
848 if (errno != errno_isOS2) {
849 const int tmp = _syserrno();
850 if (tmp) /* 2nd call to _syserrno() makes it 0 */
853 sv_setnv(sv, (NV)Perl_rc);
854 sv_setpv(sv, os2error(Perl_rc));
856 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
857 fixup_errno_string(sv);
859 # elif defined(WIN32)
861 const DWORD dwErr = GetLastError();
862 sv_setnv(sv, (NV)dwErr);
864 PerlProc_GetOSError(sv, dwErr);
865 fixup_errno_string(sv);
872 # error Missing code for platform
875 SvNOK_on(sv); /* what a wonderful hack! */
877 #endif /* End of platforms with special handling for $^E; others just fall
884 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
886 sv_setnv(sv, (NV)errno);
889 if (errno == errno_isOS2 || errno == errno_isOS2_set)
890 sv_setpv(sv, os2error(Perl_rc));
898 /* Strerror can return NULL on some platforms, which will
899 * result in 'sv' not being considered SvOK. The SvNOK_on()
900 * below will cause just the number part to be valid */
901 sv_setpv(sv, my_strerror(errno));
903 fixup_errno_string(sv);
910 SvNOK_on(sv); /* what a wonderful hack! */
913 case '\006': /* ^F */
914 sv_setiv(sv, (IV)PL_maxsysfd);
916 case '\007': /* ^GLOBAL_PHASE */
917 if (strEQ(remaining, "LOBAL_PHASE")) {
918 sv_setpvn(sv, PL_phase_names[PL_phase],
919 strlen(PL_phase_names[PL_phase]));
922 case '\010': /* ^H */
923 sv_setiv(sv, (IV)PL_hints);
925 case '\011': /* ^I */ /* NOT \t in EBCDIC */
926 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
928 case '\014': /* ^LAST_FH */
929 if (strEQ(remaining, "AST_FH")) {
931 assert(isGV_with_GP(PL_last_in_gv));
932 SV_CHECK_THINKFIRST_COW_DROP(sv);
933 prepare_SV_for_RV(sv);
935 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
939 else sv_setsv_nomg(sv, NULL);
942 case '\017': /* ^O & ^OPEN */
943 if (nextchar == '\0') {
944 sv_setpv(sv, PL_osname);
947 else if (strEQ(remaining, "PEN")) {
948 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
952 sv_setiv(sv, (IV)PL_perldb);
954 case '\023': /* ^S */
956 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
959 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
964 case '\024': /* ^T */
965 if (nextchar == '\0') {
967 sv_setnv(sv, PL_basetime);
969 sv_setiv(sv, (IV)PL_basetime);
972 else if (strEQ(remaining, "AINT"))
973 sv_setiv(sv, TAINTING_get
974 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
977 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
978 if (strEQ(remaining, "NICODE"))
979 sv_setuv(sv, (UV) PL_unicode);
980 else if (strEQ(remaining, "TF8LOCALE"))
981 sv_setuv(sv, (UV) PL_utf8locale);
982 else if (strEQ(remaining, "TF8CACHE"))
983 sv_setiv(sv, (IV) PL_utf8cache);
985 case '\027': /* ^W & $^WARNING_BITS */
986 if (nextchar == '\0')
987 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
988 else if (strEQ(remaining, "ARNING_BITS")) {
989 if (PL_compiling.cop_warnings == pWARN_NONE) {
990 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
992 else if (PL_compiling.cop_warnings == pWARN_STD) {
993 sv_setsv(sv, &PL_sv_undef);
996 else if (PL_compiling.cop_warnings == pWARN_ALL) {
997 /* Get the bit mask for $warnings::Bits{all}, because
998 * it could have been extended by warnings::register */
999 HV * const bits = get_hv("warnings::Bits", 0);
1000 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
1002 sv_copypv(sv, *bits_all);
1004 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1007 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1008 *PL_compiling.cop_warnings);
1013 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1014 paren = RX_LASTPAREN(rx);
1016 goto do_numbuf_fetch;
1018 sv_setsv(sv,&PL_sv_undef);
1020 case '\016': /* ^N */
1021 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1022 paren = RX_LASTCLOSEPAREN(rx);
1024 goto do_numbuf_fetch;
1026 sv_setsv(sv,&PL_sv_undef);
1029 if (GvIO(PL_last_in_gv)) {
1030 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1035 sv_setiv(sv, (IV)STATUS_CURRENT);
1036 #ifdef COMPLEX_STATUS
1037 SvUPGRADE(sv, SVt_PVLV);
1038 LvTARGOFF(sv) = PL_statusvalue;
1039 LvTARGLEN(sv) = PL_statusvalue_vms;
1044 if (GvIOp(PL_defoutgv))
1045 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1049 sv_setpv(sv,GvENAME(PL_defoutgv));
1050 sv_catpvs(sv,"_TOP");
1054 if (GvIOp(PL_defoutgv))
1055 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1057 s = GvENAME(PL_defoutgv);
1061 if (GvIO(PL_defoutgv))
1062 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1065 if (GvIO(PL_defoutgv))
1066 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1069 if (GvIO(PL_defoutgv))
1070 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1080 if (GvIO(PL_defoutgv))
1081 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1085 sv_copypv(sv, PL_ors_sv);
1087 sv_setsv(sv, &PL_sv_undef);
1091 IV const pid = (IV)PerlProc_getpid();
1092 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1093 /* never set manually, or at least not since last fork */
1095 /* never unsafe, even if reading in a tainted expression */
1098 /* else a value has been assigned manually, so do nothing */
1102 sv_setuid(sv, PerlProc_getuid());
1105 sv_setuid(sv, PerlProc_geteuid());
1108 sv_setgid(sv, PerlProc_getgid());
1111 sv_setgid(sv, PerlProc_getegid());
1113 #ifdef HAS_GETGROUPS
1115 Groups_t *gary = NULL;
1117 I32 num_groups = getgroups(0, gary);
1118 if (num_groups > 0) {
1119 Newx(gary, num_groups, Groups_t);
1120 num_groups = getgroups(num_groups, gary);
1121 for (i = 0; i < num_groups; i++)
1122 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1126 (void)SvIOK_on(sv); /* what a wonderful hack! */
1136 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1138 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1140 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1142 if (uf && uf->uf_val)
1143 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1148 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1151 STRLEN len = 0, klen;
1152 const char * const key = MgPV_const(mg,klen);
1155 PERL_ARGS_ASSERT_MAGIC_SETENV;
1159 /* defined environment variables are byte strings; unfortunately
1160 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1161 (void)SvPV_force_nomg_nolen(sv);
1162 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1164 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1170 my_setenv(key, s); /* does the deed */
1172 #ifdef DYNAMIC_ENV_FETCH
1173 /* We just undefd an environment var. Is a replacement */
1174 /* waiting in the wings? */
1176 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1178 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1182 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1183 /* And you'll never guess what the dog had */
1184 /* in its mouth... */
1186 MgTAINTEDDIR_off(mg);
1188 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1189 char pathbuf[256], eltbuf[256], *cp, *elt;
1192 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1194 do { /* DCL$PATH may be a search list */
1195 while (1) { /* as may dev portion of any element */
1196 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1197 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1198 cando_by_name(S_IWUSR,0,elt) ) {
1199 MgTAINTEDDIR_on(mg);
1203 if ((cp = strchr(elt, ':')) != NULL)
1205 if (my_trnlnm(elt, eltbuf, j++))
1211 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1214 if (s && klen == 4 && strEQ(key,"PATH")) {
1215 const char * const strend = s + len;
1217 while (s < strend) {
1221 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1222 const char path_sep = '|';
1224 const char path_sep = ':';
1226 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1227 s, strend, path_sep, &i);
1229 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1231 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1233 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1235 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1236 MgTAINTEDDIR_on(mg);
1242 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1248 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1250 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1251 PERL_UNUSED_ARG(sv);
1252 my_setenv(MgPV_nolen_const(mg),NULL);
1257 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1260 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1261 PERL_UNUSED_ARG(mg);
1263 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1265 if (PL_localizing) {
1268 hv_iterinit(MUTABLE_HV(sv));
1269 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1271 my_setenv(hv_iterkey(entry, &keylen),
1272 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1280 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1283 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1284 PERL_UNUSED_ARG(sv);
1285 PERL_UNUSED_ARG(mg);
1287 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1295 #ifdef HAS_SIGPROCMASK
1297 restore_sigmask(pTHX_ SV *save_sv)
1299 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1300 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1304 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1307 /* Are we fetching a signal entry? */
1308 int i = (I16)mg->mg_private;
1310 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1314 const char * sig = MgPV_const(mg, siglen);
1315 mg->mg_private = i = whichsig_pvn(sig, siglen);
1320 sv_setsv(sv,PL_psig_ptr[i]);
1322 Sighandler_t sigstate = rsignal_state(i);
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1327 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1328 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1331 /* cache state so we don't fetch it again */
1332 if(sigstate == (Sighandler_t) SIG_IGN)
1333 sv_setpvs(sv,"IGNORE");
1335 sv_setsv(sv,&PL_sv_undef);
1336 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1343 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1345 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1347 magic_setsig(NULL, mg);
1348 return sv_unmagic(sv, mg->mg_type);
1352 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1353 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1355 Perl_csighandler(int sig)
1358 #ifdef PERL_GET_SIG_CONTEXT
1359 dTHXa(PERL_GET_SIG_CONTEXT);
1363 #if defined(__cplusplus) && defined(__GNUC__)
1364 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1365 * parameters would be warned about. */
1366 PERL_UNUSED_ARG(sip);
1367 PERL_UNUSED_ARG(uap);
1369 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1370 (void) rsignal(sig, PL_csighandlerp);
1371 if (PL_sig_ignoring[sig]) return;
1373 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1374 if (PL_sig_defaulting[sig])
1375 #ifdef KILL_BY_SIGPRC
1376 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1391 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1392 /* Call the perl level handler now--
1393 * with risk we may be in malloc() or being destructed etc. */
1394 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1395 (*PL_sighandlerp)(sig, NULL, NULL);
1397 (*PL_sighandlerp)(sig);
1400 if (!PL_psig_pend) return;
1401 /* Set a flag to say this signal is pending, that is awaiting delivery after
1402 * the current Perl opcode completes */
1403 PL_psig_pend[sig]++;
1405 #ifndef SIG_PENDING_DIE_COUNT
1406 # define SIG_PENDING_DIE_COUNT 120
1408 /* Add one to say _a_ signal is pending */
1409 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1410 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1411 (unsigned long)SIG_PENDING_DIE_COUNT);
1415 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1417 Perl_csighandler_init(void)
1420 if (PL_sig_handlers_initted) return;
1422 for (sig = 1; sig < SIG_SIZE; sig++) {
1423 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1425 PL_sig_defaulting[sig] = 1;
1426 (void) rsignal(sig, PL_csighandlerp);
1428 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1429 PL_sig_ignoring[sig] = 0;
1432 PL_sig_handlers_initted = 1;
1436 #if defined HAS_SIGPROCMASK
1438 unblock_sigmask(pTHX_ void* newset)
1440 PERL_UNUSED_CONTEXT;
1441 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1446 Perl_despatch_signals(pTHX)
1451 for (sig = 1; sig < SIG_SIZE; sig++) {
1452 if (PL_psig_pend[sig]) {
1454 #ifdef HAS_SIGPROCMASK
1455 /* From sigaction(2) (FreeBSD man page):
1456 * | Signal routines normally execute with the signal that
1457 * | caused their invocation blocked, but other signals may
1459 * Emulation of this behavior (from within Perl) is enabled
1463 sigset_t newset, oldset;
1465 sigemptyset(&newset);
1466 sigaddset(&newset, sig);
1467 sigprocmask(SIG_BLOCK, &newset, &oldset);
1468 was_blocked = sigismember(&oldset, sig);
1470 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1472 SAVEFREESV(save_sv);
1473 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1476 PL_psig_pend[sig] = 0;
1477 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1478 (*PL_sighandlerp)(sig, NULL, NULL);
1480 (*PL_sighandlerp)(sig);
1482 #ifdef HAS_SIGPROCMASK
1491 /* sv of NULL signifies that we're acting as magic_clearsig. */
1493 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1498 /* Need to be careful with SvREFCNT_dec(), because that can have side
1499 * effects (due to closures). We must make sure that the new disposition
1500 * is in place before it is called.
1504 #ifdef HAS_SIGPROCMASK
1508 const char *s = MgPV_const(mg,len);
1510 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1513 if (memEQs(s, len, "__DIE__"))
1515 else if (memEQs(s, len, "__WARN__")
1516 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1517 /* Merge the existing behaviours, which are as follows:
1518 magic_setsig, we always set svp to &PL_warnhook
1519 (hence we always change the warnings handler)
1520 For magic_clearsig, we don't change the warnings handler if it's
1521 set to the &PL_warnhook. */
1524 SV *tmp = sv_newmortal();
1525 Perl_croak(aTHX_ "No such hook: %s",
1526 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1530 if (*svp != PERL_WARNHOOK_FATAL)
1536 i = (I16)mg->mg_private;
1538 i = whichsig_pvn(s, len); /* ...no, a brick */
1539 mg->mg_private = (U16)i;
1543 SV *tmp = sv_newmortal();
1544 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1545 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1549 #ifdef HAS_SIGPROCMASK
1550 /* Avoid having the signal arrive at a bad time, if possible. */
1553 sigprocmask(SIG_BLOCK, &set, &save);
1555 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1556 SAVEFREESV(save_sv);
1557 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1560 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1561 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1563 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1564 PL_sig_ignoring[i] = 0;
1566 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1567 PL_sig_defaulting[i] = 0;
1569 to_dec = PL_psig_ptr[i];
1571 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1572 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1574 /* Signals don't change name during the program's execution, so once
1575 they're cached in the appropriate slot of PL_psig_name, they can
1578 Ideally we'd find some way of making SVs at (C) compile time, or
1579 at least, doing most of the work. */
1580 if (!PL_psig_name[i]) {
1581 PL_psig_name[i] = newSVpvn(s, len);
1582 SvREADONLY_on(PL_psig_name[i]);
1585 SvREFCNT_dec(PL_psig_name[i]);
1586 PL_psig_name[i] = NULL;
1587 PL_psig_ptr[i] = NULL;
1590 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1592 (void)rsignal(i, PL_csighandlerp);
1595 *svp = SvREFCNT_inc_simple_NN(sv);
1597 if (sv && SvOK(sv)) {
1598 s = SvPV_force(sv, len);
1602 if (sv && memEQs(s, len,"IGNORE")) {
1604 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1605 PL_sig_ignoring[i] = 1;
1606 (void)rsignal(i, PL_csighandlerp);
1608 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1612 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1614 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1615 PL_sig_defaulting[i] = 1;
1616 (void)rsignal(i, PL_csighandlerp);
1618 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1624 * We should warn if HINT_STRICT_REFS, but without
1625 * access to a known hint bit in a known OP, we can't
1626 * tell whether HINT_STRICT_REFS is in force or not.
1628 if (!strchr(s,':') && !strchr(s,'\''))
1629 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1632 (void)rsignal(i, PL_csighandlerp);
1634 *svp = SvREFCNT_inc_simple_NN(sv);
1638 #ifdef HAS_SIGPROCMASK
1642 SvREFCNT_dec(to_dec);
1645 #endif /* !PERL_MICRO */
1648 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1651 PERL_ARGS_ASSERT_MAGIC_SETISA;
1652 PERL_UNUSED_ARG(sv);
1654 /* Skip _isaelem because _isa will handle it shortly */
1655 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1658 return magic_clearisa(NULL, mg);
1661 /* sv of NULL signifies that we're acting as magic_setisa. */
1663 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1668 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1670 /* Bail out if destruction is going on */
1671 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1674 av_clear(MUTABLE_AV(sv));
1676 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1677 /* This occurs with setisa_elem magic, which calls this
1679 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1682 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1683 SV **svp = AvARRAY((AV *)mg->mg_obj);
1684 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1686 stash = GvSTASH((GV *)*svp++);
1687 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1694 (const GV *)mg->mg_obj
1697 /* The stash may have been detached from the symbol table, so check its
1698 name before doing anything. */
1699 if (stash && HvENAME_get(stash))
1700 mro_isa_changed_in(stash);
1706 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1708 HV * const hv = MUTABLE_HV(LvTARG(sv));
1711 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1712 PERL_UNUSED_ARG(mg);
1715 (void) hv_iterinit(hv);
1716 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1719 while (hv_iternext(hv))
1724 sv_setiv(sv, (IV)i);
1729 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1731 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1732 PERL_UNUSED_ARG(mg);
1734 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1740 =for apidoc magic_methcall
1742 Invoke a magic method (like FETCH).
1744 C<sv> and C<mg> are the tied thingy and the tie magic.
1746 C<meth> is the name of the method to call.
1748 C<argc> is the number of args (in addition to $self) to pass to the method.
1750 The C<flags> can be:
1752 G_DISCARD invoke method with G_DISCARD flag and don't
1754 G_UNDEF_FILL fill the stack with argc pointers to
1757 The arguments themselves are any values following the C<flags> argument.
1759 Returns the SV (if any) returned by the method, or NULL on failure.
1766 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1773 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1777 if (flags & G_WRITING_TO_STDERR) {
1781 SAVESPTR(PL_stderrgv);
1785 PUSHSTACKi(PERLSI_MAGIC);
1789 PUSHs(SvTIED_obj(sv, mg));
1790 if (flags & G_UNDEF_FILL) {
1792 PUSHs(&PL_sv_undef);
1794 } else if (argc > 0) {
1796 va_start(args, argc);
1799 SV *const sv = va_arg(args, SV *);
1806 if (flags & G_DISCARD) {
1807 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1810 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1811 ret = *PL_stack_sp--;
1814 if (flags & G_WRITING_TO_STDERR)
1820 /* wrapper for magic_methcall that creates the first arg */
1823 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1829 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1832 if (mg->mg_len >= 0) {
1833 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1835 else if (mg->mg_len == HEf_SVKEY)
1836 arg1 = MUTABLE_SV(mg->mg_ptr);
1838 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1839 arg1 = newSViv((IV)(mg->mg_len));
1843 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1845 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1849 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1854 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1856 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1863 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1865 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1867 if (mg->mg_type == PERL_MAGIC_tiedelem)
1868 mg->mg_flags |= MGf_GSKIP;
1869 magic_methpack(sv,mg,SV_CONST(FETCH));
1874 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1880 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1882 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1883 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1884 * public flags indicate its value based on copying from $val. Doing
1885 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1886 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1887 * wrong if $val happened to be tainted, as sv hasn't got magic
1888 * enabled, even though taint magic is in the chain. In which case,
1889 * fake up a temporary tainted value (this is easier than temporarily
1890 * re-enabling magic on sv). */
1892 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1893 && (tmg->mg_len & 1))
1895 val = sv_mortalcopy(sv);
1901 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
1906 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1908 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1910 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1911 return magic_methpack(sv,mg,SV_CONST(DELETE));
1916 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1922 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1924 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
1926 retval = SvIV(retsv)-1;
1928 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1930 return (U32) retval;
1934 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1938 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1940 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
1945 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1950 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1952 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1953 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
1960 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1962 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1964 return magic_methpack(sv,mg,SV_CONST(EXISTS));
1968 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1972 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1973 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1975 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1977 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1979 if (HvEITER_get(hv))
1980 /* we are in an iteration so the hash cannot be empty */
1982 /* no xhv_eiter so now use FIRSTKEY */
1983 key = sv_newmortal();
1984 magic_nextpack(MUTABLE_SV(hv), mg, key);
1985 HvEITER_set(hv, NULL); /* need to reset iterator */
1986 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1989 /* there is a SCALAR method that we can call */
1990 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
1992 retval = &PL_sv_undef;
1997 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2002 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2004 /* The magic ptr/len for the debugger's hash should always be an SV. */
2005 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2006 Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
2007 (IV)mg->mg_len, mg->mg_ptr);
2010 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2011 setting/clearing debugger breakpoints is not a hot path. */
2012 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2013 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2015 if (svp && SvIOKp(*svp)) {
2016 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2018 #ifdef PERL_DEBUG_READONLY_OPS
2019 Slab_to_rw(OpSLAB(o));
2021 /* set or clear breakpoint in the relevant control op */
2023 o->op_flags |= OPf_SPECIAL;
2025 o->op_flags &= ~OPf_SPECIAL;
2026 #ifdef PERL_DEBUG_READONLY_OPS
2027 Slab_to_ro(OpSLAB(o));
2035 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2038 AV * const obj = MUTABLE_AV(mg->mg_obj);
2040 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2043 sv_setiv(sv, AvFILL(obj));
2051 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2054 AV * const obj = MUTABLE_AV(mg->mg_obj);
2056 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2059 av_fill(obj, SvIV(sv));
2061 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2062 "Attempt to set length of freed array");
2068 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2072 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2073 PERL_UNUSED_ARG(sv);
2074 PERL_UNUSED_CONTEXT;
2076 /* Reset the iterator when the array is cleared */
2077 #if IVSIZE == I32SIZE
2078 *((IV *) &(mg->mg_len)) = 0;
2081 *((IV *) mg->mg_ptr) = 0;
2088 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2092 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2093 PERL_UNUSED_ARG(sv);
2095 /* during global destruction, mg_obj may already have been freed */
2096 if (PL_in_clean_all)
2099 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2102 /* arylen scalar holds a pointer back to the array, but doesn't own a
2103 reference. Hence the we (the array) are about to go away with it
2104 still pointing at us. Clear its pointer, else it would be pointing
2105 at free memory. See the comment in sv_magic about reference loops,
2106 and why it can't own a reference to us. */
2113 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2116 SV* const lsv = LvTARG(sv);
2117 MAGIC * const found = mg_find_mglob(lsv);
2119 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2120 PERL_UNUSED_ARG(mg);
2122 if (found && found->mg_len != -1) {
2123 STRLEN i = found->mg_len;
2124 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2125 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2134 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2137 SV* const lsv = LvTARG(sv);
2144 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2145 PERL_UNUSED_ARG(mg);
2147 found = mg_find_mglob(lsv);
2151 found = sv_magicext_mglob(lsv);
2153 else if (!SvOK(sv)) {
2157 s = SvPV_const(lsv, len);
2162 ulen = sv_or_pv_len_utf8(lsv, s, len);
2172 else if (pos > (SSize_t)len)
2175 found->mg_len = pos;
2176 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2182 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2185 SV * const lsv = LvTARG(sv);
2186 const char * const tmps = SvPV_const(lsv,len);
2187 STRLEN offs = LvTARGOFF(sv);
2188 STRLEN rem = LvTARGLEN(sv);
2189 const bool negoff = LvFLAGS(sv) & 1;
2190 const bool negrem = LvFLAGS(sv) & 2;
2192 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2193 PERL_UNUSED_ARG(mg);
2195 if (!translate_substr_offsets(
2196 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2197 negoff ? -(IV)offs : (IV)offs, !negoff,
2198 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2200 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2201 sv_setsv_nomg(sv, &PL_sv_undef);
2206 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2207 sv_setpvn(sv, tmps + offs, rem);
2214 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2217 STRLEN len, lsv_len, oldtarglen, newtarglen;
2218 const char * const tmps = SvPV_const(sv, len);
2219 SV * const lsv = LvTARG(sv);
2220 STRLEN lvoff = LvTARGOFF(sv);
2221 STRLEN lvlen = LvTARGLEN(sv);
2222 const bool negoff = LvFLAGS(sv) & 1;
2223 const bool neglen = LvFLAGS(sv) & 2;
2225 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2226 PERL_UNUSED_ARG(mg);
2230 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2231 "Attempt to use reference as lvalue in substr"
2233 SvPV_force_nomg(lsv,lsv_len);
2234 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2235 if (!translate_substr_offsets(
2237 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2238 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2240 Perl_croak(aTHX_ "substr outside of string");
2243 sv_utf8_upgrade_nomg(lsv);
2244 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2245 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2246 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2249 else if (SvUTF8(lsv)) {
2251 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2253 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2254 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2258 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2261 if (!neglen) LvTARGLEN(sv) = newtarglen;
2262 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2268 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2272 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2273 PERL_UNUSED_ARG(sv);
2274 #ifdef NO_TAINT_SUPPORT
2275 PERL_UNUSED_ARG(mg);
2278 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2283 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2287 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2288 PERL_UNUSED_ARG(sv);
2290 /* update taint status */
2299 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2301 SV * const lsv = LvTARG(sv);
2303 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2304 PERL_UNUSED_ARG(mg);
2306 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2312 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2314 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2315 PERL_UNUSED_ARG(mg);
2316 do_vecset(sv); /* XXX slurp this routine */
2321 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2325 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2326 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2328 if (LvTARGLEN(sv)) {
2330 SV * const ahv = LvTARG(sv);
2331 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2335 else if (LvSTARGOFF(sv) >= 0) {
2336 AV *const av = MUTABLE_AV(LvTARG(sv));
2337 if (LvSTARGOFF(sv) <= AvFILL(av))
2339 if (SvRMAGICAL(av)) {
2340 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2341 targ = svp ? *svp : NULL;
2344 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2347 if (targ && (targ != &PL_sv_undef)) {
2348 /* somebody else defined it for us */
2349 SvREFCNT_dec(LvTARG(sv));
2350 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2352 SvREFCNT_dec(mg->mg_obj);
2354 mg->mg_flags &= ~MGf_REFCOUNTED;
2363 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2365 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2367 sv_setsv(sv, defelem_target(sv, mg));
2372 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2374 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2375 PERL_UNUSED_ARG(mg);
2379 sv_setsv(LvTARG(sv), sv);
2380 SvSETMAGIC(LvTARG(sv));
2386 Perl_vivify_defelem(pTHX_ SV *sv)
2392 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2394 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2397 SV * const ahv = LvTARG(sv);
2398 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2401 if (!value || value == &PL_sv_undef)
2402 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2404 else if (LvSTARGOFF(sv) < 0)
2405 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2407 AV *const av = MUTABLE_AV(LvTARG(sv));
2408 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2409 LvTARG(sv) = NULL; /* array can't be extended */
2411 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2412 if (!svp || !(value = *svp))
2413 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2416 SvREFCNT_inc_simple_void(value);
2417 SvREFCNT_dec(LvTARG(sv));
2420 SvREFCNT_dec(mg->mg_obj);
2422 mg->mg_flags &= ~MGf_REFCOUNTED;
2426 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2428 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2429 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2434 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2436 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2437 PERL_UNUSED_CONTEXT;
2438 PERL_UNUSED_ARG(sv);
2444 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2446 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2448 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2450 if (uf && uf->uf_set)
2451 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2456 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2458 const char type = mg->mg_type;
2460 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2462 if (type == PERL_MAGIC_qr) {
2463 } else if (type == PERL_MAGIC_bm) {
2467 assert(type == PERL_MAGIC_fm);
2469 return sv_unmagic(sv, type);
2472 #ifdef USE_LOCALE_COLLATE
2474 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2476 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2479 * RenE<eacute> Descartes said "I think not."
2480 * and vanished with a faint plop.
2482 PERL_UNUSED_CONTEXT;
2483 PERL_UNUSED_ARG(sv);
2485 Safefree(mg->mg_ptr);
2491 #endif /* USE_LOCALE_COLLATE */
2493 /* Just clear the UTF-8 cache data. */
2495 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2497 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2498 PERL_UNUSED_CONTEXT;
2499 PERL_UNUSED_ARG(sv);
2500 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2502 mg->mg_len = -1; /* The mg_len holds the len cache. */
2507 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2517 PERL_ARGS_ASSERT_MAGIC_SET;
2521 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2523 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2525 /* Croak with a READONLY error when a numbered match var is
2526 * set without a previous pattern match. Unless it's C<local $1>
2529 if (!PL_localizing) {
2530 Perl_croak_no_modify();
2536 switch (*mg->mg_ptr) {
2537 case '\001': /* ^A */
2538 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2539 else SvOK_off(PL_bodytarget);
2540 FmLINES(PL_bodytarget) = 0;
2541 if (SvPOK(PL_bodytarget)) {
2542 char *s = SvPVX(PL_bodytarget);
2543 while ( ((s = strchr(s, '\n'))) ) {
2544 FmLINES(PL_bodytarget)++;
2548 /* mg_set() has temporarily made sv non-magical */
2550 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2551 SvTAINTED_on(PL_bodytarget);
2553 SvTAINTED_off(PL_bodytarget);
2556 case '\003': /* ^C */
2557 PL_minus_c = cBOOL(SvIV(sv));
2560 case '\004': /* ^D */
2562 s = SvPV_nolen_const(sv);
2563 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2564 if (DEBUG_x_TEST || DEBUG_B_TEST)
2565 dump_all_perl(!DEBUG_B_TEST);
2567 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2570 case '\005': /* ^E */
2571 if (*(mg->mg_ptr+1) == '\0') {
2573 set_vaxc_errno(SvIV(sv));
2576 SetLastError( SvIV(sv) );
2579 os2_setsyserrno(SvIV(sv));
2581 /* will anyone ever use this? */
2582 SETERRNO(SvIV(sv), 4);
2587 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2588 SvREFCNT_dec(PL_encoding);
2589 if (SvOK(sv) || SvGMAGICAL(sv)) {
2590 PL_encoding = newSVsv(sv);
2597 case '\006': /* ^F */
2598 PL_maxsysfd = SvIV(sv);
2600 case '\010': /* ^H */
2601 PL_hints = SvIV(sv);
2603 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2604 Safefree(PL_inplace);
2605 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2607 case '\016': /* ^N */
2608 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2609 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2611 case '\017': /* ^O */
2612 if (*(mg->mg_ptr+1) == '\0') {
2613 Safefree(PL_osname);
2616 TAINT_PROPER("assigning to $^O");
2617 PL_osname = savesvpv(sv);
2620 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2622 const char *const start = SvPV(sv, len);
2623 const char *out = (const char*)memchr(start, '\0', len);
2627 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2628 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2630 /* Opening for input is more common than opening for output, so
2631 ensure that hints for input are sooner on linked list. */
2632 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2634 : newSVpvs_flags("", SvUTF8(sv));
2635 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2638 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2640 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2644 case '\020': /* ^P */
2645 PL_perldb = SvIV(sv);
2646 if (PL_perldb && !PL_DBsingle)
2649 case '\024': /* ^T */
2651 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2653 PL_basetime = (Time_t)SvIV(sv);
2656 case '\025': /* ^UTF8CACHE */
2657 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2658 PL_utf8cache = (signed char) sv_2iv(sv);
2661 case '\027': /* ^W & $^WARNING_BITS */
2662 if (*(mg->mg_ptr+1) == '\0') {
2663 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2665 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2666 | (i ? G_WARN_ON : G_WARN_OFF) ;
2669 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2670 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2672 PL_compiling.cop_warnings = pWARN_STD;
2677 int accumulate = 0 ;
2678 int any_fatals = 0 ;
2679 const char * const ptr = SvPV_const(sv, len) ;
2680 for (i = 0 ; i < len ; ++i) {
2681 accumulate |= ptr[i] ;
2682 any_fatals |= (ptr[i] & 0xAA) ;
2685 if (!specialWARN(PL_compiling.cop_warnings))
2686 PerlMemShared_free(PL_compiling.cop_warnings);
2687 PL_compiling.cop_warnings = pWARN_NONE;
2689 /* Yuck. I can't see how to abstract this: */
2691 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2695 if (!specialWARN(PL_compiling.cop_warnings))
2696 PerlMemShared_free(PL_compiling.cop_warnings);
2697 PL_compiling.cop_warnings = pWARN_ALL;
2698 PL_dowarn |= G_WARN_ONCE ;
2702 const char *const p = SvPV_const(sv, len);
2704 PL_compiling.cop_warnings
2705 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2708 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2709 PL_dowarn |= G_WARN_ONCE ;
2717 if (PL_localizing) {
2718 if (PL_localizing == 1)
2719 SAVESPTR(PL_last_in_gv);
2721 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2722 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2725 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2726 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2727 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2730 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2731 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2732 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2735 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2738 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2739 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2740 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2743 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2747 IO * const io = GvIO(PL_defoutgv);
2750 if ((SvIV(sv)) == 0)
2751 IoFLAGS(io) &= ~IOf_FLUSH;
2753 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2754 PerlIO *ofp = IoOFP(io);
2756 (void)PerlIO_flush(ofp);
2757 IoFLAGS(io) |= IOf_FLUSH;
2766 SV *referent= SvRV(sv);
2767 const char *reftype= sv_reftype(referent, 0);
2768 /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
2769 * is to copy pretty much the entire sv_reftype() into this routine, or to do
2770 * a full string comparison on the return of sv_reftype() both of which
2771 * make me feel worse! NOTE, do not modify this comment without reviewing the
2772 * corresponding comment in sv_reftype(). - Yves */
2773 if (reftype[0] == 'S' || reftype[0] == 'L') {
2774 IV val= SvIV(referent);
2776 tmpsv= &PL_sv_undef;
2777 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
2778 "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
2779 SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2783 /* diag_listed_as: Setting $/ to %s reference is forbidden */
2784 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2785 *reftype == 'A' ? "n" : "", reftype);
2788 SvREFCNT_dec(PL_rs);
2789 PL_rs = newSVsv(tmpsv);
2793 SvREFCNT_dec(PL_ors_sv);
2795 PL_ors_sv = newSVsv(sv);
2803 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2806 #ifdef COMPLEX_STATUS
2807 if (PL_localizing == 2) {
2808 SvUPGRADE(sv, SVt_PVLV);
2809 PL_statusvalue = LvTARGOFF(sv);
2810 PL_statusvalue_vms = LvTARGLEN(sv);
2814 #ifdef VMSISH_STATUS
2816 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2819 STATUS_UNIX_EXIT_SET(SvIV(sv));
2824 # define PERL_VMS_BANG vaxc$errno
2826 # define PERL_VMS_BANG 0
2828 #if defined(WIN32) && ! defined(UNDER_CE)
2829 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2830 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2832 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2833 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2839 /* XXX $< currently silently ignores failures */
2840 const Uid_t new_uid = SvUID(sv);
2841 PL_delaymagic_uid = new_uid;
2842 if (PL_delaymagic) {
2843 PL_delaymagic |= DM_RUID;
2844 break; /* don't do magic till later */
2847 PERL_UNUSED_RESULT(setruid(new_uid));
2850 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
2852 #ifdef HAS_SETRESUID
2853 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
2855 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2857 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2858 if (new_uid != 0 && PerlProc_getuid() == 0)
2859 PERL_UNUSED_RESULT(PerlProc_setuid(0));
2861 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
2863 Perl_croak(aTHX_ "setruid() not implemented");
2872 /* XXX $> currently silently ignores failures */
2873 const Uid_t new_euid = SvUID(sv);
2874 PL_delaymagic_euid = new_euid;
2875 if (PL_delaymagic) {
2876 PL_delaymagic |= DM_EUID;
2877 break; /* don't do magic till later */
2880 PERL_UNUSED_RESULT(seteuid(new_euid));
2883 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
2885 #ifdef HAS_SETRESUID
2886 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
2888 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2889 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
2891 Perl_croak(aTHX_ "seteuid() not implemented");
2900 /* XXX $( currently silently ignores failures */
2901 const Gid_t new_gid = SvGID(sv);
2902 PL_delaymagic_gid = new_gid;
2903 if (PL_delaymagic) {
2904 PL_delaymagic |= DM_RGID;
2905 break; /* don't do magic till later */
2908 PERL_UNUSED_RESULT(setrgid(new_gid));
2911 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
2913 #ifdef HAS_SETRESGID
2914 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
2916 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2917 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
2919 Perl_croak(aTHX_ "setrgid() not implemented");
2928 /* XXX $) currently silently ignores failures */
2930 #ifdef HAS_SETGROUPS
2932 const char *p = SvPV_const(sv, len);
2933 Groups_t *gary = NULL;
2934 #ifdef _SC_NGROUPS_MAX
2935 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2940 int maxgrp = NGROUPS;
2945 new_egid = (Gid_t)Atol(p);
2946 for (i = 0; i < maxgrp; ++i) {
2947 while (*p && !isSPACE(*p))
2954 Newx(gary, i + 1, Groups_t);
2956 Renew(gary, i + 1, Groups_t);
2957 gary[i] = (Groups_t)Atol(p);
2960 PERL_UNUSED_RESULT(setgroups(i, gary));
2963 #else /* HAS_SETGROUPS */
2964 new_egid = SvGID(sv);
2965 #endif /* HAS_SETGROUPS */
2966 PL_delaymagic_egid = new_egid;
2967 if (PL_delaymagic) {
2968 PL_delaymagic |= DM_EGID;
2969 break; /* don't do magic till later */
2972 PERL_UNUSED_RESULT(setegid(new_egid));
2975 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
2977 #ifdef HAS_SETRESGID
2978 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
2980 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2981 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
2983 Perl_croak(aTHX_ "setegid() not implemented");
2991 PL_chopset = SvPV_force(sv,len);
2994 /* Store the pid in mg->mg_obj so we can tell when a fork has
2995 occurred. mg->mg_obj points to *$ by default, so clear it. */
2996 if (isGV(mg->mg_obj)) {
2997 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2998 SvREFCNT_dec(mg->mg_obj);
2999 mg->mg_flags |= MGf_REFCOUNTED;
3000 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3002 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3005 LOCK_DOLLARZERO_MUTEX;
3006 #ifdef HAS_SETPROCTITLE
3007 /* The BSDs don't show the argv[] in ps(1) output, they
3008 * show a string from the process struct and provide
3009 * the setproctitle() routine to manipulate that. */
3010 if (PL_origalen != 1) {
3011 s = SvPV_const(sv, len);
3012 # if __FreeBSD_version > 410001
3013 /* The leading "-" removes the "perl: " prefix,
3014 * but not the "(perl) suffix from the ps(1)
3015 * output, because that's what ps(1) shows if the
3016 * argv[] is modified. */
3017 setproctitle("-%s", s);
3018 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
3019 /* This doesn't really work if you assume that
3020 * $0 = 'foobar'; will wipe out 'perl' from the $0
3021 * because in ps(1) output the result will be like
3022 * sprintf("perl: %s (perl)", s)
3023 * I guess this is a security feature:
3024 * one (a user process) cannot get rid of the original name.
3026 setproctitle("%s", s);
3029 #elif defined(__hpux) && defined(PSTAT_SETCMD)
3030 if (PL_origalen != 1) {
3032 s = SvPV_const(sv, len);
3033 un.pst_command = (char *)s;
3034 pstat(PSTAT_SETCMD, un, len, 0, 0);
3037 if (PL_origalen > 1) {
3038 /* PL_origalen is set in perl_parse(). */
3039 s = SvPV_force(sv,len);
3040 if (len >= (STRLEN)PL_origalen-1) {
3041 /* Longer than original, will be truncated. We assume that
3042 * PL_origalen bytes are available. */
3043 Copy(s, PL_origargv[0], PL_origalen-1, char);
3046 /* Shorter than original, will be padded. */
3048 /* Special case for Mac OS X: see [perl #38868] */
3051 /* Is the space counterintuitive? Yes.
3052 * (You were expecting \0?)
3053 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3055 const int pad = ' ';
3057 Copy(s, PL_origargv[0], len, char);
3058 PL_origargv[0][len] = 0;
3059 memset(PL_origargv[0] + len + 1,
3060 pad, PL_origalen - len - 1);
3062 PL_origargv[0][PL_origalen-1] = 0;
3063 for (i = 1; i < PL_origargc; i++)
3065 #ifdef HAS_PRCTL_SET_NAME
3066 /* Set the legacy process name in addition to the POSIX name on Linux */
3067 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3068 /* diag_listed_as: SKIPME */
3069 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3074 UNLOCK_DOLLARZERO_MUTEX;
3081 Perl_whichsig_sv(pTHX_ SV *sigsv)
3085 PERL_ARGS_ASSERT_WHICHSIG_SV;
3086 sigpv = SvPV_const(sigsv, siglen);
3087 return whichsig_pvn(sigpv, siglen);
3091 Perl_whichsig_pv(pTHX_ const char *sig)
3093 PERL_ARGS_ASSERT_WHICHSIG_PV;
3094 return whichsig_pvn(sig, strlen(sig));
3098 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3102 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3103 PERL_UNUSED_CONTEXT;
3105 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3106 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3107 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3109 if (memEQs(sig, len, "CHLD"))
3113 if (memEQs(sig, len, "CLD"))
3120 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3121 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3123 Perl_sighandler(int sig)
3126 #ifdef PERL_GET_SIG_CONTEXT
3127 dTHXa(PERL_GET_SIG_CONTEXT);
3134 SV * const tSv = PL_Sv;
3138 XPV * const tXpv = PL_Xpv;
3139 I32 old_ss_ix = PL_savestack_ix;
3140 SV *errsv_save = NULL;
3143 if (!PL_psig_ptr[sig]) {
3144 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3149 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3150 /* Max number of items pushed there is 3*n or 4. We cannot fix
3151 infinity, so we fix 4 (in fact 5): */
3152 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3154 PL_savestack_ix += 5; /* Protect save in progress. */
3155 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3158 /* sv_2cv is too complicated, try a simpler variant first: */
3159 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3160 || SvTYPE(cv) != SVt_PVCV) {
3162 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3165 if (!cv || !CvROOT(cv)) {
3166 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3167 PL_sig_name[sig], (gv ? GvENAME(gv)
3174 sv = PL_psig_name[sig]
3175 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3176 : newSVpv(PL_sig_name[sig],0);
3180 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3181 /* make sure our assumption about the size of the SAVEs are correct:
3182 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3183 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3186 PUSHSTACKi(PERLSI_SIGNAL);
3189 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3191 struct sigaction oact;
3193 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3196 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3197 /* The siginfo fields signo, code, errno, pid, uid,
3198 * addr, status, and band are defined by POSIX/SUSv3. */
3199 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3200 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3201 #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. */
3202 hv_stores(sih, "errno", newSViv(sip->si_errno));
3203 hv_stores(sih, "status", newSViv(sip->si_status));
3204 hv_stores(sih, "uid", newSViv(sip->si_uid));
3205 hv_stores(sih, "pid", newSViv(sip->si_pid));
3206 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3207 hv_stores(sih, "band", newSViv(sip->si_band));
3211 mPUSHp((char *)sip, sizeof(*sip));
3219 errsv_save = newSVsv(ERRSV);
3221 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3225 SV * const errsv = ERRSV;
3226 if (SvTRUE_NN(errsv)) {
3227 SvREFCNT_dec(errsv_save);
3229 /* Handler "died", for example to get out of a restart-able read().
3230 * Before we re-do that on its behalf re-enable the signal which was
3231 * blocked by the system when we entered.
3233 #ifdef HAS_SIGPROCMASK
3234 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3240 sigaddset(&set,sig);
3241 sigprocmask(SIG_UNBLOCK, &set, NULL);
3244 /* Not clear if this will work */
3245 (void)rsignal(sig, SIG_IGN);
3246 (void)rsignal(sig, PL_csighandlerp);
3248 #endif /* !PERL_MICRO */
3252 sv_setsv(errsv, errsv_save);
3253 SvREFCNT_dec(errsv_save);
3258 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3259 PL_savestack_ix = old_ss_ix;
3261 SvREFCNT_dec_NN(sv);
3262 PL_op = myop; /* Apparently not needed... */
3264 PL_Sv = tSv; /* Restore global temporaries. */
3271 S_restore_magic(pTHX_ const void *p)
3274 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3275 SV* const sv = mgs->mgs_sv;
3281 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3282 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3283 #ifdef PERL_OLD_COPY_ON_WRITE
3284 /* While magic was saved (and off) sv_setsv may well have seen
3285 this SV as a prime candidate for COW. */
3287 sv_force_normal_flags(sv, 0);
3289 if (mgs->mgs_readonly)
3291 if (mgs->mgs_magical)
3292 SvFLAGS(sv) |= mgs->mgs_magical;
3297 bumped = mgs->mgs_bumped;
3298 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3300 /* If we're still on top of the stack, pop us off. (That condition
3301 * will be satisfied if restore_magic was called explicitly, but *not*
3302 * if it's being called via leave_scope.)
3303 * The reason for doing this is that otherwise, things like sv_2cv()
3304 * may leave alloc gunk on the savestack, and some code
3305 * (e.g. sighandler) doesn't expect that...
3307 if (PL_savestack_ix == mgs->mgs_ss_ix)
3309 UV popval = SSPOPUV;
3310 assert(popval == SAVEt_DESTRUCTOR_X);
3311 PL_savestack_ix -= 2;
3313 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3314 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3317 if (SvREFCNT(sv) == 1) {
3318 /* We hold the last reference to this SV, which implies that the
3319 SV was deleted as a side effect of the routines we called.
3320 So artificially keep it alive a bit longer.
3321 We avoid turning on the TEMP flag, which can cause the SV's
3322 buffer to get stolen (and maybe other stuff). */
3327 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3331 /* clean up the mess created by Perl_sighandler().
3332 * Note that this is only called during an exit in a signal handler;
3333 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3337 S_unwind_handler_stack(pTHX_ const void *p)
3342 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3346 =for apidoc magic_sethint
3348 Triggered by a store to %^H, records the key/value pair to
3349 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3350 anything that would need a deep copy. Maybe we should warn if we find a
3356 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3359 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3360 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3362 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3364 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3365 an alternative leaf in there, with PL_compiling.cop_hints being used if
3366 it's NULL. If needed for threads, the alternative could lock a mutex,
3367 or take other more complex action. */
3369 /* Something changed in %^H, so it will need to be restored on scope exit.
3370 Doing this here saves a lot of doing it manually in perl code (and
3371 forgetting to do it, and consequent subtle errors. */
3372 PL_hints |= HINT_LOCALIZE_HH;
3373 CopHINTHASH_set(&PL_compiling,
3374 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3379 =for apidoc magic_clearhint
3381 Triggered by a delete from %^H, records the key to
3382 C<PL_compiling.cop_hints_hash>.
3387 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3391 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3392 PERL_UNUSED_ARG(sv);
3394 PL_hints |= HINT_LOCALIZE_HH;
3395 CopHINTHASH_set(&PL_compiling,
3396 mg->mg_len == HEf_SVKEY
3397 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3398 MUTABLE_SV(mg->mg_ptr), 0, 0)
3399 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3400 mg->mg_ptr, mg->mg_len, 0, 0));
3405 =for apidoc magic_clearhints
3407 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3412 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3414 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3415 PERL_UNUSED_ARG(sv);
3416 PERL_UNUSED_ARG(mg);
3417 cophh_free(CopHINTHASH_get(&PL_compiling));
3418 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3423 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3424 const char *name, I32 namlen)
3428 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3429 PERL_UNUSED_ARG(sv);
3430 PERL_UNUSED_ARG(name);
3431 PERL_UNUSED_ARG(namlen);
3433 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3434 nmg = mg_find(nsv, mg->mg_type);
3436 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3437 nmg->mg_ptr = mg->mg_ptr;
3438 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3439 nmg->mg_flags |= MGf_REFCOUNTED;
3445 * c-indentation-style: bsd
3447 * indent-tabs-mode: nil
3450 * ex: set ts=8 sts=4 sw=4 et: