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
46 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 #if defined(HAS_SETGROUPS)
59 # include <sys/pstat.h>
62 #ifdef HAS_PRCTL_SET_NAME
63 # include <sys/prctl.h>
67 /* Missing protos on LynxOS */
68 void setruid(uid_t id);
69 void seteuid(uid_t id);
70 void setrgid(uid_t id);
71 void setegid(uid_t id);
75 * Pre-magic setup and post-magic takedown.
76 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
85 /* MGS is typedef'ed to struct magic_state in perl.h */
88 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
93 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
95 assert(SvMAGICAL(sv));
97 /* we shouldn't really be called here with RC==0, but it can sometimes
98 * happen via mg_clear() (which also shouldn't be called when RC==0,
99 * but it can happen). Handle this case gracefully(ish) by not RC++
100 * and thus avoiding the resultant double free */
101 if (SvREFCNT(sv) > 0) {
102 /* guard against sv getting freed midway through the mg clearing,
103 * by holding a private reference for the duration. */
104 SvREFCNT_inc_simple_void_NN(sv);
108 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
110 mgs = SSPTR(mgs_ix, MGS*);
112 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
113 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
114 mgs->mgs_bumped = bumped;
116 SvFLAGS(sv) &= ~flags;
120 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
123 =for apidoc mg_magical
125 Turns on the magical status of an SV. See C<L</sv_magic>>.
131 Perl_mg_magical(SV *sv)
134 PERL_ARGS_ASSERT_MG_MAGICAL;
137 if ((mg = SvMAGIC(sv))) {
139 const MGVTBL* const vtbl = mg->mg_virtual;
141 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
148 } while ((mg = mg->mg_moremagic));
149 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
157 Do magic before a value is retrieved from the SV. The type of SV must
158 be >= C<SVt_PVMG>. See C<L</sv_magic>>.
164 Perl_mg_get(pTHX_ SV *sv)
166 const I32 mgs_ix = SSNEW(sizeof(MGS));
169 bool taint_only = TRUE; /* the only get method seen is taint */
170 MAGIC *newmg, *head, *cur, *mg;
172 PERL_ARGS_ASSERT_MG_GET;
174 if (PL_localizing == 1 && sv == DEFSV) return 0;
176 /* We must call svt_get(sv, mg) for each valid entry in the linked
177 list of magic. svt_get() may delete the current entry, add new
178 magic to the head of the list, or upgrade the SV. AMS 20010810 */
180 newmg = cur = head = mg = SvMAGIC(sv);
182 const MGVTBL * const vtbl = mg->mg_virtual;
183 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
185 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
187 /* taint's mg get is so dumb it doesn't need flag saving */
188 if (mg->mg_type != PERL_MAGIC_taint) {
191 save_magic(mgs_ix, sv);
196 vtbl->svt_get(aTHX_ sv, mg);
198 /* guard against magic having been deleted - eg FETCH calling
201 /* recalculate flags */
202 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
206 /* recalculate flags if this entry was deleted. */
207 if (mg->mg_flags & MGf_GSKIP)
208 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
209 ~(SVs_GMG|SVs_SMG|SVs_RMG);
211 else if (vtbl == &PL_vtbl_utf8) {
212 /* get-magic can reallocate the PV, unless there's only taint
216 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
217 if ( mg2->mg_type != PERL_MAGIC_taint
218 && !(mg2->mg_flags & MGf_GSKIP)
220 && mg2->mg_virtual->svt_get
228 magic_setutf8(sv, mg);
234 /* Have we finished with the new entries we saw? Start again
235 where we left off (unless there are more new entries). */
243 /* Were any new entries added? */
244 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
248 /* recalculate flags */
249 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
254 restore_magic(INT2PTR(void *, (IV)mgs_ix));
262 Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
268 Perl_mg_set(pTHX_ SV *sv)
270 const I32 mgs_ix = SSNEW(sizeof(MGS));
274 PERL_ARGS_ASSERT_MG_SET;
276 if (PL_localizing == 2 && sv == DEFSV) return 0;
278 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
280 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
281 const MGVTBL* vtbl = mg->mg_virtual;
282 nextmg = mg->mg_moremagic; /* it may delete itself */
283 if (mg->mg_flags & MGf_GSKIP) {
284 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
285 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
287 if (PL_localizing == 2
288 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
290 if (vtbl && vtbl->svt_set)
291 vtbl->svt_set(aTHX_ sv, mg);
294 restore_magic(INT2PTR(void*, (IV)mgs_ix));
299 =for apidoc mg_length
301 Reports on the SV's length in bytes, calling length magic if available,
302 but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
303 magic if there is no 'length' magic, but with no indication as to
304 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
305 higher. Use C<sv_len()> instead.
311 Perl_mg_length(pTHX_ SV *sv)
316 PERL_ARGS_ASSERT_MG_LENGTH;
318 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
319 const MGVTBL * const vtbl = mg->mg_virtual;
320 if (vtbl && vtbl->svt_len) {
321 const I32 mgs_ix = SSNEW(sizeof(MGS));
322 save_magic(mgs_ix, sv);
323 /* omit MGf_GSKIP -- not changed here */
324 len = vtbl->svt_len(aTHX_ sv, mg);
325 restore_magic(INT2PTR(void*, (IV)mgs_ix));
330 (void)SvPV_const(sv, len);
335 Perl_mg_size(pTHX_ SV *sv)
339 PERL_ARGS_ASSERT_MG_SIZE;
341 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
342 const MGVTBL* const vtbl = mg->mg_virtual;
343 if (vtbl && vtbl->svt_len) {
344 const I32 mgs_ix = SSNEW(sizeof(MGS));
346 save_magic(mgs_ix, sv);
347 /* omit MGf_GSKIP -- not changed here */
348 len = vtbl->svt_len(aTHX_ sv, mg);
349 restore_magic(INT2PTR(void*, (IV)mgs_ix));
356 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
360 Perl_croak(aTHX_ "Size magic not implemented");
363 NOT_REACHED; /* NOTREACHED */
369 Clear something magical that the SV represents. See C<L</sv_magic>>.
375 Perl_mg_clear(pTHX_ SV *sv)
377 const I32 mgs_ix = SSNEW(sizeof(MGS));
381 PERL_ARGS_ASSERT_MG_CLEAR;
383 save_magic(mgs_ix, sv);
385 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
386 const MGVTBL* const vtbl = mg->mg_virtual;
387 /* omit GSKIP -- never set here */
389 nextmg = mg->mg_moremagic; /* it may delete itself */
391 if (vtbl && vtbl->svt_clear)
392 vtbl->svt_clear(aTHX_ sv, mg);
395 restore_magic(INT2PTR(void*, (IV)mgs_ix));
400 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
407 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
408 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
420 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
426 Perl_mg_find(const SV *sv, int type)
428 return S_mg_findext_flags(sv, type, NULL, 0);
432 =for apidoc mg_findext
434 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
441 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
443 return S_mg_findext_flags(sv, type, vtbl, 1);
447 Perl_mg_find_mglob(pTHX_ SV *sv)
449 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
450 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
451 /* This sv is only a delegate. //g magic must be attached to
456 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
457 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
464 Copies the magic from one SV to another. See C<L</sv_magic>>.
470 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
475 PERL_ARGS_ASSERT_MG_COPY;
477 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
478 const MGVTBL* const vtbl = mg->mg_virtual;
479 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
480 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
483 const char type = mg->mg_type;
484 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
486 (type == PERL_MAGIC_tied)
489 toLOWER(type), key, klen);
498 =for apidoc mg_localize
500 Copy some of the magic from an existing SV to new localized version of that
501 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
502 gets copied, value magic doesn't (I<e.g.>,
505 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
506 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
507 and that will handle the magic.
513 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
517 PERL_ARGS_ASSERT_MG_LOCALIZE;
522 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
523 const MGVTBL* const vtbl = mg->mg_virtual;
524 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
527 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
528 (void)vtbl->svt_local(aTHX_ nsv, mg);
530 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
531 mg->mg_ptr, mg->mg_len);
533 /* container types should remain read-only across localization */
534 SvFLAGS(nsv) |= SvREADONLY(sv);
537 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
538 SvFLAGS(nsv) |= SvMAGICAL(sv);
547 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
549 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
551 const MGVTBL* const vtbl = mg->mg_virtual;
552 if (vtbl && vtbl->svt_free)
553 vtbl->svt_free(aTHX_ sv, mg);
555 if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
556 /* collate magic uses string len not buffer len, so
557 * free even with mg_len == 0 */
558 Safefree(mg->mg_ptr);
559 else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
560 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
561 Safefree(mg->mg_ptr);
562 else if (mg->mg_len == HEf_SVKEY)
563 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
566 if (mg->mg_flags & MGf_REFCOUNTED)
567 SvREFCNT_dec(mg->mg_obj);
574 Free any magic storage used by the SV. See C<L</sv_magic>>.
580 Perl_mg_free(pTHX_ SV *sv)
585 PERL_ARGS_ASSERT_MG_FREE;
587 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
588 moremagic = mg->mg_moremagic;
589 mg_free_struct(sv, mg);
590 SvMAGIC_set(sv, moremagic);
592 SvMAGIC_set(sv, NULL);
598 =for apidoc mg_free_type
600 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
606 Perl_mg_free_type(pTHX_ SV *sv, int how)
608 MAGIC *mg, *prevmg, *moremg;
609 PERL_ARGS_ASSERT_MG_FREE_TYPE;
610 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
611 moremg = mg->mg_moremagic;
612 if (mg->mg_type == how) {
614 /* temporarily move to the head of the magic chain, in case
615 custom free code relies on this historical aspect of mg_free */
617 prevmg->mg_moremagic = moremg;
618 mg->mg_moremagic = SvMAGIC(sv);
621 newhead = mg->mg_moremagic;
622 mg_free_struct(sv, mg);
623 SvMAGIC_set(sv, newhead);
631 =for apidoc mg_freeext
633 Remove any magic of type C<how> using virtual table C<vtbl> from the
634 SV C<sv>. See L</sv_magic>.
636 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
642 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
644 MAGIC *mg, *prevmg, *moremg;
645 PERL_ARGS_ASSERT_MG_FREEEXT;
646 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
648 moremg = mg->mg_moremagic;
649 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
650 /* temporarily move to the head of the magic chain, in case
651 custom free code relies on this historical aspect of mg_free */
653 prevmg->mg_moremagic = moremg;
654 mg->mg_moremagic = SvMAGIC(sv);
657 newhead = mg->mg_moremagic;
658 mg_free_struct(sv, mg);
659 SvMAGIC_set(sv, newhead);
669 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
673 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
676 REGEXP * const rx = PM_GETRE(PL_curpm);
678 const SSize_t n = (SSize_t)mg->mg_obj;
679 if (n == '+') { /* @+ */
680 /* return the number possible */
681 return RX_NPARENS(rx);
682 } else { /* @- @^CAPTURE @{^CAPTURE} */
683 I32 paren = RX_LASTPAREN(rx);
685 /* return the last filled */
687 && (RX_OFFS(rx)[paren].start == -1
688 || RX_OFFS(rx)[paren].end == -1) )
694 /* @^CAPTURE @{^CAPTURE} */
695 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
707 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
709 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
712 REGEXP * const rx = PM_GETRE(PL_curpm);
714 const SSize_t n = (SSize_t)mg->mg_obj;
715 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
716 const I32 paren = mg->mg_len
717 + (n == '\003' ? 1 : 0);
722 if (paren <= (I32)RX_NPARENS(rx) &&
723 (s = RX_OFFS(rx)[paren].start) != -1 &&
724 (t = RX_OFFS(rx)[paren].end) != -1)
728 if (n == '+') /* @+ */
730 else if (n == '-') /* @- */
732 else { /* @^CAPTURE @{^CAPTURE} */
733 CALLREG_NUMBUF_FETCH(rx,paren,sv);
737 if (RX_MATCH_UTF8(rx)) {
738 const char * const b = RX_SUBBEG(rx);
740 i = RX_SUBCOFFSET(rx) +
742 (U8*)(b-RX_SUBOFFSET(rx)+i));
757 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
759 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
763 Perl_croak_no_modify();
764 NORETURN_FUNCTION_END;
767 #define SvRTRIM(sv) STMT_START { \
769 STRLEN len = SvCUR(sv); \
770 char * const p = SvPVX(sv); \
771 while (len > 0 && isSPACE(p[len-1])) \
773 SvCUR_set(sv, len); \
779 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
781 PERL_ARGS_ASSERT_EMULATE_COP_IO;
783 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
788 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
789 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
794 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
795 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
803 S_fixup_errno_string(pTHX_ SV* sv)
805 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
808 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
812 if(strEQ(SvPVX(sv), "")) {
813 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
817 /* In some locales the error string may come back as UTF-8, in which
818 * case we should turn on that flag. This didn't use to happen, and to
819 * avoid as many possible backward compatibility issues as possible, we
820 * don't turn on the flag unless we have to. So the flag stays off for
821 * an entirely invariant string. We assume that if the string looks
822 * like UTF-8 in a single script, it really is UTF-8: "text in any
823 * other encoding that uses bytes with the high bit set is extremely
824 * unlikely to pass a UTF-8 validity test"
825 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
826 * potential that we will get it wrong however, especially on short
827 * error message text, so do an additional check. */
828 if ( ! IN_BYTES /* respect 'use bytes' */
829 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
831 #ifdef USE_LOCALE_MESSAGES
833 && _is_cur_LC_category_utf8(LC_MESSAGES)
835 #else /* If can't check directly, at least can see if script is consistent,
836 under UTF-8, which gives us an extra measure of confidence. */
838 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
839 TRUE) /* Means assume UTF-8 */
849 =for apidoc sv_string_from_errnum
851 Generates the message string describing an OS error and returns it as
852 an SV. C<errnum> must be a value that C<errno> could take, identifying
855 If C<tgtsv> is non-null then the string will be written into that SV
856 (overwriting existing content) and it will be returned. If C<tgtsv>
857 is a null pointer then the string will be written into a new mortal SV
858 which will be returned.
860 The message will be taken from whatever locale would be used by C<$!>,
861 and will be encoded in the SV in whatever manner would be used by C<$!>.
862 The details of this process are subject to future change. Currently,
863 the message is taken from the C locale by default (usually producing an
864 English message), and from the currently selected locale when in the scope
865 of the C<use locale> pragma. A heuristic attempt is made to decode the
866 message from the locale's character encoding, but it will only be decoded
867 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
868 locale, usually in an ISO-8859-1 locale, and never in any other locale.
870 The SV is always returned containing an actual string, and with no other
871 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
872 (meaning success), and if no useful message is available then a useless
873 string (currently empty) is returned.
879 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
883 tgtsv = sv_newmortal();
884 errstr = my_strerror(errnum);
886 sv_setpv(tgtsv, errstr);
887 fixup_errno_string(tgtsv);
900 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
903 const char *s = NULL;
905 const char * const remaining = mg->mg_ptr + 1;
908 PERL_ARGS_ASSERT_MAGIC_GET;
912 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
914 CALLREG_NUMBUF_FETCH(rx,paren,sv);
921 nextchar = *remaining;
922 switch (*mg->mg_ptr) {
923 case '\001': /* ^A */
924 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
927 if (SvTAINTED(PL_bodytarget))
930 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
931 if (nextchar == '\0') {
932 sv_setiv(sv, (IV)PL_minus_c);
934 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
935 sv_setiv(sv, (IV)STATUS_NATIVE);
939 case '\004': /* ^D */
940 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
942 case '\005': /* ^E */
943 if (nextchar != '\0') {
944 if (strEQ(remaining, "NCODING"))
949 #if defined(VMS) || defined(OS2) || defined(WIN32)
953 $DESCRIPTOR(msgdsc,msg);
954 sv_setnv(sv,(NV) vaxc$errno);
955 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
956 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
961 if (!(_emx_env & 0x200)) { /* Under DOS */
962 sv_setnv(sv, (NV)errno);
963 sv_setpv(sv, errno ? my_strerror(errno) : "");
965 if (errno != errno_isOS2) {
966 const int tmp = _syserrno();
967 if (tmp) /* 2nd call to _syserrno() makes it 0 */
970 sv_setnv(sv, (NV)Perl_rc);
971 sv_setpv(sv, os2error(Perl_rc));
973 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
974 fixup_errno_string(sv);
976 # elif defined(WIN32)
978 const DWORD dwErr = GetLastError();
979 sv_setnv(sv, (NV)dwErr);
981 PerlProc_GetOSError(sv, dwErr);
982 fixup_errno_string(sv);
989 # error Missing code for platform
992 SvNOK_on(sv); /* what a wonderful hack! */
994 #endif /* End of platforms with special handling for $^E; others just fall
1002 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1004 sv_setnv(sv, (NV)errno);
1007 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1008 sv_setpv(sv, os2error(Perl_rc));
1015 sv_string_from_errnum(errno, sv);
1016 /* If no useful string is available, don't
1017 * claim to have a string part. The SvNOK_on()
1018 * below will cause just the number part to be valid */
1026 SvNOK_on(sv); /* what a wonderful hack! */
1029 case '\006': /* ^F */
1030 if (nextchar == '\0') {
1031 sv_setiv(sv, (IV)PL_maxsysfd);
1034 case '\007': /* ^GLOBAL_PHASE */
1035 if (strEQ(remaining, "LOBAL_PHASE")) {
1036 sv_setpvn(sv, PL_phase_names[PL_phase],
1037 strlen(PL_phase_names[PL_phase]));
1040 case '\010': /* ^H */
1041 sv_setuv(sv, PL_hints);
1043 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1044 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1046 case '\014': /* ^LAST_FH */
1047 if (strEQ(remaining, "AST_FH")) {
1048 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1049 assert(isGV_with_GP(PL_last_in_gv));
1050 SV_CHECK_THINKFIRST_COW_DROP(sv);
1051 prepare_SV_for_RV(sv);
1053 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
1061 case '\017': /* ^O & ^OPEN */
1062 if (nextchar == '\0') {
1063 sv_setpv(sv, PL_osname);
1066 else if (strEQ(remaining, "PEN")) {
1067 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1071 sv_setiv(sv, (IV)PL_perldb);
1073 case '\023': /* ^S */
1074 if (nextchar == '\0') {
1075 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1077 else if (PL_in_eval)
1078 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1082 else if (strEQ(remaining, "AFE_LOCALES")) {
1084 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1086 sv_setuv(sv, (UV) 1);
1089 sv_setuv(sv, (UV) 0);
1095 case '\024': /* ^T */
1096 if (nextchar == '\0') {
1098 sv_setnv(sv, PL_basetime);
1100 sv_setiv(sv, (IV)PL_basetime);
1103 else if (strEQ(remaining, "AINT"))
1104 sv_setiv(sv, TAINTING_get
1105 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1108 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1109 if (strEQ(remaining, "NICODE"))
1110 sv_setuv(sv, (UV) PL_unicode);
1111 else if (strEQ(remaining, "TF8LOCALE"))
1112 sv_setuv(sv, (UV) PL_utf8locale);
1113 else if (strEQ(remaining, "TF8CACHE"))
1114 sv_setiv(sv, (IV) PL_utf8cache);
1116 case '\027': /* ^W & $^WARNING_BITS */
1117 if (nextchar == '\0')
1118 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1119 else if (strEQ(remaining, "ARNING_BITS")) {
1120 if (PL_compiling.cop_warnings == pWARN_NONE) {
1121 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1123 else if (PL_compiling.cop_warnings == pWARN_STD) {
1126 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1127 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1130 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1131 *PL_compiling.cop_warnings);
1135 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
1136 sv_setiv(sv, w32_sloppystat);
1141 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1142 paren = RX_LASTPAREN(rx);
1144 goto do_numbuf_fetch;
1147 case '\016': /* ^N */
1148 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1149 paren = RX_LASTCLOSEPAREN(rx);
1151 goto do_numbuf_fetch;
1155 if (GvIO(PL_last_in_gv)) {
1156 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1161 sv_setiv(sv, (IV)STATUS_CURRENT);
1162 #ifdef COMPLEX_STATUS
1163 SvUPGRADE(sv, SVt_PVLV);
1164 LvTARGOFF(sv) = PL_statusvalue;
1165 LvTARGLEN(sv) = PL_statusvalue_vms;
1170 if (GvIOp(PL_defoutgv))
1171 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1175 sv_setpv(sv,GvENAME(PL_defoutgv));
1176 sv_catpvs(sv,"_TOP");
1180 if (GvIOp(PL_defoutgv))
1181 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1183 s = GvENAME(PL_defoutgv);
1187 if (GvIO(PL_defoutgv))
1188 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1191 if (GvIO(PL_defoutgv))
1192 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1195 if (GvIO(PL_defoutgv))
1196 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1205 if (GvIO(PL_defoutgv))
1206 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1210 sv_copypv(sv, PL_ors_sv);
1216 IV const pid = (IV)PerlProc_getpid();
1217 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1218 /* never set manually, or at least not since last fork */
1220 /* never unsafe, even if reading in a tainted expression */
1223 /* else a value has been assigned manually, so do nothing */
1227 sv_setuid(sv, PerlProc_getuid());
1230 sv_setuid(sv, PerlProc_geteuid());
1233 sv_setgid(sv, PerlProc_getgid());
1236 sv_setgid(sv, PerlProc_getegid());
1238 #ifdef HAS_GETGROUPS
1240 Groups_t *gary = NULL;
1241 I32 num_groups = getgroups(0, gary);
1242 if (num_groups > 0) {
1244 Newx(gary, num_groups, Groups_t);
1245 num_groups = getgroups(num_groups, gary);
1246 for (i = 0; i < num_groups; i++)
1247 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1251 (void)SvIOK_on(sv); /* what a wonderful hack! */
1265 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1267 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1269 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1271 if (uf && uf->uf_val)
1272 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1277 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1279 STRLEN len = 0, klen;
1280 const char * const key = MgPV_const(mg,klen);
1283 PERL_ARGS_ASSERT_MAGIC_SETENV;
1287 /* defined environment variables are byte strings; unfortunately
1288 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1289 (void)SvPV_force_nomg_nolen(sv);
1290 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1292 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1298 my_setenv(key, s); /* does the deed */
1300 #ifdef DYNAMIC_ENV_FETCH
1301 /* We just undefd an environment var. Is a replacement */
1302 /* waiting in the wings? */
1304 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1306 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1310 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
1311 /* And you'll never guess what the dog had */
1312 /* in its mouth... */
1314 MgTAINTEDDIR_off(mg);
1316 if (s && memEQs(key, klen, "DCL$PATH")) {
1317 char pathbuf[256], eltbuf[256], *cp, *elt;
1320 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1322 do { /* DCL$PATH may be a search list */
1323 while (1) { /* as may dev portion of any element */
1324 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1325 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1326 cando_by_name(S_IWUSR,0,elt) ) {
1327 MgTAINTEDDIR_on(mg);
1331 if ((cp = strchr(elt, ':')) != NULL)
1333 if (my_trnlnm(elt, eltbuf, j++))
1339 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1342 if (s && memEQs(key, klen, "PATH")) {
1343 const char * const strend = s + len;
1345 /* set MGf_TAINTEDDIR if any component of the new path is
1346 * relative or world-writeable */
1347 while (s < strend) {
1351 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1352 const char path_sep = PL_perllib_sep;
1354 const char path_sep = ':';
1356 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1357 s, strend, path_sep, &i);
1359 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1361 /* no colon thus no device name -- assume relative path */
1362 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1363 /* Using Unix separator, e.g. under bash, so act line Unix */
1364 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1366 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1368 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1369 MgTAINTEDDIR_on(mg);
1375 #endif /* neither OS2 nor WIN32 nor MSDOS */
1381 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1383 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1384 PERL_UNUSED_ARG(sv);
1385 my_setenv(MgPV_nolen_const(mg),NULL);
1390 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1392 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1393 PERL_UNUSED_ARG(mg);
1395 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1397 if (PL_localizing) {
1400 hv_iterinit(MUTABLE_HV(sv));
1401 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1403 my_setenv(hv_iterkey(entry, &keylen),
1404 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1412 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1414 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1415 PERL_UNUSED_ARG(sv);
1416 PERL_UNUSED_ARG(mg);
1418 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1426 #ifdef HAS_SIGPROCMASK
1428 restore_sigmask(pTHX_ SV *save_sv)
1430 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1431 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1435 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1437 /* Are we fetching a signal entry? */
1438 int i = (I16)mg->mg_private;
1440 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1444 const char * sig = MgPV_const(mg, siglen);
1445 mg->mg_private = i = whichsig_pvn(sig, siglen);
1450 sv_setsv(sv,PL_psig_ptr[i]);
1452 Sighandler_t sigstate = rsignal_state(i);
1453 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1454 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1457 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1458 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1461 /* cache state so we don't fetch it again */
1462 if(sigstate == (Sighandler_t) SIG_IGN)
1463 sv_setpvs(sv,"IGNORE");
1466 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1473 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1475 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1477 magic_setsig(NULL, mg);
1478 return sv_unmagic(sv, mg->mg_type);
1482 #ifdef PERL_USE_3ARG_SIGHANDLER
1484 Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
1486 Perl_csighandler3(sig, sip, uap);
1490 Perl_csighandler(int sig)
1492 Perl_csighandler3(sig, NULL, NULL);
1497 Perl_csighandler1(int sig)
1499 Perl_csighandler3(sig, NULL, NULL);
1502 /* Handler intended to directly handle signal calls from the kernel.
1503 * (Depending on configuration, the kernel may actually call one of the
1504 * wrappers csighandler() or csighandler1() instead.)
1505 * It either queues up the signal or dispatches it immediately depending
1506 * on whether safe signals are enabled and whether the signal is capable
1507 * of being deferred (e.g. SEGV isn't).
1511 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1513 #ifdef PERL_GET_SIG_CONTEXT
1514 dTHXa(PERL_GET_SIG_CONTEXT);
1519 #ifdef PERL_USE_3ARG_SIGHANDLER
1520 #if defined(__cplusplus) && defined(__GNUC__)
1521 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1522 * parameters would be warned about. */
1523 PERL_UNUSED_ARG(sip);
1524 PERL_UNUSED_ARG(uap);
1528 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1529 (void) rsignal(sig, PL_csighandlerp);
1530 if (PL_sig_ignoring[sig]) return;
1532 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1533 if (PL_sig_defaulting[sig])
1534 #ifdef KILL_BY_SIGPRC
1535 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1550 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1551 /* Call the perl level handler now--
1552 * with risk we may be in malloc() or being destructed etc. */
1554 if (PL_sighandlerp == Perl_sighandler)
1555 /* default handler, so can call perly_sighandler() directly
1556 * rather than via Perl_sighandler, passing the extra
1557 * 'safe = false' arg
1559 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
1561 #ifdef PERL_USE_3ARG_SIGHANDLER
1562 (*PL_sighandlerp)(sig, NULL, NULL);
1564 (*PL_sighandlerp)(sig);
1568 if (!PL_psig_pend) return;
1569 /* Set a flag to say this signal is pending, that is awaiting delivery after
1570 * the current Perl opcode completes */
1571 PL_psig_pend[sig]++;
1573 #ifndef SIG_PENDING_DIE_COUNT
1574 # define SIG_PENDING_DIE_COUNT 120
1576 /* Add one to say _a_ signal is pending */
1577 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1578 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1579 (unsigned long)SIG_PENDING_DIE_COUNT);
1583 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1585 Perl_csighandler_init(void)
1588 if (PL_sig_handlers_initted) return;
1590 for (sig = 1; sig < SIG_SIZE; sig++) {
1591 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1593 PL_sig_defaulting[sig] = 1;
1594 (void) rsignal(sig, PL_csighandlerp);
1596 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1597 PL_sig_ignoring[sig] = 0;
1600 PL_sig_handlers_initted = 1;
1604 #if defined HAS_SIGPROCMASK
1606 unblock_sigmask(pTHX_ void* newset)
1608 PERL_UNUSED_CONTEXT;
1609 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1614 Perl_despatch_signals(pTHX)
1618 for (sig = 1; sig < SIG_SIZE; sig++) {
1619 if (PL_psig_pend[sig]) {
1621 #ifdef HAS_SIGPROCMASK
1622 /* From sigaction(2) (FreeBSD man page):
1623 * | Signal routines normally execute with the signal that
1624 * | caused their invocation blocked, but other signals may
1626 * Emulation of this behavior (from within Perl) is enabled
1630 sigset_t newset, oldset;
1632 sigemptyset(&newset);
1633 sigaddset(&newset, sig);
1634 sigprocmask(SIG_BLOCK, &newset, &oldset);
1635 was_blocked = sigismember(&oldset, sig);
1637 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1639 SAVEFREESV(save_sv);
1640 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1643 PL_psig_pend[sig] = 0;
1644 if (PL_sighandlerp == Perl_sighandler)
1645 /* default handler, so can call perly_sighandler() directly
1646 * rather than via Perl_sighandler, passing the extra
1649 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1651 #ifdef PERL_USE_3ARG_SIGHANDLER
1652 (*PL_sighandlerp)(sig, NULL, NULL);
1654 (*PL_sighandlerp)(sig);
1657 #ifdef HAS_SIGPROCMASK
1666 /* sv of NULL signifies that we're acting as magic_clearsig. */
1668 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1673 /* Need to be careful with SvREFCNT_dec(), because that can have side
1674 * effects (due to closures). We must make sure that the new disposition
1675 * is in place before it is called.
1679 #ifdef HAS_SIGPROCMASK
1683 const char *s = MgPV_const(mg,len);
1685 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1688 if (memEQs(s, len, "__DIE__"))
1690 else if (memEQs(s, len, "__WARN__")
1691 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1692 /* Merge the existing behaviours, which are as follows:
1693 magic_setsig, we always set svp to &PL_warnhook
1694 (hence we always change the warnings handler)
1695 For magic_clearsig, we don't change the warnings handler if it's
1696 set to the &PL_warnhook. */
1699 SV *tmp = sv_newmortal();
1700 Perl_croak(aTHX_ "No such hook: %s",
1701 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1705 if (*svp != PERL_WARNHOOK_FATAL)
1711 i = (I16)mg->mg_private;
1713 i = whichsig_pvn(s, len); /* ...no, a brick */
1714 mg->mg_private = (U16)i;
1718 SV *tmp = sv_newmortal();
1719 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1720 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1724 #ifdef HAS_SIGPROCMASK
1725 /* Avoid having the signal arrive at a bad time, if possible. */
1728 sigprocmask(SIG_BLOCK, &set, &save);
1730 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1731 SAVEFREESV(save_sv);
1732 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1735 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1736 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1738 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1739 PL_sig_ignoring[i] = 0;
1741 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1742 PL_sig_defaulting[i] = 0;
1744 to_dec = PL_psig_ptr[i];
1746 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1747 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1749 /* Signals don't change name during the program's execution, so once
1750 they're cached in the appropriate slot of PL_psig_name, they can
1753 Ideally we'd find some way of making SVs at (C) compile time, or
1754 at least, doing most of the work. */
1755 if (!PL_psig_name[i]) {
1756 const char* name = PL_sig_name[i];
1757 PL_psig_name[i] = newSVpvn(name, strlen(name));
1758 SvREADONLY_on(PL_psig_name[i]);
1761 SvREFCNT_dec(PL_psig_name[i]);
1762 PL_psig_name[i] = NULL;
1763 PL_psig_ptr[i] = NULL;
1766 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1768 (void)rsignal(i, PL_csighandlerp);
1771 *svp = SvREFCNT_inc_simple_NN(sv);
1773 if (sv && SvOK(sv)) {
1774 s = SvPV_force(sv, len);
1778 if (sv && memEQs(s, len,"IGNORE")) {
1780 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1781 PL_sig_ignoring[i] = 1;
1782 (void)rsignal(i, PL_csighandlerp);
1784 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1788 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1790 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1791 PL_sig_defaulting[i] = 1;
1792 (void)rsignal(i, PL_csighandlerp);
1794 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1800 * We should warn if HINT_STRICT_REFS, but without
1801 * access to a known hint bit in a known OP, we can't
1802 * tell whether HINT_STRICT_REFS is in force or not.
1804 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1805 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1808 (void)rsignal(i, PL_csighandlerp);
1810 *svp = SvREFCNT_inc_simple_NN(sv);
1814 #ifdef HAS_SIGPROCMASK
1818 SvREFCNT_dec(to_dec);
1821 #endif /* !PERL_MICRO */
1824 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1826 PERL_ARGS_ASSERT_MAGIC_SETISA;
1827 PERL_UNUSED_ARG(sv);
1829 /* Skip _isaelem because _isa will handle it shortly */
1830 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1833 return magic_clearisa(NULL, mg);
1836 /* sv of NULL signifies that we're acting as magic_setisa. */
1838 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1841 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1843 /* Bail out if destruction is going on */
1844 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1847 av_clear(MUTABLE_AV(sv));
1849 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1850 /* This occurs with setisa_elem magic, which calls this
1852 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1855 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1856 SV **svp = AvARRAY((AV *)mg->mg_obj);
1857 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1859 stash = GvSTASH((GV *)*svp++);
1860 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1867 (const GV *)mg->mg_obj
1870 /* The stash may have been detached from the symbol table, so check its
1871 name before doing anything. */
1872 if (stash && HvENAME_get(stash))
1873 mro_isa_changed_in(stash);
1879 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1881 HV * const hv = MUTABLE_HV(LvTARG(sv));
1884 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1885 PERL_UNUSED_ARG(mg);
1888 (void) hv_iterinit(hv);
1889 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1892 while (hv_iternext(hv))
1897 sv_setiv(sv, (IV)i);
1902 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1904 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1905 PERL_UNUSED_ARG(mg);
1907 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1913 =for apidoc magic_methcall
1915 Invoke a magic method (like FETCH).
1917 C<sv> and C<mg> are the tied thingy and the tie magic.
1919 C<meth> is the name of the method to call.
1921 C<argc> is the number of args (in addition to $self) to pass to the method.
1923 The C<flags> can be:
1925 G_DISCARD invoke method with G_DISCARD flag and don't
1927 G_UNDEF_FILL fill the stack with argc pointers to
1930 The arguments themselves are any values following the C<flags> argument.
1932 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1939 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1945 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1949 if (flags & G_WRITING_TO_STDERR) {
1953 SAVESPTR(PL_stderrgv);
1957 PUSHSTACKi(PERLSI_MAGIC);
1960 /* EXTEND() expects a signed argc; don't wrap when casting */
1961 assert(argc <= I32_MAX);
1962 EXTEND(SP, (I32)argc+1);
1963 PUSHs(SvTIED_obj(sv, mg));
1964 if (flags & G_UNDEF_FILL) {
1966 PUSHs(&PL_sv_undef);
1968 } else if (argc > 0) {
1970 va_start(args, argc);
1973 SV *const this_sv = va_arg(args, SV *);
1980 if (flags & G_DISCARD) {
1981 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1984 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1985 ret = *PL_stack_sp--;
1988 if (flags & G_WRITING_TO_STDERR)
1994 /* wrapper for magic_methcall that creates the first arg */
1997 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2002 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2005 if (mg->mg_len >= 0) {
2006 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2008 else if (mg->mg_len == HEf_SVKEY)
2009 arg1 = MUTABLE_SV(mg->mg_ptr);
2011 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2012 arg1 = newSViv((IV)(mg->mg_len));
2016 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2018 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2022 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2026 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2028 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2035 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2037 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2039 if (mg->mg_type == PERL_MAGIC_tiedelem)
2040 mg->mg_flags |= MGf_GSKIP;
2041 magic_methpack(sv,mg,SV_CONST(FETCH));
2046 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2051 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2053 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2054 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2055 * public flags indicate its value based on copying from $val. Doing
2056 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2057 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2058 * wrong if $val happened to be tainted, as sv hasn't got magic
2059 * enabled, even though taint magic is in the chain. In which case,
2060 * fake up a temporary tainted value (this is easier than temporarily
2061 * re-enabling magic on sv). */
2063 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2064 && (tmg->mg_len & 1))
2066 val = sv_mortalcopy(sv);
2072 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2077 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2079 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2081 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2082 return magic_methpack(sv,mg,SV_CONST(DELETE));
2087 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2092 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2094 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2096 retval = SvIV(retsv)-1;
2098 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2100 return (U32) retval;
2104 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2106 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2108 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2113 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2117 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2119 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2120 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2127 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2129 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2131 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2135 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2138 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2139 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2141 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2143 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2145 if (HvEITER_get(hv))
2146 /* we are in an iteration so the hash cannot be empty */
2148 /* no xhv_eiter so now use FIRSTKEY */
2149 key = sv_newmortal();
2150 magic_nextpack(MUTABLE_SV(hv), mg, key);
2151 HvEITER_set(hv, NULL); /* need to reset iterator */
2152 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2155 /* there is a SCALAR method that we can call */
2156 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2158 retval = &PL_sv_undef;
2163 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2167 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2169 /* The magic ptr/len for the debugger's hash should always be an SV. */
2170 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2171 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2172 (IV)mg->mg_len, mg->mg_ptr);
2175 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2176 setting/clearing debugger breakpoints is not a hot path. */
2177 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2178 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2180 if (svp && SvIOKp(*svp)) {
2181 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2183 #ifdef PERL_DEBUG_READONLY_OPS
2184 Slab_to_rw(OpSLAB(o));
2186 /* set or clear breakpoint in the relevant control op */
2188 o->op_flags |= OPf_SPECIAL;
2190 o->op_flags &= ~OPf_SPECIAL;
2191 #ifdef PERL_DEBUG_READONLY_OPS
2192 Slab_to_ro(OpSLAB(o));
2200 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2202 AV * const obj = MUTABLE_AV(mg->mg_obj);
2204 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2207 sv_setiv(sv, AvFILL(obj));
2215 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2217 AV * const obj = MUTABLE_AV(mg->mg_obj);
2219 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2222 av_fill(obj, SvIV(sv));
2224 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2225 "Attempt to set length of freed array");
2231 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2233 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2234 PERL_UNUSED_ARG(sv);
2235 PERL_UNUSED_CONTEXT;
2237 /* Reset the iterator when the array is cleared */
2238 if (sizeof(IV) == sizeof(SSize_t)) {
2239 *((IV *) &(mg->mg_len)) = 0;
2242 *((IV *) mg->mg_ptr) = 0;
2249 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2251 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2252 PERL_UNUSED_ARG(sv);
2254 /* during global destruction, mg_obj may already have been freed */
2255 if (PL_in_clean_all)
2258 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2261 /* arylen scalar holds a pointer back to the array, but doesn't own a
2262 reference. Hence the we (the array) are about to go away with it
2263 still pointing at us. Clear its pointer, else it would be pointing
2264 at free memory. See the comment in sv_magic about reference loops,
2265 and why it can't own a reference to us. */
2272 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2274 SV* const lsv = LvTARG(sv);
2275 MAGIC * const found = mg_find_mglob(lsv);
2277 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2278 PERL_UNUSED_ARG(mg);
2280 if (found && found->mg_len != -1) {
2281 STRLEN i = found->mg_len;
2282 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2283 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2292 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2294 SV* const lsv = LvTARG(sv);
2300 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2301 PERL_UNUSED_ARG(mg);
2303 found = mg_find_mglob(lsv);
2307 found = sv_magicext_mglob(lsv);
2309 else if (!SvOK(sv)) {
2313 s = SvPV_const(lsv, len);
2318 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2328 else if (pos > (SSize_t)len)
2331 found->mg_len = pos;
2332 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2338 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2341 SV * const lsv = LvTARG(sv);
2342 const char * const tmps = SvPV_const(lsv,len);
2343 STRLEN offs = LvTARGOFF(sv);
2344 STRLEN rem = LvTARGLEN(sv);
2345 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2346 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2348 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2349 PERL_UNUSED_ARG(mg);
2351 if (!translate_substr_offsets(
2352 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2353 negoff ? -(IV)offs : (IV)offs, !negoff,
2354 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2356 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2362 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2363 sv_setpvn(sv, tmps + offs, rem);
2370 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2372 STRLEN len, lsv_len, oldtarglen, newtarglen;
2373 const char * const tmps = SvPV_const(sv, len);
2374 SV * const lsv = LvTARG(sv);
2375 STRLEN lvoff = LvTARGOFF(sv);
2376 STRLEN lvlen = LvTARGLEN(sv);
2377 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2378 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2380 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2381 PERL_UNUSED_ARG(mg);
2385 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2386 "Attempt to use reference as lvalue in substr"
2388 SvPV_force_nomg(lsv,lsv_len);
2389 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2390 if (!translate_substr_offsets(
2392 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2393 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2395 Perl_croak(aTHX_ "substr outside of string");
2398 sv_utf8_upgrade_nomg(lsv);
2399 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2400 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2401 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2404 else if (SvUTF8(lsv)) {
2406 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2408 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2409 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2413 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2416 if (!neglen) LvTARGLEN(sv) = newtarglen;
2417 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2423 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2425 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2426 PERL_UNUSED_ARG(sv);
2427 #ifdef NO_TAINT_SUPPORT
2428 PERL_UNUSED_ARG(mg);
2431 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2436 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2438 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2439 PERL_UNUSED_ARG(sv);
2441 /* update taint status */
2450 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2452 SV * const lsv = LvTARG(sv);
2453 char errflags = LvFLAGS(sv);
2455 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2456 PERL_UNUSED_ARG(mg);
2458 /* non-zero errflags implies deferred out-of-range condition */
2459 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2460 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2466 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2468 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2469 PERL_UNUSED_ARG(mg);
2470 do_vecset(sv); /* XXX slurp this routine */
2475 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2478 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2479 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2481 if (LvTARGLEN(sv)) {
2483 SV * const ahv = LvTARG(sv);
2484 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2488 else if (LvSTARGOFF(sv) >= 0) {
2489 AV *const av = MUTABLE_AV(LvTARG(sv));
2490 if (LvSTARGOFF(sv) <= AvFILL(av))
2492 if (SvRMAGICAL(av)) {
2493 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2494 targ = svp ? *svp : NULL;
2497 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2500 if (targ && (targ != &PL_sv_undef)) {
2501 /* somebody else defined it for us */
2502 SvREFCNT_dec(LvTARG(sv));
2503 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2505 SvREFCNT_dec(mg->mg_obj);
2507 mg->mg_flags &= ~MGf_REFCOUNTED;
2516 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2518 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2520 sv_setsv(sv, defelem_target(sv, mg));
2525 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2527 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2528 PERL_UNUSED_ARG(mg);
2532 sv_setsv(LvTARG(sv), sv);
2533 SvSETMAGIC(LvTARG(sv));
2539 Perl_vivify_defelem(pTHX_ SV *sv)
2544 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2546 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2549 SV * const ahv = LvTARG(sv);
2550 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2553 if (!value || value == &PL_sv_undef)
2554 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2556 else if (LvSTARGOFF(sv) < 0)
2557 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2559 AV *const av = MUTABLE_AV(LvTARG(sv));
2560 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2561 LvTARG(sv) = NULL; /* array can't be extended */
2563 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2564 if (!svp || !(value = *svp))
2565 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2568 SvREFCNT_inc_simple_void(value);
2569 SvREFCNT_dec(LvTARG(sv));
2572 SvREFCNT_dec(mg->mg_obj);
2574 mg->mg_flags &= ~MGf_REFCOUNTED;
2578 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2580 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2581 PERL_UNUSED_ARG(mg);
2582 sv_unmagic(sv, PERL_MAGIC_nonelem);
2587 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2589 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2590 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2595 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2597 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2598 PERL_UNUSED_CONTEXT;
2599 PERL_UNUSED_ARG(sv);
2605 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2607 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2609 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2611 if (uf && uf->uf_set)
2612 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2617 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2619 const char type = mg->mg_type;
2621 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2623 assert( type == PERL_MAGIC_fm
2624 || type == PERL_MAGIC_qr
2625 || type == PERL_MAGIC_bm);
2626 return sv_unmagic(sv, type);
2629 #ifdef USE_LOCALE_COLLATE
2631 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2633 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2636 * RenE<eacute> Descartes said "I think not."
2637 * and vanished with a faint plop.
2639 PERL_UNUSED_CONTEXT;
2640 PERL_UNUSED_ARG(sv);
2642 Safefree(mg->mg_ptr);
2648 #endif /* USE_LOCALE_COLLATE */
2650 /* Just clear the UTF-8 cache data. */
2652 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2654 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2655 PERL_UNUSED_CONTEXT;
2656 PERL_UNUSED_ARG(sv);
2657 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2659 mg->mg_len = -1; /* The mg_len holds the len cache. */
2664 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2666 const char *bad = NULL;
2667 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2668 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2669 switch (mg->mg_private & OPpLVREF_TYPE) {
2671 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2675 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2679 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2683 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2687 /* diag_listed_as: Assigned value is not %s reference */
2688 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2689 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2692 SV * const old = PAD_SV(mg->mg_len);
2693 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2698 gv_setref(mg->mg_obj, sv);
2699 SvSETMAGIC(mg->mg_obj);
2702 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2703 SvREFCNT_inc_simple_NN(SvRV(sv)));
2706 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2707 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2709 if (mg->mg_flags & MGf_PERSIST)
2710 NOOP; /* This sv is in use as an iterator var and will be reused,
2711 so we must leave the magic. */
2713 /* This sv could be returned by the assignment op, so clear the
2714 magic, as lvrefs are an implementation detail that must not be
2715 leaked to the user. */
2716 sv_unmagic(sv, PERL_MAGIC_lvref);
2721 S_set_dollarzero(pTHX_ SV *sv)
2722 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2729 #ifdef HAS_SETPROCTITLE
2730 /* The BSDs don't show the argv[] in ps(1) output, they
2731 * show a string from the process struct and provide
2732 * the setproctitle() routine to manipulate that. */
2733 if (PL_origalen != 1) {
2734 s = SvPV_const(sv, len);
2735 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2736 /* The leading "-" removes the "perl: " prefix,
2737 * but not the "(perl) suffix from the ps(1)
2738 * output, because that's what ps(1) shows if the
2739 * argv[] is modified. */
2740 setproctitle("-%s", s);
2741 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2742 /* This doesn't really work if you assume that
2743 * $0 = 'foobar'; will wipe out 'perl' from the $0
2744 * because in ps(1) output the result will be like
2745 * sprintf("perl: %s (perl)", s)
2746 * I guess this is a security feature:
2747 * one (a user process) cannot get rid of the original name.
2749 setproctitle("%s", s);
2752 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2753 if (PL_origalen != 1) {
2755 s = SvPV_const(sv, len);
2756 un.pst_command = (char *)s;
2757 pstat(PSTAT_SETCMD, un, len, 0, 0);
2760 if (PL_origalen > 1) {
2762 /* PL_origalen is set in perl_parse(). */
2763 s = SvPV_force(sv,len);
2764 if (len >= (STRLEN)PL_origalen-1) {
2765 /* Longer than original, will be truncated. We assume that
2766 * PL_origalen bytes are available. */
2767 Copy(s, PL_origargv[0], PL_origalen-1, char);
2770 /* Shorter than original, will be padded. */
2772 /* Special case for Mac OS X: see [perl #38868] */
2775 /* Is the space counterintuitive? Yes.
2776 * (You were expecting \0?)
2777 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2779 const int pad = ' ';
2781 Copy(s, PL_origargv[0], len, char);
2782 PL_origargv[0][len] = 0;
2783 memset(PL_origargv[0] + len + 1,
2784 pad, PL_origalen - len - 1);
2786 PL_origargv[0][PL_origalen-1] = 0;
2787 for (i = 1; i < PL_origargc; i++)
2789 #ifdef HAS_PRCTL_SET_NAME
2790 /* Set the legacy process name in addition to the POSIX name on Linux */
2791 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2792 /* diag_listed_as: SKIPME */
2793 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2801 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2812 PERL_ARGS_ASSERT_MAGIC_SET;
2816 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2818 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2820 /* Croak with a READONLY error when a numbered match var is
2821 * set without a previous pattern match. Unless it's C<local $1>
2824 if (!PL_localizing) {
2825 Perl_croak_no_modify();
2831 switch (*mg->mg_ptr) {
2832 case '\001': /* ^A */
2833 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2834 else SvOK_off(PL_bodytarget);
2835 FmLINES(PL_bodytarget) = 0;
2836 if (SvPOK(PL_bodytarget)) {
2837 char *s = SvPVX(PL_bodytarget);
2838 char *e = SvEND(PL_bodytarget);
2839 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2840 FmLINES(PL_bodytarget)++;
2844 /* mg_set() has temporarily made sv non-magical */
2846 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2847 SvTAINTED_on(PL_bodytarget);
2849 SvTAINTED_off(PL_bodytarget);
2852 case '\003': /* ^C */
2853 PL_minus_c = cBOOL(SvIV(sv));
2856 case '\004': /* ^D */
2859 const char *s = SvPV_nolen_const(sv);
2860 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2861 if (DEBUG_x_TEST || DEBUG_B_TEST)
2862 dump_all_perl(!DEBUG_B_TEST);
2865 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2868 case '\005': /* ^E */
2869 if (*(mg->mg_ptr+1) == '\0') {
2871 set_vaxc_errno(SvIV(sv));
2872 #elif defined(WIN32)
2873 SetLastError( SvIV(sv) );
2875 os2_setsyserrno(SvIV(sv));
2877 /* will anyone ever use this? */
2878 SETERRNO(SvIV(sv), 4);
2881 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2882 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2884 case '\006': /* ^F */
2885 if (mg->mg_ptr[1] == '\0') {
2886 PL_maxsysfd = SvIV(sv);
2889 case '\010': /* ^H */
2891 U32 save_hints = PL_hints;
2892 PL_hints = SvUV(sv);
2894 /* If wasn't UTF-8, and now is, notify the parser */
2895 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2896 notify_parser_that_changed_to_utf8();
2900 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2901 Safefree(PL_inplace);
2902 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2904 case '\016': /* ^N */
2905 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2906 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2908 case '\017': /* ^O */
2909 if (*(mg->mg_ptr+1) == '\0') {
2910 Safefree(PL_osname);
2913 TAINT_PROPER("assigning to $^O");
2914 PL_osname = savesvpv(sv);
2917 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2919 const char *const start = SvPV(sv, len);
2920 const char *out = (const char*)memchr(start, '\0', len);
2924 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2925 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2927 /* Opening for input is more common than opening for output, so
2928 ensure that hints for input are sooner on linked list. */
2929 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2931 : newSVpvs_flags("", SvUTF8(sv));
2932 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2935 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2937 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2941 case '\020': /* ^P */
2942 PL_perldb = SvIV(sv);
2943 if (PL_perldb && !PL_DBsingle)
2946 case '\024': /* ^T */
2948 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2950 PL_basetime = (Time_t)SvIV(sv);
2953 case '\025': /* ^UTF8CACHE */
2954 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2955 PL_utf8cache = (signed char) sv_2iv(sv);
2958 case '\027': /* ^W & $^WARNING_BITS */
2959 if (*(mg->mg_ptr+1) == '\0') {
2960 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2962 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2963 | (i ? G_WARN_ON : G_WARN_OFF) ;
2966 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2967 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2969 free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
2974 int not_none = 0, not_all = 0;
2975 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2976 for (i = 0 ; i < len ; ++i) {
2978 not_all |= ptr[i] ^ 0x55;
2981 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
2982 } else if (len >= WARNsize && !not_all) {
2983 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
2984 PL_dowarn |= G_WARN_ONCE ;
2988 const char *const p = SvPV_const(sv, len);
2990 PL_compiling.cop_warnings
2991 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2994 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2995 PL_dowarn |= G_WARN_ONCE ;
3002 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
3003 w32_sloppystat = (bool)sv_true(sv);
3008 if (PL_localizing) {
3009 if (PL_localizing == 1)
3010 SAVESPTR(PL_last_in_gv);
3012 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3013 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3016 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
3017 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3018 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3021 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
3022 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3023 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3026 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3029 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3030 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3031 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3034 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3038 IO * const io = GvIO(PL_defoutgv);
3041 if ((SvIV(sv)) == 0)
3042 IoFLAGS(io) &= ~IOf_FLUSH;
3044 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3045 PerlIO *ofp = IoOFP(io);
3047 (void)PerlIO_flush(ofp);
3048 IoFLAGS(io) |= IOf_FLUSH;
3056 SV *referent = SvRV(sv);
3057 const char *reftype = sv_reftype(referent, 0);
3058 /* XXX: dodgy type check: This leaves me feeling dirty, but
3059 * the alternative is to copy pretty much the entire
3060 * sv_reftype() into this routine, or to do a full string
3061 * comparison on the return of sv_reftype() both of which
3062 * make me feel worse! NOTE, do not modify this comment
3063 * without reviewing the corresponding comment in
3064 * sv_reftype(). - Yves */
3065 if (reftype[0] == 'S' || reftype[0] == 'L') {
3066 IV val = SvIV(referent);
3068 sv_setsv(sv, PL_rs);
3069 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3070 val < 0 ? "a negative integer" : "zero");
3073 sv_setsv(sv, PL_rs);
3074 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3075 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3076 *reftype == 'A' ? "n" : "", reftype);
3079 SvREFCNT_dec(PL_rs);
3080 PL_rs = newSVsv(sv);
3084 SvREFCNT_dec(PL_ors_sv);
3086 PL_ors_sv = newSVsv(sv);
3094 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3097 #ifdef COMPLEX_STATUS
3098 if (PL_localizing == 2) {
3099 SvUPGRADE(sv, SVt_PVLV);
3100 PL_statusvalue = LvTARGOFF(sv);
3101 PL_statusvalue_vms = LvTARGLEN(sv);
3105 #ifdef VMSISH_STATUS
3107 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3110 STATUS_UNIX_EXIT_SET(SvIV(sv));
3115 # define PERL_VMS_BANG vaxc$errno
3117 # define PERL_VMS_BANG 0
3120 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3121 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3123 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3124 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3130 /* XXX $< currently silently ignores failures */
3131 const Uid_t new_uid = SvUID(sv);
3132 PL_delaymagic_uid = new_uid;
3133 if (PL_delaymagic) {
3134 PL_delaymagic |= DM_RUID;
3135 break; /* don't do magic till later */
3138 PERL_UNUSED_RESULT(setruid(new_uid));
3139 #elif defined(HAS_SETREUID)
3140 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3141 #elif defined(HAS_SETRESUID)
3142 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3144 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3146 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3147 if (new_uid != 0 && PerlProc_getuid() == 0)
3148 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3150 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3152 Perl_croak(aTHX_ "setruid() not implemented");
3159 /* XXX $> currently silently ignores failures */
3160 const Uid_t new_euid = SvUID(sv);
3161 PL_delaymagic_euid = new_euid;
3162 if (PL_delaymagic) {
3163 PL_delaymagic |= DM_EUID;
3164 break; /* don't do magic till later */
3167 PERL_UNUSED_RESULT(seteuid(new_euid));
3168 #elif defined(HAS_SETREUID)
3169 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3170 #elif defined(HAS_SETRESUID)
3171 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3173 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3174 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3176 Perl_croak(aTHX_ "seteuid() not implemented");
3183 /* XXX $( currently silently ignores failures */
3184 const Gid_t new_gid = SvGID(sv);
3185 PL_delaymagic_gid = new_gid;
3186 if (PL_delaymagic) {
3187 PL_delaymagic |= DM_RGID;
3188 break; /* don't do magic till later */
3191 PERL_UNUSED_RESULT(setrgid(new_gid));
3192 #elif defined(HAS_SETREGID)
3193 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3194 #elif defined(HAS_SETRESGID)
3195 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3197 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3198 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3200 Perl_croak(aTHX_ "setrgid() not implemented");
3207 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3208 * but you can override it if you need to.
3211 #define INVALID_GID ((Gid_t)-1)
3213 /* XXX $) currently silently ignores failures */
3215 #ifdef HAS_SETGROUPS
3217 const char *p = SvPV_const(sv, len);
3218 Groups_t *gary = NULL;
3219 const char* p_end = p + len;
3220 const char* endptr = p_end;
3222 #ifdef _SC_NGROUPS_MAX
3223 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3228 int maxgrp = NGROUPS;
3233 if (grok_atoUV(p, &uv, &endptr))
3234 new_egid = (Gid_t)uv;
3236 new_egid = INVALID_GID;
3239 for (i = 0; i < maxgrp; ++i) {
3249 Newx(gary, i + 1, Groups_t);
3251 Renew(gary, i + 1, Groups_t);
3252 if (grok_atoUV(p, &uv, &endptr))
3253 gary[i] = (Groups_t)uv;
3255 gary[i] = INVALID_GID;
3260 PERL_UNUSED_RESULT(setgroups(i, gary));
3263 #else /* HAS_SETGROUPS */
3264 new_egid = SvGID(sv);
3265 #endif /* HAS_SETGROUPS */
3266 PL_delaymagic_egid = new_egid;
3267 if (PL_delaymagic) {
3268 PL_delaymagic |= DM_EGID;
3269 break; /* don't do magic till later */
3272 PERL_UNUSED_RESULT(setegid(new_egid));
3273 #elif defined(HAS_SETREGID)
3274 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3275 #elif defined(HAS_SETRESGID)
3276 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3278 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3279 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3281 Perl_croak(aTHX_ "setegid() not implemented");
3287 PL_chopset = SvPV_force(sv,len);
3290 /* Store the pid in mg->mg_obj so we can tell when a fork has
3291 occurred. mg->mg_obj points to *$ by default, so clear it. */
3292 if (isGV(mg->mg_obj)) {
3293 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3294 SvREFCNT_dec(mg->mg_obj);
3295 mg->mg_flags |= MGf_REFCOUNTED;
3296 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3298 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3301 LOCK_DOLLARZERO_MUTEX;
3302 S_set_dollarzero(aTHX_ sv);
3303 UNLOCK_DOLLARZERO_MUTEX;
3310 Perl_whichsig_sv(pTHX_ SV *sigsv)
3314 PERL_ARGS_ASSERT_WHICHSIG_SV;
3315 sigpv = SvPV_const(sigsv, siglen);
3316 return whichsig_pvn(sigpv, siglen);
3320 Perl_whichsig_pv(pTHX_ const char *sig)
3322 PERL_ARGS_ASSERT_WHICHSIG_PV;
3323 return whichsig_pvn(sig, strlen(sig));
3327 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3331 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3332 PERL_UNUSED_CONTEXT;
3334 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3335 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3336 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3338 if (memEQs(sig, len, "CHLD"))
3342 if (memEQs(sig, len, "CLD"))
3349 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3350 * these three function are intended to be called by the OS as 'C' level
3351 * signal handler functions in the case where unsafe signals are being
3352 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3353 * perl-level sighandler, rather than deferring.
3354 * In fact, the core itself will normally use Perl_csighandler as the
3355 * OS-level handler; that function will then decide whether to queue the
3356 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3357 * functions are more useful for e.g. POSIX.xs when it wants explicit
3358 * control of what's happening.
3362 #ifdef PERL_USE_3ARG_SIGHANDLER
3365 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3367 Perl_perly_sighandler(sig, sip, uap, 0);
3373 Perl_sighandler(int sig)
3375 Perl_perly_sighandler(sig, NULL, NULL, 0);
3381 Perl_sighandler1(int sig)
3383 Perl_perly_sighandler(sig, NULL, NULL, 0);
3387 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3389 Perl_perly_sighandler(sig, sip, uap, 0);
3393 /* Invoke the perl-level signal handler. This function is called either
3394 * directly from one of the C-level signals handlers (Perl_sighandler or
3395 * Perl_csighandler), or for safe signals, later from
3396 * Perl_despatch_signals() at a suitable safe point during execution.
3398 * 'safe' is a boolean indicating the latter call path.
3402 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3403 void *uap PERL_UNUSED_DECL, bool safe)
3405 #ifdef PERL_GET_SIG_CONTEXT
3406 dTHXa(PERL_GET_SIG_CONTEXT);
3413 SV * const tSv = PL_Sv;
3417 XPV * const tXpv = PL_Xpv;
3418 I32 old_ss_ix = PL_savestack_ix;
3419 SV *errsv_save = NULL;
3422 if (!PL_psig_ptr[sig]) {
3423 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3428 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3429 /* Max number of items pushed there is 3*n or 4. We cannot fix
3430 infinity, so we fix 4 (in fact 5): */
3431 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3433 PL_savestack_ix += 5; /* Protect save in progress. */
3434 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3437 /* sv_2cv is too complicated, try a simpler variant first: */
3438 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3439 || SvTYPE(cv) != SVt_PVCV) {
3441 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3444 if (!cv || !CvROOT(cv)) {
3445 const HEK * const hek = gv
3449 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3451 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3452 "SIG%s handler \"%" HEKf "\" not defined.\n",
3453 PL_sig_name[sig], HEKfARG(hek));
3454 /* diag_listed_as: SIG%s handler "%s" not defined */
3455 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3456 "SIG%s handler \"__ANON__\" not defined.\n",
3461 sv = PL_psig_name[sig]
3462 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3463 : newSVpv(PL_sig_name[sig],0);
3467 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3468 /* make sure our assumption about the size of the SAVEs are correct:
3469 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3470 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3473 PUSHSTACKi(PERLSI_SIGNAL);
3477 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3479 struct sigaction oact;
3481 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3483 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3484 /* The siginfo fields signo, code, errno, pid, uid,
3485 * addr, status, and band are defined by POSIX/SUSv3. */
3486 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3487 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3488 # ifdef HAS_SIGINFO_SI_ERRNO
3489 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3491 # ifdef HAS_SIGINFO_SI_STATUS
3492 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3494 # ifdef HAS_SIGINFO_SI_UID
3497 sv_setuid(uid, sip->si_uid);
3498 (void)hv_stores(sih, "uid", uid);
3501 # ifdef HAS_SIGINFO_SI_PID
3502 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3504 # ifdef HAS_SIGINFO_SI_ADDR
3505 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3507 # ifdef HAS_SIGINFO_SI_BAND
3508 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3512 mPUSHp((char *)sip, sizeof(*sip));
3520 errsv_save = newSVsv(ERRSV);
3522 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3526 SV * const errsv = ERRSV;
3527 if (SvTRUE_NN(errsv)) {
3528 SvREFCNT_dec(errsv_save);
3531 /* Handler "died", for example to get out of a restart-able read().
3532 * Before we re-do that on its behalf re-enable the signal which was
3533 * blocked by the system when we entered.
3535 # ifdef HAS_SIGPROCMASK
3537 /* safe signals called via dispatch_signals() set up a
3538 * savestack destructor, unblock_sigmask(), to
3539 * automatically unblock the handler at the end. If
3540 * instead we get here directly, we have to do it
3545 sigaddset(&set,sig);
3546 sigprocmask(SIG_UNBLOCK, &set, NULL);
3549 /* Not clear if this will work */
3550 /* XXX not clear if this should be protected by 'if (safe)'
3553 (void)rsignal(sig, SIG_IGN);
3554 (void)rsignal(sig, PL_csighandlerp);
3556 #endif /* !PERL_MICRO */
3561 sv_setsv(errsv, errsv_save);
3562 SvREFCNT_dec(errsv_save);
3567 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3568 PL_savestack_ix = old_ss_ix;
3570 SvREFCNT_dec_NN(sv);
3571 PL_op = myop; /* Apparently not needed... */
3573 PL_Sv = tSv; /* Restore global temporaries. */
3580 S_restore_magic(pTHX_ const void *p)
3582 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3583 SV* const sv = mgs->mgs_sv;
3589 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3590 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3592 SvFLAGS(sv) |= mgs->mgs_flags;
3597 bumped = mgs->mgs_bumped;
3598 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3600 /* If we're still on top of the stack, pop us off. (That condition
3601 * will be satisfied if restore_magic was called explicitly, but *not*
3602 * if it's being called via leave_scope.)
3603 * The reason for doing this is that otherwise, things like sv_2cv()
3604 * may leave alloc gunk on the savestack, and some code
3605 * (e.g. sighandler) doesn't expect that...
3607 if (PL_savestack_ix == mgs->mgs_ss_ix)
3609 UV popval = SSPOPUV;
3610 assert(popval == SAVEt_DESTRUCTOR_X);
3611 PL_savestack_ix -= 2;
3613 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3614 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3617 if (SvREFCNT(sv) == 1) {
3618 /* We hold the last reference to this SV, which implies that the
3619 SV was deleted as a side effect of the routines we called.
3620 So artificially keep it alive a bit longer.
3621 We avoid turning on the TEMP flag, which can cause the SV's
3622 buffer to get stolen (and maybe other stuff). */
3627 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3631 /* clean up the mess created by Perl_sighandler().
3632 * Note that this is only called during an exit in a signal handler;
3633 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3637 S_unwind_handler_stack(pTHX_ const void *p)
3641 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3645 =for apidoc magic_sethint
3647 Triggered by a store to C<%^H>, records the key/value pair to
3648 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3649 anything that would need a deep copy. Maybe we should warn if we find a
3655 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3657 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3658 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3660 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3662 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3663 an alternative leaf in there, with PL_compiling.cop_hints being used if
3664 it's NULL. If needed for threads, the alternative could lock a mutex,
3665 or take other more complex action. */
3667 /* Something changed in %^H, so it will need to be restored on scope exit.
3668 Doing this here saves a lot of doing it manually in perl code (and
3669 forgetting to do it, and consequent subtle errors. */
3670 PL_hints |= HINT_LOCALIZE_HH;
3671 CopHINTHASH_set(&PL_compiling,
3672 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3673 magic_sethint_feature(key, NULL, 0, sv, 0);
3678 =for apidoc magic_clearhint
3680 Triggered by a delete from C<%^H>, records the key to
3681 C<PL_compiling.cop_hints_hash>.
3686 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3688 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3689 PERL_UNUSED_ARG(sv);
3691 PL_hints |= HINT_LOCALIZE_HH;
3692 CopHINTHASH_set(&PL_compiling,
3693 mg->mg_len == HEf_SVKEY
3694 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3695 MUTABLE_SV(mg->mg_ptr), 0, 0)
3696 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3697 mg->mg_ptr, mg->mg_len, 0, 0));
3698 if (mg->mg_len == HEf_SVKEY)
3699 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3701 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
3706 =for apidoc magic_clearhints
3708 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3713 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3715 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3716 PERL_UNUSED_ARG(sv);
3717 PERL_UNUSED_ARG(mg);
3718 cophh_free(CopHINTHASH_get(&PL_compiling));
3719 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3725 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3726 const char *name, I32 namlen)
3730 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3731 PERL_UNUSED_ARG(sv);
3732 PERL_UNUSED_ARG(name);
3733 PERL_UNUSED_ARG(namlen);
3735 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3736 nmg = mg_find(nsv, mg->mg_type);
3738 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3739 nmg->mg_ptr = mg->mg_ptr;
3740 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3741 nmg->mg_flags |= MGf_REFCOUNTED;
3746 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3747 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3749 #if DBVARMG_SINGLE != 0
3750 assert(mg->mg_private >= DBVARMG_SINGLE);
3752 assert(mg->mg_private < DBVARMG_COUNT);
3754 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3760 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3761 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3763 #if DBVARMG_SINGLE != 0
3764 assert(mg->mg_private >= DBVARMG_SINGLE);
3766 assert(mg->mg_private < DBVARMG_COUNT);
3767 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3773 * ex: set ts=8 sts=4 sw=4 et: