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
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #ifdef HAS_PRCTL_SET_NAME
61 # include <sys/prctl.h>
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
67 Signal_t Perl_csighandler(int sig);
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
79 * Pre-magic setup and post-magic takedown.
80 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
90 /* MGS is typedef'ed to struct magic_state in perl.h */
93 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
99 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
101 assert(SvMAGICAL(sv));
103 /* we shouldn't really be called here with RC==0, but it can sometimes
104 * happen via mg_clear() (which also shouldn't be called when RC==0,
105 * but it can happen). Handle this case gracefully(ish) by not RC++
106 * and thus avoiding the resultant double free */
107 if (SvREFCNT(sv) > 0) {
108 /* guard against sv getting freed midway through the mg clearing,
109 * by holding a private reference for the duration. */
110 SvREFCNT_inc_simple_void_NN(sv);
114 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
116 mgs = SSPTR(mgs_ix, MGS*);
118 mgs->mgs_magical = SvMAGICAL(sv);
119 mgs->mgs_readonly = SvREADONLY(sv) != 0;
120 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
121 mgs->mgs_bumped = bumped;
123 SvFLAGS(sv) &= ~flags;
127 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
130 =for apidoc mg_magical
132 Turns on the magical status of an SV. See C<sv_magic>.
138 Perl_mg_magical(pTHX_ SV *sv)
141 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");
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(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
398 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
400 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
401 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
413 Finds the magic pointer for type matching the SV. See C<sv_magic>.
419 Perl_mg_find(pTHX_ const SV *sv, int type)
421 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
425 =for apidoc mg_findext
427 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
434 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
436 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
440 Perl_mg_find_mglob(pTHX_ SV *sv)
442 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
443 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
444 /* This sv is only a delegate. //g magic must be attached to
449 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
450 return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
457 Copies the magic from one SV to another. See C<sv_magic>.
463 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
468 PERL_ARGS_ASSERT_MG_COPY;
470 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
473 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
476 const char type = mg->mg_type;
477 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
479 (type == PERL_MAGIC_tied)
481 : (type == PERL_MAGIC_regdata && mg->mg_obj)
484 toLOWER(type), key, klen);
493 =for apidoc mg_localize
495 Copy some of the magic from an existing SV to new localized version of that
496 SV. Container magic (eg %ENV, $1, tie)
497 gets copied, value magic doesn't (eg
500 If setmagic is false then no set magic will be called on the new (empty) SV.
501 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
502 and that will handle the magic.
508 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
513 PERL_ARGS_ASSERT_MG_LOCALIZE;
518 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
519 const MGVTBL* const vtbl = mg->mg_virtual;
520 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
523 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
524 (void)vtbl->svt_local(aTHX_ nsv, mg);
526 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
527 mg->mg_ptr, mg->mg_len);
529 /* container types should remain read-only across localization */
530 SvFLAGS(nsv) |= SvREADONLY(sv);
533 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
534 SvFLAGS(nsv) |= SvMAGICAL(sv);
543 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
545 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
547 const MGVTBL* const vtbl = mg->mg_virtual;
548 if (vtbl && vtbl->svt_free)
549 vtbl->svt_free(aTHX_ sv, mg);
550 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
551 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
552 Safefree(mg->mg_ptr);
553 else if (mg->mg_len == HEf_SVKEY)
554 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
556 if (mg->mg_flags & MGf_REFCOUNTED)
557 SvREFCNT_dec(mg->mg_obj);
564 Free any magic storage used by the SV. See C<sv_magic>.
570 Perl_mg_free(pTHX_ SV *sv)
575 PERL_ARGS_ASSERT_MG_FREE;
577 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
578 moremagic = mg->mg_moremagic;
579 mg_free_struct(sv, mg);
580 SvMAGIC_set(sv, moremagic);
582 SvMAGIC_set(sv, NULL);
588 =for apidoc Am|void|mg_free_type|SV *sv|int how
590 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
596 Perl_mg_free_type(pTHX_ SV *sv, int how)
598 MAGIC *mg, *prevmg, *moremg;
599 PERL_ARGS_ASSERT_MG_FREE_TYPE;
600 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
602 moremg = mg->mg_moremagic;
603 if (mg->mg_type == how) {
604 /* temporarily move to the head of the magic chain, in case
605 custom free code relies on this historical aspect of mg_free */
607 prevmg->mg_moremagic = moremg;
608 mg->mg_moremagic = SvMAGIC(sv);
611 newhead = mg->mg_moremagic;
612 mg_free_struct(sv, mg);
613 SvMAGIC_set(sv, newhead);
623 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
628 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
631 const REGEXP * const rx = PM_GETRE(PL_curpm);
633 if (mg->mg_obj) { /* @+ */
634 /* return the number possible */
635 return RX_NPARENS(rx);
637 I32 paren = RX_LASTPAREN(rx);
639 /* return the last filled */
641 && (RX_OFFS(rx)[paren].start == -1
642 || RX_OFFS(rx)[paren].end == -1) )
655 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
659 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
662 const REGEXP * const rx = PM_GETRE(PL_curpm);
664 const I32 paren = mg->mg_len;
669 if (paren <= (I32)RX_NPARENS(rx) &&
670 (s = RX_OFFS(rx)[paren].start) != -1 &&
671 (t = RX_OFFS(rx)[paren].end) != -1)
674 if (mg->mg_obj) /* @+ */
679 if (RX_MATCH_UTF8(rx)) {
680 const char * const b = RX_SUBBEG(rx);
682 i = RX_SUBCOFFSET(rx) +
684 (U8*)(b-RX_SUBOFFSET(rx)+i));
699 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
701 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
704 Perl_croak_no_modify();
705 NORETURN_FUNCTION_END;
708 #define SvRTRIM(sv) STMT_START { \
710 STRLEN len = SvCUR(sv); \
711 char * const p = SvPVX(sv); \
712 while (len > 0 && isSPACE(p[len-1])) \
714 SvCUR_set(sv, len); \
720 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
722 PERL_ARGS_ASSERT_EMULATE_COP_IO;
724 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
725 sv_setsv(sv, &PL_sv_undef);
729 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
730 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
735 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
736 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
744 S_fixup_errno_string(pTHX_ SV* sv)
746 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
749 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
753 if(strEQ(SvPVX(sv), "")) {
754 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
757 /* This is disabled to get v5.20 out the door. It means that $! behaves as
758 * if in the scope of both 'use locale' and 'use bytes'. This can cause
759 * mixed encodings and double utf8 upgrading, See towards the end of the
760 * thread for [perl #119499] */
763 /* In some locales the error string may come back as UTF-8, in which
764 * case we should turn on that flag. This didn't use to happen, and to
765 * avoid any possible backward compatibility issues, we don't turn on
766 * the flag unless we have to. So the flag stays off for an entirely
767 * ASCII string. We assume that if the string looks like UTF-8, it
768 * really is UTF-8: "text in any other encoding that uses bytes with
769 * the high bit set is extremely unlikely to pass a UTF-8 validity
770 * test" (http://en.wikipedia.org/wiki/Charset_detection). There is a
771 * potential that we will get it wrong however, especially on short
772 * error message text. (If it turns out to be necessary, we could also
773 * keep track if the current LC_MESSAGES locale is UTF-8) */
774 if (! IN_BYTES /* respect 'use bytes' */
775 && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
776 && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
790 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
794 const char *s = NULL;
796 const char * const remaining = mg->mg_ptr + 1;
799 PERL_ARGS_ASSERT_MAGIC_GET;
803 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
805 CALLREG_NUMBUF_FETCH(rx,paren,sv);
807 sv_setsv(sv,&PL_sv_undef);
812 nextchar = *remaining;
813 switch (*mg->mg_ptr) {
814 case '\001': /* ^A */
815 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
816 else sv_setsv(sv, &PL_sv_undef);
817 if (SvTAINTED(PL_bodytarget))
820 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
821 if (nextchar == '\0') {
822 sv_setiv(sv, (IV)PL_minus_c);
824 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
825 sv_setiv(sv, (IV)STATUS_NATIVE);
829 case '\004': /* ^D */
830 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
832 case '\005': /* ^E */
833 if (nextchar != '\0') {
834 if (strEQ(remaining, "NCODING"))
835 sv_setsv(sv, PL_encoding);
839 #if defined(VMS) || defined(OS2) || defined(WIN32)
843 $DESCRIPTOR(msgdsc,msg);
844 sv_setnv(sv,(NV) vaxc$errno);
845 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
846 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
851 if (!(_emx_env & 0x200)) { /* Under DOS */
852 sv_setnv(sv, (NV)errno);
853 sv_setpv(sv, errno ? Strerror(errno) : "");
855 if (errno != errno_isOS2) {
856 const int tmp = _syserrno();
857 if (tmp) /* 2nd call to _syserrno() makes it 0 */
860 sv_setnv(sv, (NV)Perl_rc);
861 sv_setpv(sv, os2error(Perl_rc));
863 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
864 fixup_errno_string(sv);
866 # elif defined(WIN32)
868 const DWORD dwErr = GetLastError();
869 sv_setnv(sv, (NV)dwErr);
871 PerlProc_GetOSError(sv, dwErr);
872 fixup_errno_string(sv);
879 # error Missing code for platform
882 SvNOK_on(sv); /* what a wonderful hack! */
884 #endif /* End of platforms with special handling for $^E; others just fall
891 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
893 sv_setnv(sv, (NV)errno);
896 if (errno == errno_isOS2 || errno == errno_isOS2_set)
897 sv_setpv(sv, os2error(Perl_rc));
905 /* Strerror can return NULL on some platforms, which will
906 * result in 'sv' not being considered SvOK. The SvNOK_on()
907 * below will cause just the number part to be valid */
908 sv_setpv(sv, Strerror(errno));
910 fixup_errno_string(sv);
917 SvNOK_on(sv); /* what a wonderful hack! */
920 case '\006': /* ^F */
921 sv_setiv(sv, (IV)PL_maxsysfd);
923 case '\007': /* ^GLOBAL_PHASE */
924 if (strEQ(remaining, "LOBAL_PHASE")) {
925 sv_setpvn(sv, PL_phase_names[PL_phase],
926 strlen(PL_phase_names[PL_phase]));
929 case '\010': /* ^H */
930 sv_setiv(sv, (IV)PL_hints);
932 case '\011': /* ^I */ /* NOT \t in EBCDIC */
933 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
935 case '\014': /* ^LAST_FH */
936 if (strEQ(remaining, "AST_FH")) {
938 assert(isGV_with_GP(PL_last_in_gv));
939 SV_CHECK_THINKFIRST_COW_DROP(sv);
940 prepare_SV_for_RV(sv);
942 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
946 else sv_setsv_nomg(sv, NULL);
949 case '\017': /* ^O & ^OPEN */
950 if (nextchar == '\0') {
951 sv_setpv(sv, PL_osname);
954 else if (strEQ(remaining, "PEN")) {
955 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
959 sv_setiv(sv, (IV)PL_perldb);
961 case '\023': /* ^S */
963 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
966 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
971 case '\024': /* ^T */
972 if (nextchar == '\0') {
974 sv_setnv(sv, PL_basetime);
976 sv_setiv(sv, (IV)PL_basetime);
979 else if (strEQ(remaining, "AINT"))
980 sv_setiv(sv, TAINTING_get
981 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
984 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
985 if (strEQ(remaining, "NICODE"))
986 sv_setuv(sv, (UV) PL_unicode);
987 else if (strEQ(remaining, "TF8LOCALE"))
988 sv_setuv(sv, (UV) PL_utf8locale);
989 else if (strEQ(remaining, "TF8CACHE"))
990 sv_setiv(sv, (IV) PL_utf8cache);
992 case '\027': /* ^W & $^WARNING_BITS */
993 if (nextchar == '\0')
994 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
995 else if (strEQ(remaining, "ARNING_BITS")) {
996 if (PL_compiling.cop_warnings == pWARN_NONE) {
997 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
999 else if (PL_compiling.cop_warnings == pWARN_STD) {
1000 sv_setsv(sv, &PL_sv_undef);
1003 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1004 /* Get the bit mask for $warnings::Bits{all}, because
1005 * it could have been extended by warnings::register */
1006 HV * const bits = get_hv("warnings::Bits", 0);
1007 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
1009 sv_copypv(sv, *bits_all);
1011 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1014 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1015 *PL_compiling.cop_warnings);
1020 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1021 paren = RX_LASTPAREN(rx);
1023 goto do_numbuf_fetch;
1025 sv_setsv(sv,&PL_sv_undef);
1027 case '\016': /* ^N */
1028 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1029 paren = RX_LASTCLOSEPAREN(rx);
1031 goto do_numbuf_fetch;
1033 sv_setsv(sv,&PL_sv_undef);
1036 if (GvIO(PL_last_in_gv)) {
1037 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1042 sv_setiv(sv, (IV)STATUS_CURRENT);
1043 #ifdef COMPLEX_STATUS
1044 SvUPGRADE(sv, SVt_PVLV);
1045 LvTARGOFF(sv) = PL_statusvalue;
1046 LvTARGLEN(sv) = PL_statusvalue_vms;
1051 if (GvIOp(PL_defoutgv))
1052 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1056 sv_setpv(sv,GvENAME(PL_defoutgv));
1057 sv_catpvs(sv,"_TOP");
1061 if (GvIOp(PL_defoutgv))
1062 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1064 s = GvENAME(PL_defoutgv);
1068 if (GvIO(PL_defoutgv))
1069 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1072 if (GvIO(PL_defoutgv))
1073 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1076 if (GvIO(PL_defoutgv))
1077 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1087 if (GvIO(PL_defoutgv))
1088 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1092 sv_copypv(sv, PL_ors_sv);
1094 sv_setsv(sv, &PL_sv_undef);
1098 IV const pid = (IV)PerlProc_getpid();
1099 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1100 /* never set manually, or at least not since last fork */
1102 /* never unsafe, even if reading in a tainted expression */
1105 /* else a value has been assigned manually, so do nothing */
1109 sv_setuid(sv, PerlProc_getuid());
1112 sv_setuid(sv, PerlProc_geteuid());
1115 sv_setgid(sv, PerlProc_getgid());
1118 sv_setgid(sv, PerlProc_getegid());
1120 #ifdef HAS_GETGROUPS
1122 Groups_t *gary = NULL;
1124 I32 num_groups = getgroups(0, gary);
1125 if (num_groups > 0) {
1126 Newx(gary, num_groups, Groups_t);
1127 num_groups = getgroups(num_groups, gary);
1128 for (i = 0; i < num_groups; i++)
1129 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1133 (void)SvIOK_on(sv); /* what a wonderful hack! */
1143 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1145 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1147 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1149 if (uf && uf->uf_val)
1150 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1155 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1158 STRLEN len = 0, klen;
1159 const char * const key = MgPV_const(mg,klen);
1162 PERL_ARGS_ASSERT_MAGIC_SETENV;
1166 /* defined environment variables are byte strings; unfortunately
1167 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1168 (void)SvPV_force_nomg_nolen(sv);
1169 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1171 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1177 my_setenv(key, s); /* does the deed */
1179 #ifdef DYNAMIC_ENV_FETCH
1180 /* We just undefd an environment var. Is a replacement */
1181 /* waiting in the wings? */
1183 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1185 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1189 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1190 /* And you'll never guess what the dog had */
1191 /* in its mouth... */
1193 MgTAINTEDDIR_off(mg);
1195 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1196 char pathbuf[256], eltbuf[256], *cp, *elt;
1199 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1201 do { /* DCL$PATH may be a search list */
1202 while (1) { /* as may dev portion of any element */
1203 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1204 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1205 cando_by_name(S_IWUSR,0,elt) ) {
1206 MgTAINTEDDIR_on(mg);
1210 if ((cp = strchr(elt, ':')) != NULL)
1212 if (my_trnlnm(elt, eltbuf, j++))
1218 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1221 if (s && klen == 4 && strEQ(key,"PATH")) {
1222 const char * const strend = s + len;
1224 while (s < strend) {
1228 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1229 const char path_sep = '|';
1231 const char path_sep = ':';
1233 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1234 s, strend, path_sep, &i);
1236 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1238 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1240 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1242 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1243 MgTAINTEDDIR_on(mg);
1249 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1255 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1257 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1258 PERL_UNUSED_ARG(sv);
1259 my_setenv(MgPV_nolen_const(mg),NULL);
1264 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1267 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1268 PERL_UNUSED_ARG(mg);
1270 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1272 if (PL_localizing) {
1275 hv_iterinit(MUTABLE_HV(sv));
1276 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1278 my_setenv(hv_iterkey(entry, &keylen),
1279 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1287 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1290 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1291 PERL_UNUSED_ARG(sv);
1292 PERL_UNUSED_ARG(mg);
1294 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1302 #ifdef HAS_SIGPROCMASK
1304 restore_sigmask(pTHX_ SV *save_sv)
1306 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1307 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1311 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1314 /* Are we fetching a signal entry? */
1315 int i = (I16)mg->mg_private;
1317 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1321 const char * sig = MgPV_const(mg, siglen);
1322 mg->mg_private = i = whichsig_pvn(sig, siglen);
1327 sv_setsv(sv,PL_psig_ptr[i]);
1329 Sighandler_t sigstate = rsignal_state(i);
1330 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1331 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1334 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1335 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1338 /* cache state so we don't fetch it again */
1339 if(sigstate == (Sighandler_t) SIG_IGN)
1340 sv_setpvs(sv,"IGNORE");
1342 sv_setsv(sv,&PL_sv_undef);
1343 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1350 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1352 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1354 magic_setsig(NULL, mg);
1355 return sv_unmagic(sv, mg->mg_type);
1359 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1360 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1362 Perl_csighandler(int sig)
1365 #ifdef PERL_GET_SIG_CONTEXT
1366 dTHXa(PERL_GET_SIG_CONTEXT);
1370 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1371 (void) rsignal(sig, PL_csighandlerp);
1372 if (PL_sig_ignoring[sig]) return;
1374 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1375 if (PL_sig_defaulting[sig])
1376 #ifdef KILL_BY_SIGPRC
1377 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1392 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1393 /* Call the perl level handler now--
1394 * with risk we may be in malloc() or being destructed etc. */
1395 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1396 (*PL_sighandlerp)(sig, NULL, NULL);
1398 (*PL_sighandlerp)(sig);
1401 if (!PL_psig_pend) return;
1402 /* Set a flag to say this signal is pending, that is awaiting delivery after
1403 * the current Perl opcode completes */
1404 PL_psig_pend[sig]++;
1406 #ifndef SIG_PENDING_DIE_COUNT
1407 # define SIG_PENDING_DIE_COUNT 120
1409 /* Add one to say _a_ signal is pending */
1410 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1411 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1412 (unsigned long)SIG_PENDING_DIE_COUNT);
1416 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1418 Perl_csighandler_init(void)
1421 if (PL_sig_handlers_initted) return;
1423 for (sig = 1; sig < SIG_SIZE; sig++) {
1424 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1426 PL_sig_defaulting[sig] = 1;
1427 (void) rsignal(sig, PL_csighandlerp);
1429 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1430 PL_sig_ignoring[sig] = 0;
1433 PL_sig_handlers_initted = 1;
1437 #if defined HAS_SIGPROCMASK
1439 unblock_sigmask(pTHX_ void* newset)
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);
2075 /* Reset the iterator when the array is cleared */
2076 #if IVSIZE == I32SIZE
2077 *((IV *) &(mg->mg_len)) = 0;
2080 *((IV *) mg->mg_ptr) = 0;
2087 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2091 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2092 PERL_UNUSED_ARG(sv);
2094 /* during global destruction, mg_obj may already have been freed */
2095 if (PL_in_clean_all)
2098 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2101 /* arylen scalar holds a pointer back to the array, but doesn't own a
2102 reference. Hence the we (the array) are about to go away with it
2103 still pointing at us. Clear its pointer, else it would be pointing
2104 at free memory. See the comment in sv_magic about reference loops,
2105 and why it can't own a reference to us. */
2112 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2115 SV* const lsv = LvTARG(sv);
2116 MAGIC * const found = mg_find_mglob(lsv);
2118 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2119 PERL_UNUSED_ARG(mg);
2121 if (found && found->mg_len != -1) {
2122 STRLEN i = found->mg_len;
2123 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2124 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2133 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2136 SV* const lsv = LvTARG(sv);
2143 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2144 PERL_UNUSED_ARG(mg);
2146 found = mg_find_mglob(lsv);
2150 found = sv_magicext_mglob(lsv);
2152 else if (!SvOK(sv)) {
2156 s = SvPV_const(lsv, len);
2161 ulen = sv_or_pv_len_utf8(lsv, s, len);
2171 else if (pos > (SSize_t)len)
2174 found->mg_len = pos;
2175 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2181 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2184 SV * const lsv = LvTARG(sv);
2185 const char * const tmps = SvPV_const(lsv,len);
2186 STRLEN offs = LvTARGOFF(sv);
2187 STRLEN rem = LvTARGLEN(sv);
2188 const bool negoff = LvFLAGS(sv) & 1;
2189 const bool negrem = LvFLAGS(sv) & 2;
2191 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2192 PERL_UNUSED_ARG(mg);
2194 if (!translate_substr_offsets(
2195 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2196 negoff ? -(IV)offs : (IV)offs, !negoff,
2197 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2199 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2200 sv_setsv_nomg(sv, &PL_sv_undef);
2205 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2206 sv_setpvn(sv, tmps + offs, rem);
2213 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2216 STRLEN len, lsv_len, oldtarglen, newtarglen;
2217 const char * const tmps = SvPV_const(sv, len);
2218 SV * const lsv = LvTARG(sv);
2219 STRLEN lvoff = LvTARGOFF(sv);
2220 STRLEN lvlen = LvTARGLEN(sv);
2221 const bool negoff = LvFLAGS(sv) & 1;
2222 const bool neglen = LvFLAGS(sv) & 2;
2224 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2225 PERL_UNUSED_ARG(mg);
2229 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2230 "Attempt to use reference as lvalue in substr"
2232 SvPV_force_nomg(lsv,lsv_len);
2233 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2234 if (!translate_substr_offsets(
2236 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2237 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2239 Perl_croak(aTHX_ "substr outside of string");
2242 sv_utf8_upgrade_nomg(lsv);
2243 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2244 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2245 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2248 else if (SvUTF8(lsv)) {
2250 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2252 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2253 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2257 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2260 if (!neglen) LvTARGLEN(sv) = newtarglen;
2261 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2267 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2271 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2272 PERL_UNUSED_ARG(sv);
2273 #ifdef NO_TAINT_SUPPORT
2274 PERL_UNUSED_ARG(mg);
2277 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2282 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2286 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2287 PERL_UNUSED_ARG(sv);
2289 /* update taint status */
2298 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2300 SV * const lsv = LvTARG(sv);
2302 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2303 PERL_UNUSED_ARG(mg);
2305 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2311 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2313 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2314 PERL_UNUSED_ARG(mg);
2315 do_vecset(sv); /* XXX slurp this routine */
2320 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2324 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2325 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2327 if (LvTARGLEN(sv)) {
2329 SV * const ahv = LvTARG(sv);
2330 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2334 else if (LvSTARGOFF(sv) >= 0) {
2335 AV *const av = MUTABLE_AV(LvTARG(sv));
2336 if (LvSTARGOFF(sv) <= AvFILL(av))
2338 if (SvRMAGICAL(av)) {
2339 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2340 targ = svp ? *svp : NULL;
2343 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2346 if (targ && (targ != &PL_sv_undef)) {
2347 /* somebody else defined it for us */
2348 SvREFCNT_dec(LvTARG(sv));
2349 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2351 SvREFCNT_dec(mg->mg_obj);
2353 mg->mg_flags &= ~MGf_REFCOUNTED;
2362 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2364 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2366 sv_setsv(sv, defelem_target(sv, mg));
2371 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2373 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2374 PERL_UNUSED_ARG(mg);
2378 sv_setsv(LvTARG(sv), sv);
2379 SvSETMAGIC(LvTARG(sv));
2385 Perl_vivify_defelem(pTHX_ SV *sv)
2391 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2393 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2396 SV * const ahv = LvTARG(sv);
2397 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2400 if (!value || value == &PL_sv_undef)
2401 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2403 else if (LvSTARGOFF(sv) < 0)
2404 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2406 AV *const av = MUTABLE_AV(LvTARG(sv));
2407 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2408 LvTARG(sv) = NULL; /* array can't be extended */
2410 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2411 if (!svp || !(value = *svp))
2412 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2415 SvREFCNT_inc_simple_void(value);
2416 SvREFCNT_dec(LvTARG(sv));
2419 SvREFCNT_dec(mg->mg_obj);
2421 mg->mg_flags &= ~MGf_REFCOUNTED;
2425 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2427 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2428 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2433 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2435 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2436 PERL_UNUSED_CONTEXT;
2437 PERL_UNUSED_ARG(sv);
2443 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2445 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2447 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2449 if (uf && uf->uf_set)
2450 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2455 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2457 const char type = mg->mg_type;
2459 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2461 if (type == PERL_MAGIC_qr) {
2462 } else if (type == PERL_MAGIC_bm) {
2466 assert(type == PERL_MAGIC_fm);
2468 return sv_unmagic(sv, type);
2471 #ifdef USE_LOCALE_COLLATE
2473 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2475 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2478 * RenE<eacute> Descartes said "I think not."
2479 * and vanished with a faint plop.
2481 PERL_UNUSED_CONTEXT;
2482 PERL_UNUSED_ARG(sv);
2484 Safefree(mg->mg_ptr);
2490 #endif /* USE_LOCALE_COLLATE */
2492 /* Just clear the UTF-8 cache data. */
2494 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2496 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2497 PERL_UNUSED_CONTEXT;
2498 PERL_UNUSED_ARG(sv);
2499 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2501 mg->mg_len = -1; /* The mg_len holds the len cache. */
2506 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2516 PERL_ARGS_ASSERT_MAGIC_SET;
2520 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2522 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2524 /* Croak with a READONLY error when a numbered match var is
2525 * set without a previous pattern match. Unless it's C<local $1>
2528 if (!PL_localizing) {
2529 Perl_croak_no_modify();
2535 switch (*mg->mg_ptr) {
2536 case '\001': /* ^A */
2537 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2538 else SvOK_off(PL_bodytarget);
2539 FmLINES(PL_bodytarget) = 0;
2540 if (SvPOK(PL_bodytarget)) {
2541 char *s = SvPVX(PL_bodytarget);
2542 while ( ((s = strchr(s, '\n'))) ) {
2543 FmLINES(PL_bodytarget)++;
2547 /* mg_set() has temporarily made sv non-magical */
2549 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2550 SvTAINTED_on(PL_bodytarget);
2552 SvTAINTED_off(PL_bodytarget);
2555 case '\003': /* ^C */
2556 PL_minus_c = cBOOL(SvIV(sv));
2559 case '\004': /* ^D */
2561 s = SvPV_nolen_const(sv);
2562 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2563 if (DEBUG_x_TEST || DEBUG_B_TEST)
2564 dump_all_perl(!DEBUG_B_TEST);
2566 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2569 case '\005': /* ^E */
2570 if (*(mg->mg_ptr+1) == '\0') {
2572 set_vaxc_errno(SvIV(sv));
2575 SetLastError( SvIV(sv) );
2578 os2_setsyserrno(SvIV(sv));
2580 /* will anyone ever use this? */
2581 SETERRNO(SvIV(sv), 4);
2586 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2587 SvREFCNT_dec(PL_encoding);
2588 if (SvOK(sv) || SvGMAGICAL(sv)) {
2589 PL_encoding = newSVsv(sv);
2596 case '\006': /* ^F */
2597 PL_maxsysfd = SvIV(sv);
2599 case '\010': /* ^H */
2600 PL_hints = SvIV(sv);
2602 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2603 Safefree(PL_inplace);
2604 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2606 case '\016': /* ^N */
2607 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2608 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2610 case '\017': /* ^O */
2611 if (*(mg->mg_ptr+1) == '\0') {
2612 Safefree(PL_osname);
2615 TAINT_PROPER("assigning to $^O");
2616 PL_osname = savesvpv(sv);
2619 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2621 const char *const start = SvPV(sv, len);
2622 const char *out = (const char*)memchr(start, '\0', len);
2626 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2627 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2629 /* Opening for input is more common than opening for output, so
2630 ensure that hints for input are sooner on linked list. */
2631 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2633 : newSVpvs_flags("", SvUTF8(sv));
2634 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2637 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2639 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2643 case '\020': /* ^P */
2644 PL_perldb = SvIV(sv);
2645 if (PL_perldb && !PL_DBsingle)
2648 case '\024': /* ^T */
2650 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2652 PL_basetime = (Time_t)SvIV(sv);
2655 case '\025': /* ^UTF8CACHE */
2656 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2657 PL_utf8cache = (signed char) sv_2iv(sv);
2660 case '\027': /* ^W & $^WARNING_BITS */
2661 if (*(mg->mg_ptr+1) == '\0') {
2662 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2664 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2665 | (i ? G_WARN_ON : G_WARN_OFF) ;
2668 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2669 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2671 PL_compiling.cop_warnings = pWARN_STD;
2676 int accumulate = 0 ;
2677 int any_fatals = 0 ;
2678 const char * const ptr = SvPV_const(sv, len) ;
2679 for (i = 0 ; i < len ; ++i) {
2680 accumulate |= ptr[i] ;
2681 any_fatals |= (ptr[i] & 0xAA) ;
2684 if (!specialWARN(PL_compiling.cop_warnings))
2685 PerlMemShared_free(PL_compiling.cop_warnings);
2686 PL_compiling.cop_warnings = pWARN_NONE;
2688 /* Yuck. I can't see how to abstract this: */
2690 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2694 if (!specialWARN(PL_compiling.cop_warnings))
2695 PerlMemShared_free(PL_compiling.cop_warnings);
2696 PL_compiling.cop_warnings = pWARN_ALL;
2697 PL_dowarn |= G_WARN_ONCE ;
2701 const char *const p = SvPV_const(sv, len);
2703 PL_compiling.cop_warnings
2704 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2707 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2708 PL_dowarn |= G_WARN_ONCE ;
2716 if (PL_localizing) {
2717 if (PL_localizing == 1)
2718 SAVESPTR(PL_last_in_gv);
2720 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2721 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2724 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2725 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2726 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2729 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2730 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2731 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2734 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2737 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2738 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2739 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2742 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2746 IO * const io = GvIO(PL_defoutgv);
2749 if ((SvIV(sv)) == 0)
2750 IoFLAGS(io) &= ~IOf_FLUSH;
2752 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2753 PerlIO *ofp = IoOFP(io);
2755 (void)PerlIO_flush(ofp);
2756 IoFLAGS(io) |= IOf_FLUSH;
2765 SV *referent= SvRV(sv);
2766 const char *reftype= sv_reftype(referent, 0);
2767 /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
2768 * is to copy pretty much the entire sv_reftype() into this routine, or to do
2769 * a full string comparison on the return of sv_reftype() both of which
2770 * make me feel worse! NOTE, do not modify this comment without reviewing the
2771 * corresponding comment in sv_reftype(). - Yves */
2772 if (reftype[0] == 'S' || reftype[0] == 'L') {
2773 IV val= SvIV(referent);
2775 tmpsv= &PL_sv_undef;
2776 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
2777 "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
2778 SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2782 /* diag_listed_as: Setting $/ to %s reference is forbidden */
2783 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2784 *reftype == 'A' ? "n" : "", reftype);
2787 SvREFCNT_dec(PL_rs);
2788 PL_rs = newSVsv(tmpsv);
2792 SvREFCNT_dec(PL_ors_sv);
2794 PL_ors_sv = newSVsv(sv);
2802 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2805 #ifdef COMPLEX_STATUS
2806 if (PL_localizing == 2) {
2807 SvUPGRADE(sv, SVt_PVLV);
2808 PL_statusvalue = LvTARGOFF(sv);
2809 PL_statusvalue_vms = LvTARGLEN(sv);
2813 #ifdef VMSISH_STATUS
2815 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2818 STATUS_UNIX_EXIT_SET(SvIV(sv));
2823 # define PERL_VMS_BANG vaxc$errno
2825 # define PERL_VMS_BANG 0
2827 #if defined(WIN32) && ! defined(UNDER_CE)
2828 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2829 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2831 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2832 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2839 const Uid_t new_uid = SvUID(sv);
2840 PL_delaymagic_uid = new_uid;
2841 if (PL_delaymagic) {
2842 PL_delaymagic |= DM_RUID;
2843 break; /* don't do magic till later */
2846 rc = setruid(new_uid);
2849 rc = setreuid(new_uid, (Uid_t)-1);
2851 #ifdef HAS_SETRESUID
2852 rc = setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2854 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2856 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2857 if (new_uid != 0 && PerlProc_getuid() == 0)
2858 rc = PerlProc_setuid(0);
2860 rc = PerlProc_setuid(new_uid);
2862 Perl_croak(aTHX_ "setruid() not implemented");
2867 /* XXX $< currently silently ignores failures */
2868 PERL_UNUSED_VAR(rc);
2874 const Uid_t new_euid = SvUID(sv);
2875 PL_delaymagic_euid = new_euid;
2876 if (PL_delaymagic) {
2877 PL_delaymagic |= DM_EUID;
2878 break; /* don't do magic till later */
2881 rc = seteuid(new_euid);
2884 rc = setreuid((Uid_t)-1, new_euid);
2886 #ifdef HAS_SETRESUID
2887 rc = setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2889 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2890 rc = PerlProc_setuid(new_euid);
2892 Perl_croak(aTHX_ "seteuid() not implemented");
2897 /* XXX $> currently silently ignores failures */
2898 PERL_UNUSED_VAR(rc);
2904 const Gid_t new_gid = SvGID(sv);
2905 PL_delaymagic_gid = new_gid;
2906 if (PL_delaymagic) {
2907 PL_delaymagic |= DM_RGID;
2908 break; /* don't do magic till later */
2911 rc = setrgid(new_gid);
2914 rc = setregid(new_gid, (Gid_t)-1);
2916 #ifdef HAS_SETRESGID
2917 rc = setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2919 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2920 rc = PerlProc_setgid(new_gid);
2922 Perl_croak(aTHX_ "setrgid() not implemented");
2927 /* XXX $( currently silently ignores failures */
2928 PERL_UNUSED_VAR(rc);
2935 #ifdef HAS_SETGROUPS
2937 const char *p = SvPV_const(sv, len);
2938 Groups_t *gary = NULL;
2939 #ifdef _SC_NGROUPS_MAX
2940 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2945 int maxgrp = NGROUPS;
2950 new_egid = (Gid_t)Atol(p);
2951 for (i = 0; i < maxgrp; ++i) {
2952 while (*p && !isSPACE(*p))
2959 Newx(gary, i + 1, Groups_t);
2961 Renew(gary, i + 1, Groups_t);
2962 gary[i] = (Groups_t)Atol(p);
2965 rc = setgroups(i, gary);
2968 #else /* HAS_SETGROUPS */
2969 new_egid = SvGID(sv);
2970 #endif /* HAS_SETGROUPS */
2971 PL_delaymagic_egid = new_egid;
2972 if (PL_delaymagic) {
2973 PL_delaymagic |= DM_EGID;
2974 break; /* don't do magic till later */
2977 rc = setegid(new_egid);
2980 rc = setregid((Gid_t)-1, new_egid);
2982 #ifdef HAS_SETRESGID
2983 rc = setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2985 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2986 rc = PerlProc_setgid(new_egid);
2988 Perl_croak(aTHX_ "setegid() not implemented");
2993 /* XXX $) currently silently ignores failures */
2994 PERL_UNUSED_VAR(rc);
2998 PL_chopset = SvPV_force(sv,len);
3001 /* Store the pid in mg->mg_obj so we can tell when a fork has
3002 occurred. mg->mg_obj points to *$ by default, so clear it. */
3003 if (isGV(mg->mg_obj)) {
3004 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3005 SvREFCNT_dec(mg->mg_obj);
3006 mg->mg_flags |= MGf_REFCOUNTED;
3007 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3009 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3012 LOCK_DOLLARZERO_MUTEX;
3013 #ifdef HAS_SETPROCTITLE
3014 /* The BSDs don't show the argv[] in ps(1) output, they
3015 * show a string from the process struct and provide
3016 * the setproctitle() routine to manipulate that. */
3017 if (PL_origalen != 1) {
3018 s = SvPV_const(sv, len);
3019 # if __FreeBSD_version > 410001
3020 /* The leading "-" removes the "perl: " prefix,
3021 * but not the "(perl) suffix from the ps(1)
3022 * output, because that's what ps(1) shows if the
3023 * argv[] is modified. */
3024 setproctitle("-%s", s);
3025 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
3026 /* This doesn't really work if you assume that
3027 * $0 = 'foobar'; will wipe out 'perl' from the $0
3028 * because in ps(1) output the result will be like
3029 * sprintf("perl: %s (perl)", s)
3030 * I guess this is a security feature:
3031 * one (a user process) cannot get rid of the original name.
3033 setproctitle("%s", s);
3036 #elif defined(__hpux) && defined(PSTAT_SETCMD)
3037 if (PL_origalen != 1) {
3039 s = SvPV_const(sv, len);
3040 un.pst_command = (char *)s;
3041 pstat(PSTAT_SETCMD, un, len, 0, 0);
3044 if (PL_origalen > 1) {
3045 /* PL_origalen is set in perl_parse(). */
3046 s = SvPV_force(sv,len);
3047 if (len >= (STRLEN)PL_origalen-1) {
3048 /* Longer than original, will be truncated. We assume that
3049 * PL_origalen bytes are available. */
3050 Copy(s, PL_origargv[0], PL_origalen-1, char);
3053 /* Shorter than original, will be padded. */
3055 /* Special case for Mac OS X: see [perl #38868] */
3058 /* Is the space counterintuitive? Yes.
3059 * (You were expecting \0?)
3060 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3062 const int pad = ' ';
3064 Copy(s, PL_origargv[0], len, char);
3065 PL_origargv[0][len] = 0;
3066 memset(PL_origargv[0] + len + 1,
3067 pad, PL_origalen - len - 1);
3069 PL_origargv[0][PL_origalen-1] = 0;
3070 for (i = 1; i < PL_origargc; i++)
3072 #ifdef HAS_PRCTL_SET_NAME
3073 /* Set the legacy process name in addition to the POSIX name on Linux */
3074 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3075 /* diag_listed_as: SKIPME */
3076 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3081 UNLOCK_DOLLARZERO_MUTEX;
3088 Perl_whichsig_sv(pTHX_ SV *sigsv)
3092 PERL_ARGS_ASSERT_WHICHSIG_SV;
3093 PERL_UNUSED_CONTEXT;
3094 sigpv = SvPV_const(sigsv, siglen);
3095 return whichsig_pvn(sigpv, siglen);
3099 Perl_whichsig_pv(pTHX_ const char *sig)
3101 PERL_ARGS_ASSERT_WHICHSIG_PV;
3102 PERL_UNUSED_CONTEXT;
3103 return whichsig_pvn(sig, strlen(sig));
3107 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3111 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3112 PERL_UNUSED_CONTEXT;
3114 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3115 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3116 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3118 if (memEQs(sig, len, "CHLD"))
3122 if (memEQs(sig, len, "CLD"))
3129 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3130 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3132 Perl_sighandler(int sig)
3135 #ifdef PERL_GET_SIG_CONTEXT
3136 dTHXa(PERL_GET_SIG_CONTEXT);
3143 SV * const tSv = PL_Sv;
3147 XPV * const tXpv = PL_Xpv;
3148 I32 old_ss_ix = PL_savestack_ix;
3149 SV *errsv_save = NULL;
3152 if (!PL_psig_ptr[sig]) {
3153 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3158 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3159 /* Max number of items pushed there is 3*n or 4. We cannot fix
3160 infinity, so we fix 4 (in fact 5): */
3161 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3163 PL_savestack_ix += 5; /* Protect save in progress. */
3164 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3167 /* sv_2cv is too complicated, try a simpler variant first: */
3168 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3169 || SvTYPE(cv) != SVt_PVCV) {
3171 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3174 if (!cv || !CvROOT(cv)) {
3175 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3176 PL_sig_name[sig], (gv ? GvENAME(gv)
3183 sv = PL_psig_name[sig]
3184 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3185 : newSVpv(PL_sig_name[sig],0);
3189 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3190 /* make sure our assumption about the size of the SAVEs are correct:
3191 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3192 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3195 PUSHSTACKi(PERLSI_SIGNAL);
3198 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3200 struct sigaction oact;
3202 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3205 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3206 /* The siginfo fields signo, code, errno, pid, uid,
3207 * addr, status, and band are defined by POSIX/SUSv3. */
3208 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3209 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3210 #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. */
3211 hv_stores(sih, "errno", newSViv(sip->si_errno));
3212 hv_stores(sih, "status", newSViv(sip->si_status));
3213 hv_stores(sih, "uid", newSViv(sip->si_uid));
3214 hv_stores(sih, "pid", newSViv(sip->si_pid));
3215 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3216 hv_stores(sih, "band", newSViv(sip->si_band));
3220 mPUSHp((char *)sip, sizeof(*sip));
3228 errsv_save = newSVsv(ERRSV);
3230 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3234 SV * const errsv = ERRSV;
3235 if (SvTRUE_NN(errsv)) {
3236 SvREFCNT_dec(errsv_save);
3238 /* Handler "died", for example to get out of a restart-able read().
3239 * Before we re-do that on its behalf re-enable the signal which was
3240 * blocked by the system when we entered.
3242 #ifdef HAS_SIGPROCMASK
3243 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3249 sigaddset(&set,sig);
3250 sigprocmask(SIG_UNBLOCK, &set, NULL);
3253 /* Not clear if this will work */
3254 (void)rsignal(sig, SIG_IGN);
3255 (void)rsignal(sig, PL_csighandlerp);
3257 #endif /* !PERL_MICRO */
3261 sv_setsv(errsv, errsv_save);
3262 SvREFCNT_dec(errsv_save);
3267 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3268 PL_savestack_ix = old_ss_ix;
3270 SvREFCNT_dec_NN(sv);
3271 PL_op = myop; /* Apparently not needed... */
3273 PL_Sv = tSv; /* Restore global temporaries. */
3280 S_restore_magic(pTHX_ const void *p)
3283 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3284 SV* const sv = mgs->mgs_sv;
3290 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3291 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3292 #ifdef PERL_OLD_COPY_ON_WRITE
3293 /* While magic was saved (and off) sv_setsv may well have seen
3294 this SV as a prime candidate for COW. */
3296 sv_force_normal_flags(sv, 0);
3298 if (mgs->mgs_readonly)
3300 if (mgs->mgs_magical)
3301 SvFLAGS(sv) |= mgs->mgs_magical;
3306 bumped = mgs->mgs_bumped;
3307 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3309 /* If we're still on top of the stack, pop us off. (That condition
3310 * will be satisfied if restore_magic was called explicitly, but *not*
3311 * if it's being called via leave_scope.)
3312 * The reason for doing this is that otherwise, things like sv_2cv()
3313 * may leave alloc gunk on the savestack, and some code
3314 * (e.g. sighandler) doesn't expect that...
3316 if (PL_savestack_ix == mgs->mgs_ss_ix)
3318 UV popval = SSPOPUV;
3319 assert(popval == SAVEt_DESTRUCTOR_X);
3320 PL_savestack_ix -= 2;
3322 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3323 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3326 if (SvREFCNT(sv) == 1) {
3327 /* We hold the last reference to this SV, which implies that the
3328 SV was deleted as a side effect of the routines we called.
3329 So artificially keep it alive a bit longer.
3330 We avoid turning on the TEMP flag, which can cause the SV's
3331 buffer to get stolen (and maybe other stuff). */
3336 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3340 /* clean up the mess created by Perl_sighandler().
3341 * Note that this is only called during an exit in a signal handler;
3342 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3346 S_unwind_handler_stack(pTHX_ const void *p)
3351 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3355 =for apidoc magic_sethint
3357 Triggered by a store to %^H, records the key/value pair to
3358 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3359 anything that would need a deep copy. Maybe we should warn if we find a
3365 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3368 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3369 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3371 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3373 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3374 an alternative leaf in there, with PL_compiling.cop_hints being used if
3375 it's NULL. If needed for threads, the alternative could lock a mutex,
3376 or take other more complex action. */
3378 /* Something changed in %^H, so it will need to be restored on scope exit.
3379 Doing this here saves a lot of doing it manually in perl code (and
3380 forgetting to do it, and consequent subtle errors. */
3381 PL_hints |= HINT_LOCALIZE_HH;
3382 CopHINTHASH_set(&PL_compiling,
3383 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3388 =for apidoc magic_clearhint
3390 Triggered by a delete from %^H, records the key to
3391 C<PL_compiling.cop_hints_hash>.
3396 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3400 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3401 PERL_UNUSED_ARG(sv);
3403 PL_hints |= HINT_LOCALIZE_HH;
3404 CopHINTHASH_set(&PL_compiling,
3405 mg->mg_len == HEf_SVKEY
3406 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3407 MUTABLE_SV(mg->mg_ptr), 0, 0)
3408 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3409 mg->mg_ptr, mg->mg_len, 0, 0));
3414 =for apidoc magic_clearhints
3416 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3421 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3423 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3424 PERL_UNUSED_ARG(sv);
3425 PERL_UNUSED_ARG(mg);
3426 cophh_free(CopHINTHASH_get(&PL_compiling));
3427 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3432 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3433 const char *name, I32 namlen)
3437 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3438 PERL_UNUSED_ARG(sv);
3439 PERL_UNUSED_ARG(name);
3440 PERL_UNUSED_ARG(namlen);
3442 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3443 nmg = mg_find(nsv, mg->mg_type);
3445 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3446 nmg->mg_ptr = mg->mg_ptr;
3447 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3448 nmg->mg_flags |= MGf_REFCOUNTED;
3454 * c-indentation-style: bsd
3456 * indent-tabs-mode: nil
3459 * ex: set ts=8 sts=4 sw=4 et: