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"]
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
37 =for apidoc Ayh||MAGIC
48 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
54 #if defined(HAS_SETGROUPS)
61 # include <sys/pstat.h>
64 #ifdef HAS_PRCTL_SET_NAME
65 # include <sys/prctl.h>
69 /* Missing protos on LynxOS */
70 void setruid(uid_t id);
71 void seteuid(uid_t id);
72 void setrgid(uid_t id);
73 void setegid(uid_t id);
77 * Pre-magic setup and post-magic takedown.
78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
87 /* MGS is typedef'ed to struct magic_state in perl.h */
90 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
95 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
97 assert(SvMAGICAL(sv));
99 /* we shouldn't really be called here with RC==0, but it can sometimes
100 * happen via mg_clear() (which also shouldn't be called when RC==0,
101 * but it can happen). Handle this case gracefully(ish) by not RC++
102 * and thus avoiding the resultant double free */
103 if (SvREFCNT(sv) > 0) {
104 /* guard against sv getting freed midway through the mg clearing,
105 * by holding a private reference for the duration. */
106 SvREFCNT_inc_simple_void_NN(sv);
110 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
112 mgs = SSPTR(mgs_ix, MGS*);
114 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
115 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
116 mgs->mgs_bumped = bumped;
118 SvFLAGS(sv) &= ~flags;
122 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
125 =for apidoc mg_magical
127 Turns on the magical status of an SV. See C<L</sv_magic>>.
133 Perl_mg_magical(SV *sv)
136 PERL_ARGS_ASSERT_MG_MAGICAL;
139 if ((mg = SvMAGIC(sv))) {
141 const MGVTBL* const vtbl = mg->mg_virtual;
143 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
150 } while ((mg = mg->mg_moremagic));
151 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
159 Do magic before a value is retrieved from the SV. The type of SV must
160 be >= C<SVt_PVMG>. See C<L</sv_magic>>.
166 Perl_mg_get(pTHX_ SV *sv)
168 const I32 mgs_ix = SSNEW(sizeof(MGS));
171 bool taint_only = TRUE; /* the only get method seen is taint */
172 MAGIC *newmg, *head, *cur, *mg;
174 PERL_ARGS_ASSERT_MG_GET;
176 if (PL_localizing == 1 && sv == DEFSV) return 0;
178 /* We must call svt_get(sv, mg) for each valid entry in the linked
179 list of magic. svt_get() may delete the current entry, add new
180 magic to the head of the list, or upgrade the SV. AMS 20010810 */
182 newmg = cur = head = mg = SvMAGIC(sv);
184 const MGVTBL * const vtbl = mg->mg_virtual;
185 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
187 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
189 /* taint's mg get is so dumb it doesn't need flag saving */
190 if (mg->mg_type != PERL_MAGIC_taint) {
193 save_magic(mgs_ix, sv);
198 vtbl->svt_get(aTHX_ sv, mg);
200 /* guard against magic having been deleted - eg FETCH calling
203 /* recalculate flags */
204 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
208 /* recalculate flags if this entry was deleted. */
209 if (mg->mg_flags & MGf_GSKIP)
210 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
211 ~(SVs_GMG|SVs_SMG|SVs_RMG);
213 else if (vtbl == &PL_vtbl_utf8) {
214 /* get-magic can reallocate the PV, unless there's only taint
218 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
219 if ( mg2->mg_type != PERL_MAGIC_taint
220 && !(mg2->mg_flags & MGf_GSKIP)
222 && mg2->mg_virtual->svt_get
230 magic_setutf8(sv, mg);
236 /* Have we finished with the new entries we saw? Start again
237 where we left off (unless there are more new entries). */
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
250 /* recalculate flags */
251 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
256 restore_magic(INT2PTR(void *, (IV)mgs_ix));
264 Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
270 Perl_mg_set(pTHX_ SV *sv)
272 const I32 mgs_ix = SSNEW(sizeof(MGS));
276 PERL_ARGS_ASSERT_MG_SET;
278 if (PL_localizing == 2 && sv == DEFSV) return 0;
280 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
282 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
283 const MGVTBL* vtbl = mg->mg_virtual;
284 nextmg = mg->mg_moremagic; /* it may delete itself */
285 if (mg->mg_flags & MGf_GSKIP) {
286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
287 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
289 if (PL_localizing == 2
290 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
292 if (vtbl && vtbl->svt_set)
293 vtbl->svt_set(aTHX_ sv, mg);
296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
301 =for apidoc mg_length
303 Reports on the SV's length in bytes, calling length magic if available,
304 but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
305 magic if there is no 'length' magic, but with no indication as to
306 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
307 higher. Use C<sv_len()> instead.
313 Perl_mg_length(pTHX_ SV *sv)
318 PERL_ARGS_ASSERT_MG_LENGTH;
320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
321 const MGVTBL * const vtbl = mg->mg_virtual;
322 if (vtbl && vtbl->svt_len) {
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
324 save_magic(mgs_ix, sv);
325 /* omit MGf_GSKIP -- not changed here */
326 len = vtbl->svt_len(aTHX_ sv, mg);
327 restore_magic(INT2PTR(void*, (IV)mgs_ix));
332 (void)SvPV_const(sv, len);
337 Perl_mg_size(pTHX_ SV *sv)
341 PERL_ARGS_ASSERT_MG_SIZE;
343 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
344 const MGVTBL* const vtbl = mg->mg_virtual;
345 if (vtbl && vtbl->svt_len) {
346 const I32 mgs_ix = SSNEW(sizeof(MGS));
348 save_magic(mgs_ix, sv);
349 /* omit MGf_GSKIP -- not changed here */
350 len = vtbl->svt_len(aTHX_ sv, mg);
351 restore_magic(INT2PTR(void*, (IV)mgs_ix));
358 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
362 Perl_croak(aTHX_ "Size magic not implemented");
365 NOT_REACHED; /* NOTREACHED */
371 Clear something magical that the SV represents. See C<L</sv_magic>>.
377 Perl_mg_clear(pTHX_ SV *sv)
379 const I32 mgs_ix = SSNEW(sizeof(MGS));
383 PERL_ARGS_ASSERT_MG_CLEAR;
385 save_magic(mgs_ix, sv);
387 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
388 const MGVTBL* const vtbl = mg->mg_virtual;
389 /* omit GSKIP -- never set here */
391 nextmg = mg->mg_moremagic; /* it may delete itself */
393 if (vtbl && vtbl->svt_clear)
394 vtbl->svt_clear(aTHX_ sv, mg);
397 restore_magic(INT2PTR(void*, (IV)mgs_ix));
402 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
409 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
410 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
422 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
428 Perl_mg_find(const SV *sv, int type)
430 return S_mg_findext_flags(sv, type, NULL, 0);
434 =for apidoc mg_findext
436 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
443 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
445 return S_mg_findext_flags(sv, type, vtbl, 1);
449 Perl_mg_find_mglob(pTHX_ SV *sv)
451 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
452 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
453 /* This sv is only a delegate. //g magic must be attached to
458 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
459 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
466 Copies the magic from one SV to another. See C<L</sv_magic>>.
472 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
477 PERL_ARGS_ASSERT_MG_COPY;
479 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
480 const MGVTBL* const vtbl = mg->mg_virtual;
481 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
482 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
485 const char type = mg->mg_type;
486 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
488 (type == PERL_MAGIC_tied)
491 toLOWER(type), key, klen);
500 =for apidoc mg_localize
502 Copy some of the magic from an existing SV to new localized version of that
503 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
504 gets copied, value magic doesn't (I<e.g.>,
507 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
508 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
509 and that will handle the magic.
515 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
519 PERL_ARGS_ASSERT_MG_LOCALIZE;
524 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
525 const MGVTBL* const vtbl = mg->mg_virtual;
526 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
529 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
530 (void)vtbl->svt_local(aTHX_ nsv, mg);
532 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
533 mg->mg_ptr, mg->mg_len);
535 /* container types should remain read-only across localization */
536 SvFLAGS(nsv) |= SvREADONLY(sv);
539 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
540 SvFLAGS(nsv) |= SvMAGICAL(sv);
549 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
551 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
553 const MGVTBL* const vtbl = mg->mg_virtual;
554 if (vtbl && vtbl->svt_free)
555 vtbl->svt_free(aTHX_ sv, mg);
558 Safefree(mg->mg_ptr);
559 else if (mg->mg_len == HEf_SVKEY)
560 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
562 if (mg->mg_flags & MGf_REFCOUNTED)
563 SvREFCNT_dec(mg->mg_obj);
570 Free any magic storage used by the SV. See C<L</sv_magic>>.
576 Perl_mg_free(pTHX_ SV *sv)
581 PERL_ARGS_ASSERT_MG_FREE;
583 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
584 moremagic = mg->mg_moremagic;
585 mg_free_struct(sv, mg);
586 SvMAGIC_set(sv, moremagic);
588 SvMAGIC_set(sv, NULL);
594 =for apidoc mg_free_type
596 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
602 Perl_mg_free_type(pTHX_ SV *sv, int how)
604 MAGIC *mg, *prevmg, *moremg;
605 PERL_ARGS_ASSERT_MG_FREE_TYPE;
606 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
607 moremg = mg->mg_moremagic;
608 if (mg->mg_type == how) {
610 /* temporarily move to the head of the magic chain, in case
611 custom free code relies on this historical aspect of mg_free */
613 prevmg->mg_moremagic = moremg;
614 mg->mg_moremagic = SvMAGIC(sv);
617 newhead = mg->mg_moremagic;
618 mg_free_struct(sv, mg);
619 SvMAGIC_set(sv, newhead);
627 =for apidoc mg_freeext
629 Remove any magic of type C<how> using virtual table C<vtbl> from the
630 SV C<sv>. See L</sv_magic>.
632 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
638 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
640 MAGIC *mg, *prevmg, *moremg;
641 PERL_ARGS_ASSERT_MG_FREEEXT;
642 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
644 moremg = mg->mg_moremagic;
645 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
646 /* temporarily move to the head of the magic chain, in case
647 custom free code relies on this historical aspect of mg_free */
649 prevmg->mg_moremagic = moremg;
650 mg->mg_moremagic = SvMAGIC(sv);
653 newhead = mg->mg_moremagic;
654 mg_free_struct(sv, mg);
655 SvMAGIC_set(sv, newhead);
665 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
669 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
672 REGEXP * const rx = PM_GETRE(PL_curpm);
674 const SSize_t n = (SSize_t)mg->mg_obj;
675 if (n == '+') { /* @+ */
676 /* return the number possible */
677 return RX_NPARENS(rx);
678 } else { /* @- @^CAPTURE @{^CAPTURE} */
679 I32 paren = RX_LASTPAREN(rx);
681 /* return the last filled */
683 && (RX_OFFS(rx)[paren].start == -1
684 || RX_OFFS(rx)[paren].end == -1) )
690 /* @^CAPTURE @{^CAPTURE} */
691 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
703 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
705 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
708 REGEXP * const rx = PM_GETRE(PL_curpm);
710 const SSize_t n = (SSize_t)mg->mg_obj;
711 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
712 const I32 paren = mg->mg_len
713 + (n == '\003' ? 1 : 0);
718 if (paren <= (I32)RX_NPARENS(rx) &&
719 (s = RX_OFFS(rx)[paren].start) != -1 &&
720 (t = RX_OFFS(rx)[paren].end) != -1)
724 if (n == '+') /* @+ */
726 else if (n == '-') /* @- */
728 else { /* @^CAPTURE @{^CAPTURE} */
729 CALLREG_NUMBUF_FETCH(rx,paren,sv);
733 if (RX_MATCH_UTF8(rx)) {
734 const char * const b = RX_SUBBEG(rx);
736 i = RX_SUBCOFFSET(rx) +
738 (U8*)(b-RX_SUBOFFSET(rx)+i));
753 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
755 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
759 Perl_croak_no_modify();
760 NORETURN_FUNCTION_END;
763 #define SvRTRIM(sv) STMT_START { \
765 STRLEN len = SvCUR(sv); \
766 char * const p = SvPVX(sv); \
767 while (len > 0 && isSPACE(p[len-1])) \
769 SvCUR_set(sv, len); \
775 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
777 PERL_ARGS_ASSERT_EMULATE_COP_IO;
779 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
784 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
785 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
790 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
791 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
799 S_fixup_errno_string(pTHX_ SV* sv)
801 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
804 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
808 if(strEQ(SvPVX(sv), "")) {
809 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
813 /* In some locales the error string may come back as UTF-8, in which
814 * case we should turn on that flag. This didn't use to happen, and to
815 * avoid as many possible backward compatibility issues as possible, we
816 * don't turn on the flag unless we have to. So the flag stays off for
817 * an entirely invariant string. We assume that if the string looks
818 * like UTF-8 in a single script, it really is UTF-8: "text in any
819 * other encoding that uses bytes with the high bit set is extremely
820 * unlikely to pass a UTF-8 validity test"
821 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
822 * potential that we will get it wrong however, especially on short
823 * error message text, so do an additional check. */
824 if ( ! IN_BYTES /* respect 'use bytes' */
825 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
827 #ifdef USE_LOCALE_MESSAGES
829 && _is_cur_LC_category_utf8(LC_MESSAGES)
831 #else /* If can't check directly, at least can see if script is consistent,
832 under UTF-8, which gives us an extra measure of confidence. */
834 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
835 TRUE) /* Means assume UTF-8 */
845 =for apidoc_section $errno
846 =for apidoc sv_string_from_errnum
848 Generates the message string describing an OS error and returns it as
849 an SV. C<errnum> must be a value that C<errno> could take, identifying
852 If C<tgtsv> is non-null then the string will be written into that SV
853 (overwriting existing content) and it will be returned. If C<tgtsv>
854 is a null pointer then the string will be written into a new mortal SV
855 which will be returned.
857 The message will be taken from whatever locale would be used by C<$!>,
858 and will be encoded in the SV in whatever manner would be used by C<$!>.
859 The details of this process are subject to future change. Currently,
860 the message is taken from the C locale by default (usually producing an
861 English message), and from the currently selected locale when in the scope
862 of the C<use locale> pragma. A heuristic attempt is made to decode the
863 message from the locale's character encoding, but it will only be decoded
864 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
865 locale, usually in an ISO-8859-1 locale, and never in any other locale.
867 The SV is always returned containing an actual string, and with no other
868 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
869 (meaning success), and if no useful message is available then a useless
870 string (currently empty) is returned.
876 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
880 tgtsv = sv_newmortal();
881 errstr = my_strerror(errnum);
883 sv_setpv(tgtsv, errstr);
884 fixup_errno_string(tgtsv);
897 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
900 const char *s = NULL;
902 const char * const remaining = mg->mg_ptr + 1;
905 PERL_ARGS_ASSERT_MAGIC_GET;
909 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
911 CALLREG_NUMBUF_FETCH(rx,paren,sv);
918 nextchar = *remaining;
919 switch (*mg->mg_ptr) {
920 case '\001': /* ^A */
921 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
924 if (SvTAINTED(PL_bodytarget))
927 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
928 if (nextchar == '\0') {
929 sv_setiv(sv, (IV)PL_minus_c);
931 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
932 sv_setiv(sv, (IV)STATUS_NATIVE);
936 case '\004': /* ^D */
937 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
939 case '\005': /* ^E */
940 if (nextchar != '\0') {
941 if (strEQ(remaining, "NCODING"))
946 #if defined(VMS) || defined(OS2) || defined(WIN32)
950 $DESCRIPTOR(msgdsc,msg);
951 sv_setnv(sv,(NV) vaxc$errno);
952 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
953 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
958 if (!(_emx_env & 0x200)) { /* Under DOS */
959 sv_setnv(sv, (NV)errno);
960 sv_setpv(sv, errno ? my_strerror(errno) : "");
962 if (errno != errno_isOS2) {
963 const int tmp = _syserrno();
964 if (tmp) /* 2nd call to _syserrno() makes it 0 */
967 sv_setnv(sv, (NV)Perl_rc);
968 sv_setpv(sv, os2error(Perl_rc));
970 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
971 fixup_errno_string(sv);
973 # elif defined(WIN32)
975 const DWORD dwErr = GetLastError();
976 sv_setnv(sv, (NV)dwErr);
978 PerlProc_GetOSError(sv, dwErr);
979 fixup_errno_string(sv);
986 # error Missing code for platform
989 SvNOK_on(sv); /* what a wonderful hack! */
991 #endif /* End of platforms with special handling for $^E; others just fall
999 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1001 sv_setnv(sv, (NV)errno);
1004 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1005 sv_setpv(sv, os2error(Perl_rc));
1012 sv_string_from_errnum(errno, sv);
1013 /* If no useful string is available, don't
1014 * claim to have a string part. The SvNOK_on()
1015 * below will cause just the number part to be valid */
1023 SvNOK_on(sv); /* what a wonderful hack! */
1026 case '\006': /* ^F */
1027 if (nextchar == '\0') {
1028 sv_setiv(sv, (IV)PL_maxsysfd);
1031 case '\007': /* ^GLOBAL_PHASE */
1032 if (strEQ(remaining, "LOBAL_PHASE")) {
1033 sv_setpvn(sv, PL_phase_names[PL_phase],
1034 strlen(PL_phase_names[PL_phase]));
1037 case '\010': /* ^H */
1038 sv_setuv(sv, PL_hints);
1040 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1041 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1043 case '\014': /* ^LAST_FH */
1044 if (strEQ(remaining, "AST_FH")) {
1045 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1046 assert(isGV_with_GP(PL_last_in_gv));
1047 sv_setrv_inc(sv, MUTABLE_SV(PL_last_in_gv));
1054 case '\017': /* ^O & ^OPEN */
1055 if (nextchar == '\0') {
1056 sv_setpv(sv, PL_osname);
1059 else if (strEQ(remaining, "PEN")) {
1060 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1064 sv_setiv(sv, (IV)PL_perldb);
1066 case '\023': /* ^S */
1067 if (nextchar == '\0') {
1068 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1070 else if (PL_in_eval)
1071 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1075 else if (strEQ(remaining, "AFE_LOCALES")) {
1077 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1079 sv_setuv(sv, (UV) 1);
1082 sv_setuv(sv, (UV) 0);
1088 case '\024': /* ^T */
1089 if (nextchar == '\0') {
1091 sv_setnv(sv, PL_basetime);
1093 sv_setiv(sv, (IV)PL_basetime);
1096 else if (strEQ(remaining, "AINT"))
1097 sv_setiv(sv, TAINTING_get
1098 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1101 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1102 if (strEQ(remaining, "NICODE"))
1103 sv_setuv(sv, (UV) PL_unicode);
1104 else if (strEQ(remaining, "TF8LOCALE"))
1105 sv_setuv(sv, (UV) PL_utf8locale);
1106 else if (strEQ(remaining, "TF8CACHE"))
1107 sv_setiv(sv, (IV) PL_utf8cache);
1109 case '\027': /* ^W & $^WARNING_BITS */
1110 if (nextchar == '\0')
1111 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1112 else if (strEQ(remaining, "ARNING_BITS")) {
1113 if (PL_compiling.cop_warnings == pWARN_NONE) {
1114 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1116 else if (PL_compiling.cop_warnings == pWARN_STD) {
1119 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1120 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1123 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1124 *PL_compiling.cop_warnings);
1129 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1130 paren = RX_LASTPAREN(rx);
1132 goto do_numbuf_fetch;
1135 case '\016': /* ^N */
1136 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1137 paren = RX_LASTCLOSEPAREN(rx);
1139 goto do_numbuf_fetch;
1143 if (GvIO(PL_last_in_gv)) {
1144 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1149 sv_setiv(sv, (IV)STATUS_CURRENT);
1150 #ifdef COMPLEX_STATUS
1151 SvUPGRADE(sv, SVt_PVLV);
1152 LvTARGOFF(sv) = PL_statusvalue;
1153 LvTARGLEN(sv) = PL_statusvalue_vms;
1158 if (GvIOp(PL_defoutgv))
1159 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1163 sv_setpv(sv,GvENAME(PL_defoutgv));
1164 sv_catpvs(sv,"_TOP");
1168 if (GvIOp(PL_defoutgv))
1169 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1171 s = GvENAME(PL_defoutgv);
1175 if (GvIO(PL_defoutgv))
1176 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1179 if (GvIO(PL_defoutgv))
1180 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1183 if (GvIO(PL_defoutgv))
1184 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1193 if (GvIO(PL_defoutgv))
1194 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1198 sv_copypv(sv, PL_ors_sv);
1204 IV const pid = (IV)PerlProc_getpid();
1205 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1206 /* never set manually, or at least not since last fork */
1208 /* never unsafe, even if reading in a tainted expression */
1211 /* else a value has been assigned manually, so do nothing */
1215 sv_setuid(sv, PerlProc_getuid());
1218 sv_setuid(sv, PerlProc_geteuid());
1221 sv_setgid(sv, PerlProc_getgid());
1224 sv_setgid(sv, PerlProc_getegid());
1226 #ifdef HAS_GETGROUPS
1228 Groups_t *gary = NULL;
1229 I32 num_groups = getgroups(0, gary);
1230 if (num_groups > 0) {
1232 Newx(gary, num_groups, Groups_t);
1233 num_groups = getgroups(num_groups, gary);
1234 for (i = 0; i < num_groups; i++)
1235 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1241 Set this to avoid warnings when the SV is used as a number.
1242 Avoid setting the public IOK flag so that serializers will
1245 (void)SvIOKp_on(sv); /* what a wonderful hack! */
1259 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1261 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1263 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1265 if (uf && uf->uf_val)
1266 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1271 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1273 STRLEN len = 0, klen;
1278 SV *keysv = MgSV(mg);
1280 if (keysv == NULL) {
1285 if (!sv_utf8_downgrade(keysv, /* fail_ok */ TRUE)) {
1286 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv key (encoding to utf8)");
1289 key = SvPV_const(keysv,klen);
1292 PERL_ARGS_ASSERT_MAGIC_SETENV;
1296 /* defined environment variables are byte strings; unfortunately
1297 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1298 (void)SvPV_force_nomg_nolen(sv);
1299 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1301 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1307 my_setenv(key, s); /* does the deed */
1309 #ifdef DYNAMIC_ENV_FETCH
1310 /* We just undefd an environment var. Is a replacement */
1311 /* waiting in the wings? */
1313 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1315 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1319 #if !defined(OS2) && !defined(WIN32)
1320 /* And you'll never guess what the dog had */
1321 /* in its mouth... */
1323 MgTAINTEDDIR_off(mg);
1325 if (s && memEQs(key, klen, "DCL$PATH")) {
1326 char pathbuf[256], eltbuf[256], *cp, *elt;
1329 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1331 do { /* DCL$PATH may be a search list */
1332 while (1) { /* as may dev portion of any element */
1333 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1334 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1335 cando_by_name(S_IWUSR,0,elt) ) {
1336 MgTAINTEDDIR_on(mg);
1340 if ((cp = strchr(elt, ':')) != NULL)
1342 if (my_trnlnm(elt, eltbuf, j++))
1348 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1351 if (s && memEQs(key, klen, "PATH")) {
1352 const char * const strend = s + len;
1354 /* set MGf_TAINTEDDIR if any component of the new path is
1355 * relative or world-writeable */
1356 while (s < strend) {
1360 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1361 const char path_sep = PL_perllib_sep;
1363 const char path_sep = ':';
1365 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1366 s, strend, path_sep, &i);
1368 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1370 /* no colon thus no device name -- assume relative path */
1371 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1372 /* Using Unix separator, e.g. under bash, so act line Unix */
1373 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1375 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1377 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1378 MgTAINTEDDIR_on(mg);
1384 #endif /* neither OS2 nor WIN32 */
1390 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1392 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1393 PERL_UNUSED_ARG(sv);
1394 my_setenv(MgPV_nolen_const(mg),NULL);
1399 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1401 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1402 PERL_UNUSED_ARG(mg);
1404 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1406 if (PL_localizing) {
1409 hv_iterinit(MUTABLE_HV(sv));
1410 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1412 my_setenv(hv_iterkey(entry, &keylen),
1413 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1421 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1423 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1424 PERL_UNUSED_ARG(sv);
1425 PERL_UNUSED_ARG(mg);
1427 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1435 #ifdef HAS_SIGPROCMASK
1437 restore_sigmask(pTHX_ SV *save_sv)
1439 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1440 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1444 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1446 /* Are we fetching a signal entry? */
1447 int i = (I16)mg->mg_private;
1449 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1453 const char * sig = MgPV_const(mg, siglen);
1454 mg->mg_private = i = whichsig_pvn(sig, siglen);
1459 sv_setsv(sv,PL_psig_ptr[i]);
1461 Sighandler_t sigstate = rsignal_state(i);
1462 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1463 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1466 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1467 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1470 /* cache state so we don't fetch it again */
1471 if(sigstate == (Sighandler_t) SIG_IGN)
1472 sv_setpvs(sv,"IGNORE");
1475 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1482 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1484 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1486 magic_setsig(NULL, mg);
1487 return sv_unmagic(sv, mg->mg_type);
1491 #ifdef PERL_USE_3ARG_SIGHANDLER
1493 Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
1495 Perl_csighandler3(sig, sip, uap);
1499 Perl_csighandler(int sig)
1501 Perl_csighandler3(sig, NULL, NULL);
1506 Perl_csighandler1(int sig)
1508 Perl_csighandler3(sig, NULL, NULL);
1511 /* Handler intended to directly handle signal calls from the kernel.
1512 * (Depending on configuration, the kernel may actually call one of the
1513 * wrappers csighandler() or csighandler1() instead.)
1514 * It either queues up the signal or dispatches it immediately depending
1515 * on whether safe signals are enabled and whether the signal is capable
1516 * of being deferred (e.g. SEGV isn't).
1520 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1522 #ifdef PERL_GET_SIG_CONTEXT
1523 dTHXa(PERL_GET_SIG_CONTEXT);
1528 #ifdef PERL_USE_3ARG_SIGHANDLER
1529 #if defined(__cplusplus) && defined(__GNUC__)
1530 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1531 * parameters would be warned about. */
1532 PERL_UNUSED_ARG(sip);
1533 PERL_UNUSED_ARG(uap);
1537 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1538 (void) rsignal(sig, PL_csighandlerp);
1539 if (PL_sig_ignoring[sig]) return;
1541 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1542 if (PL_sig_defaulting[sig])
1543 #ifdef KILL_BY_SIGPRC
1544 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1562 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1563 /* Call the perl level handler now--
1564 * with risk we may be in malloc() or being destructed etc. */
1566 if (PL_sighandlerp == Perl_sighandler)
1567 /* default handler, so can call perly_sighandler() directly
1568 * rather than via Perl_sighandler, passing the extra
1569 * 'safe = false' arg
1571 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
1573 #ifdef PERL_USE_3ARG_SIGHANDLER
1574 (*PL_sighandlerp)(sig, NULL, NULL);
1576 (*PL_sighandlerp)(sig);
1580 if (!PL_psig_pend) return;
1581 /* Set a flag to say this signal is pending, that is awaiting delivery after
1582 * the current Perl opcode completes */
1583 PL_psig_pend[sig]++;
1585 #ifndef SIG_PENDING_DIE_COUNT
1586 # define SIG_PENDING_DIE_COUNT 120
1588 /* Add one to say _a_ signal is pending */
1589 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1590 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1591 (unsigned long)SIG_PENDING_DIE_COUNT);
1595 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1597 Perl_csighandler_init(void)
1600 if (PL_sig_handlers_initted) return;
1602 for (sig = 1; sig < SIG_SIZE; sig++) {
1603 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1605 PL_sig_defaulting[sig] = 1;
1606 (void) rsignal(sig, PL_csighandlerp);
1608 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1609 PL_sig_ignoring[sig] = 0;
1612 PL_sig_handlers_initted = 1;
1616 #if defined HAS_SIGPROCMASK
1618 unblock_sigmask(pTHX_ void* newset)
1620 PERL_UNUSED_CONTEXT;
1621 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1626 Perl_despatch_signals(pTHX)
1630 for (sig = 1; sig < SIG_SIZE; sig++) {
1631 if (PL_psig_pend[sig]) {
1633 #ifdef HAS_SIGPROCMASK
1634 /* From sigaction(2) (FreeBSD man page):
1635 * | Signal routines normally execute with the signal that
1636 * | caused their invocation blocked, but other signals may
1638 * Emulation of this behavior (from within Perl) is enabled
1642 sigset_t newset, oldset;
1644 sigemptyset(&newset);
1645 sigaddset(&newset, sig);
1646 sigprocmask(SIG_BLOCK, &newset, &oldset);
1647 was_blocked = sigismember(&oldset, sig);
1649 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1651 SAVEFREESV(save_sv);
1652 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1655 PL_psig_pend[sig] = 0;
1656 if (PL_sighandlerp == Perl_sighandler)
1657 /* default handler, so can call perly_sighandler() directly
1658 * rather than via Perl_sighandler, passing the extra
1661 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1663 #ifdef PERL_USE_3ARG_SIGHANDLER
1664 (*PL_sighandlerp)(sig, NULL, NULL);
1666 (*PL_sighandlerp)(sig);
1669 #ifdef HAS_SIGPROCMASK
1678 /* sv of NULL signifies that we're acting as magic_clearsig. */
1680 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1684 /* Need to be careful with SvREFCNT_dec(), because that can have side
1685 * effects (due to closures). We must make sure that the new disposition
1686 * is in place before it is called.
1690 #ifdef HAS_SIGPROCMASK
1694 const char *s = MgPV_const(mg,len);
1696 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1699 if (memEQs(s, len, "__DIE__"))
1701 else if (memEQs(s, len, "__WARN__")
1702 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1703 /* Merge the existing behaviours, which are as follows:
1704 magic_setsig, we always set svp to &PL_warnhook
1705 (hence we always change the warnings handler)
1706 For magic_clearsig, we don't change the warnings handler if it's
1707 set to the &PL_warnhook. */
1710 SV *tmp = sv_newmortal();
1711 Perl_croak(aTHX_ "No such hook: %s",
1712 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1716 if (*svp != PERL_WARNHOOK_FATAL)
1722 i = (I16)mg->mg_private;
1724 i = whichsig_pvn(s, len); /* ...no, a brick */
1725 mg->mg_private = (U16)i;
1729 SV *tmp = sv_newmortal();
1730 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1731 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1735 #ifdef HAS_SIGPROCMASK
1736 /* Avoid having the signal arrive at a bad time, if possible. */
1739 sigprocmask(SIG_BLOCK, &set, &save);
1741 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1742 SAVEFREESV(save_sv);
1743 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1746 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1747 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1749 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1750 PL_sig_ignoring[i] = 0;
1752 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1753 PL_sig_defaulting[i] = 0;
1755 to_dec = PL_psig_ptr[i];
1757 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1758 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1760 /* Signals don't change name during the program's execution, so once
1761 they're cached in the appropriate slot of PL_psig_name, they can
1764 Ideally we'd find some way of making SVs at (C) compile time, or
1765 at least, doing most of the work. */
1766 if (!PL_psig_name[i]) {
1767 const char* name = PL_sig_name[i];
1768 PL_psig_name[i] = newSVpvn(name, strlen(name));
1769 SvREADONLY_on(PL_psig_name[i]);
1772 SvREFCNT_dec(PL_psig_name[i]);
1773 PL_psig_name[i] = NULL;
1774 PL_psig_ptr[i] = NULL;
1777 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1779 (void)rsignal(i, PL_csighandlerp);
1782 *svp = SvREFCNT_inc_simple_NN(sv);
1784 if (sv && SvOK(sv)) {
1785 s = SvPV_force(sv, len);
1789 if (sv && memEQs(s, len,"IGNORE")) {
1791 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1792 PL_sig_ignoring[i] = 1;
1793 (void)rsignal(i, PL_csighandlerp);
1795 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1799 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1801 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1802 PL_sig_defaulting[i] = 1;
1803 (void)rsignal(i, PL_csighandlerp);
1805 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1811 * We should warn if HINT_STRICT_REFS, but without
1812 * access to a known hint bit in a known OP, we can't
1813 * tell whether HINT_STRICT_REFS is in force or not.
1815 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1816 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1819 (void)rsignal(i, PL_csighandlerp);
1821 *svp = SvREFCNT_inc_simple_NN(sv);
1825 #ifdef HAS_SIGPROCMASK
1829 SvREFCNT_dec(to_dec);
1832 #endif /* !PERL_MICRO */
1835 Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
1837 PERL_ARGS_ASSERT_MAGIC_SETSIGALL;
1838 PERL_UNUSED_ARG(mg);
1840 if (PL_localizing == 2) {
1844 while ((current = hv_iternext(hv))) {
1845 SV* sigelem = hv_iterval(hv, current);
1853 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1855 PERL_ARGS_ASSERT_MAGIC_SETISA;
1856 PERL_UNUSED_ARG(sv);
1858 /* Skip _isaelem because _isa will handle it shortly */
1859 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1862 return magic_clearisa(NULL, mg);
1865 /* sv of NULL signifies that we're acting as magic_setisa. */
1867 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1870 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1872 /* Bail out if destruction is going on */
1873 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1876 av_clear(MUTABLE_AV(sv));
1878 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1879 /* This occurs with setisa_elem magic, which calls this
1881 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1884 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1885 SV **svp = AvARRAY((AV *)mg->mg_obj);
1886 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1888 stash = GvSTASH((GV *)*svp++);
1889 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1896 (const GV *)mg->mg_obj
1899 /* The stash may have been detached from the symbol table, so check its
1900 name before doing anything. */
1901 if (stash && HvENAME_get(stash))
1902 mro_isa_changed_in(stash);
1908 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1910 HV * const hv = MUTABLE_HV(LvTARG(sv));
1913 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1914 PERL_UNUSED_ARG(mg);
1917 (void) hv_iterinit(hv);
1918 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1921 while (hv_iternext(hv))
1926 sv_setiv(sv, (IV)i);
1931 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1933 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1934 PERL_UNUSED_ARG(mg);
1936 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1942 =for apidoc_section $magic
1943 =for apidoc magic_methcall
1945 Invoke a magic method (like FETCH).
1947 C<sv> and C<mg> are the tied thingy and the tie magic.
1949 C<meth> is the name of the method to call.
1951 C<argc> is the number of args (in addition to $self) to pass to the method.
1953 The C<flags> can be:
1955 G_DISCARD invoke method with G_DISCARD flag and don't
1957 G_UNDEF_FILL fill the stack with argc pointers to
1960 The arguments themselves are any values following the C<flags> argument.
1962 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1969 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1975 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1979 if (flags & G_WRITING_TO_STDERR) {
1983 SAVESPTR(PL_stderrgv);
1987 PUSHSTACKi(PERLSI_MAGIC);
1990 /* EXTEND() expects a signed argc; don't wrap when casting */
1991 assert(argc <= I32_MAX);
1992 EXTEND(SP, (I32)argc+1);
1993 PUSHs(SvTIED_obj(sv, mg));
1994 if (flags & G_UNDEF_FILL) {
1996 PUSHs(&PL_sv_undef);
1998 } else if (argc > 0) {
2000 va_start(args, argc);
2003 SV *const this_sv = va_arg(args, SV *);
2010 if (flags & G_DISCARD) {
2011 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
2014 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
2015 ret = *PL_stack_sp--;
2018 if (flags & G_WRITING_TO_STDERR)
2024 /* wrapper for magic_methcall that creates the first arg */
2027 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2032 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2035 if (mg->mg_len >= 0) {
2036 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2038 else if (mg->mg_len == HEf_SVKEY)
2039 arg1 = MUTABLE_SV(mg->mg_ptr);
2041 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2042 arg1 = newSViv((IV)(mg->mg_len));
2046 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2048 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2052 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2056 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2058 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2065 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2067 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2069 if (mg->mg_type == PERL_MAGIC_tiedelem)
2070 mg->mg_flags |= MGf_GSKIP;
2071 magic_methpack(sv,mg,SV_CONST(FETCH));
2076 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2081 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2083 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2084 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2085 * public flags indicate its value based on copying from $val. Doing
2086 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2087 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2088 * wrong if $val happened to be tainted, as sv hasn't got magic
2089 * enabled, even though taint magic is in the chain. In which case,
2090 * fake up a temporary tainted value (this is easier than temporarily
2091 * re-enabling magic on sv). */
2093 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2094 && (tmg->mg_len & 1))
2096 val = sv_mortalcopy(sv);
2102 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2107 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2109 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2111 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2112 return magic_methpack(sv,mg,SV_CONST(DELETE));
2117 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2122 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2124 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2126 retval = SvIV(retsv)-1;
2128 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2130 return (U32) retval;
2134 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2136 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2138 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2143 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2147 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2149 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2150 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2157 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2159 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2161 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2165 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2168 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2169 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2171 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2173 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2175 if (HvEITER_get(hv))
2176 /* we are in an iteration so the hash cannot be empty */
2178 /* no xhv_eiter so now use FIRSTKEY */
2179 key = sv_newmortal();
2180 magic_nextpack(MUTABLE_SV(hv), mg, key);
2181 HvEITER_set(hv, NULL); /* need to reset iterator */
2182 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2185 /* there is a SCALAR method that we can call */
2186 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2188 retval = &PL_sv_undef;
2193 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2197 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2199 /* The magic ptr/len for the debugger's hash should always be an SV. */
2200 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2201 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2202 (IV)mg->mg_len, mg->mg_ptr);
2205 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2206 setting/clearing debugger breakpoints is not a hot path. */
2207 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2208 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2210 if (svp && SvIOKp(*svp)) {
2211 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2213 #ifdef PERL_DEBUG_READONLY_OPS
2214 Slab_to_rw(OpSLAB(o));
2216 /* set or clear breakpoint in the relevant control op */
2218 o->op_flags |= OPf_SPECIAL;
2220 o->op_flags &= ~OPf_SPECIAL;
2221 #ifdef PERL_DEBUG_READONLY_OPS
2222 Slab_to_ro(OpSLAB(o));
2230 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2232 AV * const obj = MUTABLE_AV(mg->mg_obj);
2234 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2237 sv_setiv(sv, AvFILL(obj));
2245 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2247 AV * const obj = MUTABLE_AV(mg->mg_obj);
2249 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2252 av_fill(obj, SvIV(sv));
2254 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2255 "Attempt to set length of freed array");
2261 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2263 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2264 PERL_UNUSED_ARG(sv);
2265 PERL_UNUSED_CONTEXT;
2267 /* Reset the iterator when the array is cleared */
2268 if (sizeof(IV) == sizeof(SSize_t)) {
2269 *((IV *) &(mg->mg_len)) = 0;
2272 *((IV *) mg->mg_ptr) = 0;
2279 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2281 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2282 PERL_UNUSED_ARG(sv);
2284 /* during global destruction, mg_obj may already have been freed */
2285 if (PL_in_clean_all)
2288 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2291 /* arylen scalar holds a pointer back to the array, but doesn't own a
2292 reference. Hence the we (the array) are about to go away with it
2293 still pointing at us. Clear its pointer, else it would be pointing
2294 at free memory. See the comment in sv_magic about reference loops,
2295 and why it can't own a reference to us. */
2302 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2304 SV* const lsv = LvTARG(sv);
2305 MAGIC * const found = mg_find_mglob(lsv);
2307 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2308 PERL_UNUSED_ARG(mg);
2310 if (found && found->mg_len != -1) {
2311 STRLEN i = found->mg_len;
2312 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2313 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2322 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2324 SV* const lsv = LvTARG(sv);
2330 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2331 PERL_UNUSED_ARG(mg);
2333 found = mg_find_mglob(lsv);
2337 found = sv_magicext_mglob(lsv);
2339 else if (!SvOK(sv)) {
2343 s = SvPV_const(lsv, len);
2348 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2358 else if (pos > (SSize_t)len)
2361 found->mg_len = pos;
2362 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2368 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2371 SV * const lsv = LvTARG(sv);
2372 const char * const tmps = SvPV_const(lsv,len);
2373 STRLEN offs = LvTARGOFF(sv);
2374 STRLEN rem = LvTARGLEN(sv);
2375 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2376 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2378 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2379 PERL_UNUSED_ARG(mg);
2381 if (!translate_substr_offsets(
2382 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2383 negoff ? -(IV)offs : (IV)offs, !negoff,
2384 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2386 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2392 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2393 sv_setpvn(sv, tmps + offs, rem);
2400 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2402 STRLEN len, lsv_len, oldtarglen, newtarglen;
2403 const char * const tmps = SvPV_const(sv, len);
2404 SV * const lsv = LvTARG(sv);
2405 STRLEN lvoff = LvTARGOFF(sv);
2406 STRLEN lvlen = LvTARGLEN(sv);
2407 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2408 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2410 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2411 PERL_UNUSED_ARG(mg);
2415 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2416 "Attempt to use reference as lvalue in substr"
2418 SvPV_force_nomg(lsv,lsv_len);
2419 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2420 if (!translate_substr_offsets(
2422 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2423 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2425 Perl_croak(aTHX_ "substr outside of string");
2428 sv_utf8_upgrade_nomg(lsv);
2429 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2430 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2431 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2434 else if (SvUTF8(lsv)) {
2436 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2438 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2439 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2443 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2446 if (!neglen) LvTARGLEN(sv) = newtarglen;
2447 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2453 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2455 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2456 PERL_UNUSED_ARG(sv);
2457 #ifdef NO_TAINT_SUPPORT
2458 PERL_UNUSED_ARG(mg);
2461 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2466 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2468 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2469 PERL_UNUSED_ARG(sv);
2471 /* update taint status */
2480 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2482 SV * const lsv = LvTARG(sv);
2483 char errflags = LvFLAGS(sv);
2485 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2486 PERL_UNUSED_ARG(mg);
2488 /* non-zero errflags implies deferred out-of-range condition */
2489 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2490 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2496 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2498 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2499 PERL_UNUSED_ARG(mg);
2500 do_vecset(sv); /* XXX slurp this routine */
2505 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2508 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2509 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2511 if (LvTARGLEN(sv)) {
2513 SV * const ahv = LvTARG(sv);
2514 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2518 else if (LvSTARGOFF(sv) >= 0) {
2519 AV *const av = MUTABLE_AV(LvTARG(sv));
2520 if (LvSTARGOFF(sv) <= AvFILL(av))
2522 if (SvRMAGICAL(av)) {
2523 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2524 targ = svp ? *svp : NULL;
2527 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2530 if (targ && (targ != &PL_sv_undef)) {
2531 /* somebody else defined it for us */
2532 SvREFCNT_dec(LvTARG(sv));
2533 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2535 SvREFCNT_dec(mg->mg_obj);
2537 mg->mg_flags &= ~MGf_REFCOUNTED;
2546 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2548 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2550 sv_setsv(sv, defelem_target(sv, mg));
2555 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2557 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2558 PERL_UNUSED_ARG(mg);
2562 sv_setsv(LvTARG(sv), sv);
2563 SvSETMAGIC(LvTARG(sv));
2569 Perl_vivify_defelem(pTHX_ SV *sv)
2574 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2576 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2579 SV * const ahv = LvTARG(sv);
2580 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2583 if (!value || value == &PL_sv_undef)
2584 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2586 else if (LvSTARGOFF(sv) < 0)
2587 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2589 AV *const av = MUTABLE_AV(LvTARG(sv));
2590 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2591 LvTARG(sv) = NULL; /* array can't be extended */
2593 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2594 if (!svp || !(value = *svp))
2595 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2598 SvREFCNT_inc_simple_void(value);
2599 SvREFCNT_dec(LvTARG(sv));
2602 SvREFCNT_dec(mg->mg_obj);
2604 mg->mg_flags &= ~MGf_REFCOUNTED;
2608 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2610 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2611 PERL_UNUSED_ARG(mg);
2612 sv_unmagic(sv, PERL_MAGIC_nonelem);
2617 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2619 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2620 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2625 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2627 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2628 PERL_UNUSED_CONTEXT;
2629 PERL_UNUSED_ARG(sv);
2636 Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
2638 PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
2639 PERL_UNUSED_ARG(sv);
2641 /* pos() magic uses mg_len as a string position rather than a buffer
2642 * length, and mg_ptr is currently unused, so skip freeing.
2644 assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
2651 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2653 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2655 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2657 if (uf && uf->uf_set)
2658 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2663 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2665 const char type = mg->mg_type;
2667 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2669 assert( type == PERL_MAGIC_fm
2670 || type == PERL_MAGIC_qr
2671 || type == PERL_MAGIC_bm);
2672 return sv_unmagic(sv, type);
2675 #ifdef USE_LOCALE_COLLATE
2677 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2679 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2682 * RenE<eacute> Descartes said "I think not."
2683 * and vanished with a faint plop.
2685 PERL_UNUSED_CONTEXT;
2686 PERL_UNUSED_ARG(sv);
2688 Safefree(mg->mg_ptr);
2696 Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
2698 PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
2699 PERL_UNUSED_ARG(sv);
2701 /* Collate magic uses mg_len as a string length rather than a buffer
2702 * length, so we need to free even with mg_len == 0: hence we can't
2703 * rely on standard magic free handling */
2704 if (mg->mg_len >= 0) {
2705 assert(mg->mg_type == PERL_MAGIC_collxfrm);
2706 Safefree(mg->mg_ptr);
2712 #endif /* USE_LOCALE_COLLATE */
2714 /* Just clear the UTF-8 cache data. */
2716 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2718 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2719 PERL_UNUSED_CONTEXT;
2720 PERL_UNUSED_ARG(sv);
2721 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2723 mg->mg_len = -1; /* The mg_len holds the len cache. */
2728 Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
2730 PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
2731 PERL_UNUSED_ARG(sv);
2733 /* utf8 magic uses mg_len as a string length rather than a buffer
2734 * length, so we need to free even with mg_len == 0: hence we can't
2735 * rely on standard magic free handling */
2736 assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
2737 Safefree(mg->mg_ptr);
2744 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2746 const char *bad = NULL;
2747 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2748 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2749 switch (mg->mg_private & OPpLVREF_TYPE) {
2751 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2755 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2759 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2763 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2767 /* diag_listed_as: Assigned value is not %s reference */
2768 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2769 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2772 SV * const old = PAD_SV(mg->mg_len);
2773 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2778 gv_setref(mg->mg_obj, sv);
2779 SvSETMAGIC(mg->mg_obj);
2782 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2783 SvREFCNT_inc_simple_NN(SvRV(sv)));
2786 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2787 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2789 if (mg->mg_flags & MGf_PERSIST)
2790 NOOP; /* This sv is in use as an iterator var and will be reused,
2791 so we must leave the magic. */
2793 /* This sv could be returned by the assignment op, so clear the
2794 magic, as lvrefs are an implementation detail that must not be
2795 leaked to the user. */
2796 sv_unmagic(sv, PERL_MAGIC_lvref);
2801 S_set_dollarzero(pTHX_ SV *sv)
2802 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2806 #ifdef HAS_SETPROCTITLE
2807 /* The BSDs don't show the argv[] in ps(1) output, they
2808 * show a string from the process struct and provide
2809 * the setproctitle() routine to manipulate that. */
2810 if (PL_origalen != 1) {
2811 s = SvPV_const(sv, len);
2812 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2813 /* The leading "-" removes the "perl: " prefix,
2814 * but not the "(perl) suffix from the ps(1)
2815 * output, because that's what ps(1) shows if the
2816 * argv[] is modified. */
2817 setproctitle("-%s", s);
2818 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2819 /* This doesn't really work if you assume that
2820 * $0 = 'foobar'; will wipe out 'perl' from the $0
2821 * because in ps(1) output the result will be like
2822 * sprintf("perl: %s (perl)", s)
2823 * I guess this is a security feature:
2824 * one (a user process) cannot get rid of the original name.
2826 setproctitle("%s", s);
2829 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2830 if (PL_origalen != 1) {
2832 s = SvPV_const(sv, len);
2833 un.pst_command = (char *)s;
2834 pstat(PSTAT_SETCMD, un, len, 0, 0);
2837 if (PL_origalen > 1) {
2839 /* PL_origalen is set in perl_parse(). */
2840 s = SvPV_force(sv,len);
2841 if (len >= (STRLEN)PL_origalen-1) {
2842 /* Longer than original, will be truncated. We assume that
2843 * PL_origalen bytes are available. */
2844 Copy(s, PL_origargv[0], PL_origalen-1, char);
2847 /* Shorter than original, will be padded. */
2849 /* Special case for Mac OS X: see [perl #38868] */
2852 /* Is the space counterintuitive? Yes.
2853 * (You were expecting \0?)
2854 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2856 const int pad = ' ';
2858 Copy(s, PL_origargv[0], len, char);
2859 PL_origargv[0][len] = 0;
2860 memset(PL_origargv[0] + len + 1,
2861 pad, PL_origalen - len - 1);
2863 PL_origargv[0][PL_origalen-1] = 0;
2864 for (i = 1; i < PL_origargc; i++)
2866 #ifdef HAS_PRCTL_SET_NAME
2867 /* Set the legacy process name in addition to the POSIX name on Linux */
2868 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2869 /* diag_listed_as: SKIPME */
2870 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2878 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2886 PERL_ARGS_ASSERT_MAGIC_SET;
2890 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2892 CALLREG_NUMBUF_STORE((REGEXP *)rx,paren,sv);
2894 /* Croak with a READONLY error when a numbered match var is
2895 * set without a previous pattern match. Unless it's C<local $1>
2898 if (!PL_localizing) {
2899 Perl_croak_no_modify();
2905 switch (*mg->mg_ptr) {
2906 case '\001': /* ^A */
2907 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2908 else SvOK_off(PL_bodytarget);
2909 FmLINES(PL_bodytarget) = 0;
2910 if (SvPOK(PL_bodytarget)) {
2911 char *s = SvPVX(PL_bodytarget);
2912 char *e = SvEND(PL_bodytarget);
2913 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2914 FmLINES(PL_bodytarget)++;
2918 /* mg_set() has temporarily made sv non-magical */
2920 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2921 SvTAINTED_on(PL_bodytarget);
2923 SvTAINTED_off(PL_bodytarget);
2926 case '\003': /* ^C */
2927 PL_minus_c = cBOOL(SvIV(sv));
2930 case '\004': /* ^D */
2933 const char *s = SvPV_nolen_const(sv);
2934 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2935 if (DEBUG_x_TEST || DEBUG_B_TEST)
2936 dump_all_perl(!DEBUG_B_TEST);
2939 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2942 case '\005': /* ^E */
2943 if (*(mg->mg_ptr+1) == '\0') {
2945 set_vaxc_errno(SvIV(sv));
2946 #elif defined(WIN32)
2947 SetLastError( SvIV(sv) );
2949 os2_setsyserrno(SvIV(sv));
2951 /* will anyone ever use this? */
2952 SETERRNO(SvIV(sv), 4);
2955 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2956 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2958 case '\006': /* ^F */
2959 if (mg->mg_ptr[1] == '\0') {
2960 PL_maxsysfd = SvIV(sv);
2963 case '\010': /* ^H */
2965 U32 save_hints = PL_hints;
2966 PL_hints = SvUV(sv);
2968 /* If wasn't UTF-8, and now is, notify the parser */
2969 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2970 notify_parser_that_changed_to_utf8();
2974 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2975 Safefree(PL_inplace);
2976 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2978 case '\016': /* ^N */
2979 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2980 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2982 case '\017': /* ^O */
2983 if (*(mg->mg_ptr+1) == '\0') {
2984 Safefree(PL_osname);
2987 TAINT_PROPER("assigning to $^O");
2988 PL_osname = savesvpv(sv);
2991 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2993 const char *const start = SvPV(sv, len);
2994 const char *out = (const char*)memchr(start, '\0', len);
2998 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2999 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
3001 /* Opening for input is more common than opening for output, so
3002 ensure that hints for input are sooner on linked list. */
3003 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
3005 : newSVpvs_flags("", SvUTF8(sv));
3006 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
3009 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
3011 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
3015 case '\020': /* ^P */
3016 PL_perldb = SvIV(sv);
3017 if (PL_perldb && !PL_DBsingle)
3020 case '\024': /* ^T */
3022 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
3024 PL_basetime = (Time_t)SvIV(sv);
3027 case '\025': /* ^UTF8CACHE */
3028 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
3029 PL_utf8cache = (signed char) sv_2iv(sv);
3032 case '\027': /* ^W & $^WARNING_BITS */
3033 if (*(mg->mg_ptr+1) == '\0') {
3034 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3036 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
3037 | (i ? G_WARN_ON : G_WARN_OFF) ;
3040 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
3041 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3043 free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
3048 int not_none = 0, not_all = 0;
3049 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
3050 for (i = 0 ; i < len ; ++i) {
3052 not_all |= ptr[i] ^ 0x55;
3055 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3056 } else if (len >= WARNsize && !not_all) {
3057 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3058 PL_dowarn |= G_WARN_ONCE ;
3062 const char *const p = SvPV_const(sv, len);
3064 PL_compiling.cop_warnings
3065 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3068 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3069 PL_dowarn |= G_WARN_ONCE ;
3077 if (PL_localizing) {
3078 if (PL_localizing == 1)
3079 SAVESPTR(PL_last_in_gv);
3081 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3082 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3085 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
3086 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3087 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3090 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
3091 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3092 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3095 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3098 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3099 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3100 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3103 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3107 IO * const io = GvIO(PL_defoutgv);
3110 if ((SvIV(sv)) == 0)
3111 IoFLAGS(io) &= ~IOf_FLUSH;
3113 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3114 PerlIO *ofp = IoOFP(io);
3116 (void)PerlIO_flush(ofp);
3117 IoFLAGS(io) |= IOf_FLUSH;
3125 SV *referent = SvRV(sv);
3126 const char *reftype = sv_reftype(referent, 0);
3127 /* XXX: dodgy type check: This leaves me feeling dirty, but
3128 * the alternative is to copy pretty much the entire
3129 * sv_reftype() into this routine, or to do a full string
3130 * comparison on the return of sv_reftype() both of which
3131 * make me feel worse! NOTE, do not modify this comment
3132 * without reviewing the corresponding comment in
3133 * sv_reftype(). - Yves */
3134 if (reftype[0] == 'S' || reftype[0] == 'L') {
3135 IV val = SvIV(referent);
3137 sv_setsv(sv, PL_rs);
3138 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3139 val < 0 ? "a negative integer" : "zero");
3142 sv_setsv(sv, PL_rs);
3143 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3144 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3145 *reftype == 'A' ? "n" : "", reftype);
3148 SvREFCNT_dec(PL_rs);
3149 PL_rs = newSVsv(sv);
3153 SvREFCNT_dec(PL_ors_sv);
3155 PL_ors_sv = newSVsv(sv);
3163 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3166 #ifdef COMPLEX_STATUS
3167 if (PL_localizing == 2) {
3168 SvUPGRADE(sv, SVt_PVLV);
3169 PL_statusvalue = LvTARGOFF(sv);
3170 PL_statusvalue_vms = LvTARGLEN(sv);
3174 #ifdef VMSISH_STATUS
3176 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3179 STATUS_UNIX_EXIT_SET(SvIV(sv));
3184 # define PERL_VMS_BANG vaxc$errno
3186 # define PERL_VMS_BANG 0
3189 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3190 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3192 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3193 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3199 /* XXX $< currently silently ignores failures */
3200 const Uid_t new_uid = SvUID(sv);
3201 PL_delaymagic_uid = new_uid;
3202 if (PL_delaymagic) {
3203 PL_delaymagic |= DM_RUID;
3204 break; /* don't do magic till later */
3207 PERL_UNUSED_RESULT(setruid(new_uid));
3208 #elif defined(HAS_SETREUID)
3209 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3210 #elif defined(HAS_SETRESUID)
3211 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3213 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3215 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3216 if (new_uid != 0 && PerlProc_getuid() == 0)
3217 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3219 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3221 Perl_croak(aTHX_ "setruid() not implemented");
3228 /* XXX $> currently silently ignores failures */
3229 const Uid_t new_euid = SvUID(sv);
3230 PL_delaymagic_euid = new_euid;
3231 if (PL_delaymagic) {
3232 PL_delaymagic |= DM_EUID;
3233 break; /* don't do magic till later */
3236 PERL_UNUSED_RESULT(seteuid(new_euid));
3237 #elif defined(HAS_SETREUID)
3238 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3239 #elif defined(HAS_SETRESUID)
3240 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3242 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3243 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3245 Perl_croak(aTHX_ "seteuid() not implemented");
3252 /* XXX $( currently silently ignores failures */
3253 const Gid_t new_gid = SvGID(sv);
3254 PL_delaymagic_gid = new_gid;
3255 if (PL_delaymagic) {
3256 PL_delaymagic |= DM_RGID;
3257 break; /* don't do magic till later */
3260 PERL_UNUSED_RESULT(setrgid(new_gid));
3261 #elif defined(HAS_SETREGID)
3262 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3263 #elif defined(HAS_SETRESGID)
3264 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3266 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3267 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3269 Perl_croak(aTHX_ "setrgid() not implemented");
3276 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3277 * but you can override it if you need to.
3280 #define INVALID_GID ((Gid_t)-1)
3282 /* XXX $) currently silently ignores failures */
3284 #ifdef HAS_SETGROUPS
3286 const char *p = SvPV_const(sv, len);
3287 Groups_t *gary = NULL;
3288 const char* p_end = p + len;
3289 const char* endptr = p_end;
3291 #ifdef _SC_NGROUPS_MAX
3292 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3297 int maxgrp = NGROUPS;
3302 if (grok_atoUV(p, &uv, &endptr))
3303 new_egid = (Gid_t)uv;
3305 new_egid = INVALID_GID;
3308 for (i = 0; i < maxgrp; ++i) {
3318 Newx(gary, i + 1, Groups_t);
3320 Renew(gary, i + 1, Groups_t);
3321 if (grok_atoUV(p, &uv, &endptr))
3322 gary[i] = (Groups_t)uv;
3324 gary[i] = INVALID_GID;
3329 PERL_UNUSED_RESULT(setgroups(i, gary));
3332 #else /* HAS_SETGROUPS */
3333 new_egid = SvGID(sv);
3334 #endif /* HAS_SETGROUPS */
3335 PL_delaymagic_egid = new_egid;
3336 if (PL_delaymagic) {
3337 PL_delaymagic |= DM_EGID;
3338 break; /* don't do magic till later */
3341 PERL_UNUSED_RESULT(setegid(new_egid));
3342 #elif defined(HAS_SETREGID)
3343 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3344 #elif defined(HAS_SETRESGID)
3345 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3347 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3348 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3350 Perl_croak(aTHX_ "setegid() not implemented");
3356 PL_chopset = SvPV_force(sv,len);
3359 /* Store the pid in mg->mg_obj so we can tell when a fork has
3360 occurred. mg->mg_obj points to *$ by default, so clear it. */
3361 if (isGV(mg->mg_obj)) {
3362 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3363 SvREFCNT_dec(mg->mg_obj);
3364 mg->mg_flags |= MGf_REFCOUNTED;
3365 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3367 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3370 LOCK_DOLLARZERO_MUTEX;
3371 S_set_dollarzero(aTHX_ sv);
3372 UNLOCK_DOLLARZERO_MUTEX;
3379 =for apidoc_section $signals
3380 =for apidoc whichsig
3381 =for apidoc_item whichsig_pv
3382 =for apidoc_item whichsig_pvn
3383 =for apidoc_item whichsig_sv
3385 These all convert a signal name into its corresponding signal number;
3386 returning -1 if no corresponding number was found.
3388 They differ only in the source of the signal name:
3390 C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
3393 C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
3395 C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
3398 C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
3404 Perl_whichsig_sv(pTHX_ SV *sigsv)
3408 PERL_ARGS_ASSERT_WHICHSIG_SV;
3409 sigpv = SvPV_const(sigsv, siglen);
3410 return whichsig_pvn(sigpv, siglen);
3414 Perl_whichsig_pv(pTHX_ const char *sig)
3416 PERL_ARGS_ASSERT_WHICHSIG_PV;
3417 return whichsig_pvn(sig, strlen(sig));
3421 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3425 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3426 PERL_UNUSED_CONTEXT;
3428 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3429 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3430 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3432 if (memEQs(sig, len, "CHLD"))
3436 if (memEQs(sig, len, "CLD"))
3443 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3444 * these three function are intended to be called by the OS as 'C' level
3445 * signal handler functions in the case where unsafe signals are being
3446 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3447 * perl-level sighandler, rather than deferring.
3448 * In fact, the core itself will normally use Perl_csighandler as the
3449 * OS-level handler; that function will then decide whether to queue the
3450 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3451 * functions are more useful for e.g. POSIX.xs when it wants explicit
3452 * control of what's happening.
3456 #ifdef PERL_USE_3ARG_SIGHANDLER
3459 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3461 Perl_perly_sighandler(sig, sip, uap, 0);
3467 Perl_sighandler(int sig)
3469 Perl_perly_sighandler(sig, NULL, NULL, 0);
3475 Perl_sighandler1(int sig)
3477 Perl_perly_sighandler(sig, NULL, NULL, 0);
3481 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3483 Perl_perly_sighandler(sig, sip, uap, 0);
3487 /* Invoke the perl-level signal handler. This function is called either
3488 * directly from one of the C-level signals handlers (Perl_sighandler or
3489 * Perl_csighandler), or for safe signals, later from
3490 * Perl_despatch_signals() at a suitable safe point during execution.
3492 * 'safe' is a boolean indicating the latter call path.
3496 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3497 void *uap PERL_UNUSED_DECL, bool safe)
3499 #ifdef PERL_GET_SIG_CONTEXT
3500 dTHXa(PERL_GET_SIG_CONTEXT);
3507 SV * const tSv = PL_Sv;
3511 XPV * const tXpv = PL_Xpv;
3512 I32 old_ss_ix = PL_savestack_ix;
3513 SV *errsv_save = NULL;
3516 if (!PL_psig_ptr[sig]) {
3517 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3522 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3523 /* Max number of items pushed there is 3*n or 4. We cannot fix
3524 infinity, so we fix 4 (in fact 5): */
3525 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3527 PL_savestack_ix += 5; /* Protect save in progress. */
3528 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3531 /* sv_2cv is too complicated, try a simpler variant first: */
3532 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3533 || SvTYPE(cv) != SVt_PVCV) {
3535 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3538 if (!cv || !CvROOT(cv)) {
3539 const HEK * const hek = gv
3543 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3545 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3546 "SIG%s handler \"%" HEKf "\" not defined.\n",
3547 PL_sig_name[sig], HEKfARG(hek));
3548 /* diag_listed_as: SIG%s handler "%s" not defined */
3549 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3550 "SIG%s handler \"__ANON__\" not defined.\n",
3555 sv = PL_psig_name[sig]
3556 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3557 : newSVpv(PL_sig_name[sig],0);
3561 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3562 /* make sure our assumption about the size of the SAVEs are correct:
3563 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3564 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3567 PUSHSTACKi(PERLSI_SIGNAL);
3571 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3573 struct sigaction oact;
3575 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3577 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3578 /* The siginfo fields signo, code, errno, pid, uid,
3579 * addr, status, and band are defined by POSIX/SUSv3. */
3580 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3581 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3582 # ifdef HAS_SIGINFO_SI_ERRNO
3583 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3585 # ifdef HAS_SIGINFO_SI_STATUS
3586 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3588 # ifdef HAS_SIGINFO_SI_UID
3591 sv_setuid(uid, sip->si_uid);
3592 (void)hv_stores(sih, "uid", uid);
3595 # ifdef HAS_SIGINFO_SI_PID
3596 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3598 # ifdef HAS_SIGINFO_SI_ADDR
3599 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3601 # ifdef HAS_SIGINFO_SI_BAND
3602 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3606 mPUSHp((char *)sip, sizeof(*sip));
3614 errsv_save = newSVsv(ERRSV);
3616 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3620 SV * const errsv = ERRSV;
3621 if (SvTRUE_NN(errsv)) {
3622 SvREFCNT_dec(errsv_save);
3625 /* Handler "died", for example to get out of a restart-able read().
3626 * Before we re-do that on its behalf re-enable the signal which was
3627 * blocked by the system when we entered.
3629 # ifdef HAS_SIGPROCMASK
3631 /* safe signals called via dispatch_signals() set up a
3632 * savestack destructor, unblock_sigmask(), to
3633 * automatically unblock the handler at the end. If
3634 * instead we get here directly, we have to do it
3639 sigaddset(&set,sig);
3640 sigprocmask(SIG_UNBLOCK, &set, NULL);
3643 /* Not clear if this will work */
3644 /* XXX not clear if this should be protected by 'if (safe)'
3647 (void)rsignal(sig, SIG_IGN);
3648 (void)rsignal(sig, PL_csighandlerp);
3650 #endif /* !PERL_MICRO */
3655 sv_setsv(errsv, errsv_save);
3656 SvREFCNT_dec(errsv_save);
3661 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3662 PL_savestack_ix = old_ss_ix;
3664 SvREFCNT_dec_NN(sv);
3665 PL_op = myop; /* Apparently not needed... */
3667 PL_Sv = tSv; /* Restore global temporaries. */
3674 S_restore_magic(pTHX_ const void *p)
3676 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3677 SV* const sv = mgs->mgs_sv;
3683 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3684 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3686 SvFLAGS(sv) |= mgs->mgs_flags;
3691 bumped = mgs->mgs_bumped;
3692 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3694 /* If we're still on top of the stack, pop us off. (That condition
3695 * will be satisfied if restore_magic was called explicitly, but *not*
3696 * if it's being called via leave_scope.)
3697 * The reason for doing this is that otherwise, things like sv_2cv()
3698 * may leave alloc gunk on the savestack, and some code
3699 * (e.g. sighandler) doesn't expect that...
3701 if (PL_savestack_ix == mgs->mgs_ss_ix)
3703 UV popval = SSPOPUV;
3704 assert(popval == SAVEt_DESTRUCTOR_X);
3705 PL_savestack_ix -= 2;
3707 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3708 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3711 if (SvREFCNT(sv) == 1) {
3712 /* We hold the last reference to this SV, which implies that the
3713 SV was deleted as a side effect of the routines we called.
3714 So artificially keep it alive a bit longer.
3715 We avoid turning on the TEMP flag, which can cause the SV's
3716 buffer to get stolen (and maybe other stuff). */
3721 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3725 /* clean up the mess created by Perl_sighandler().
3726 * Note that this is only called during an exit in a signal handler;
3727 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3731 S_unwind_handler_stack(pTHX_ const void *p)
3735 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3739 =for apidoc_section $magic
3740 =for apidoc magic_sethint
3742 Triggered by a store to C<%^H>, records the key/value pair to
3743 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3744 anything that would need a deep copy. Maybe we should warn if we find a
3750 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3752 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3753 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3755 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3757 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3758 an alternative leaf in there, with PL_compiling.cop_hints being used if
3759 it's NULL. If needed for threads, the alternative could lock a mutex,
3760 or take other more complex action. */
3762 /* Something changed in %^H, so it will need to be restored on scope exit.
3763 Doing this here saves a lot of doing it manually in perl code (and
3764 forgetting to do it, and consequent subtle errors. */
3765 PL_hints |= HINT_LOCALIZE_HH;
3766 CopHINTHASH_set(&PL_compiling,
3767 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3768 magic_sethint_feature(key, NULL, 0, sv, 0);
3773 =for apidoc magic_clearhint
3775 Triggered by a delete from C<%^H>, records the key to
3776 C<PL_compiling.cop_hints_hash>.
3781 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3783 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3784 PERL_UNUSED_ARG(sv);
3786 PL_hints |= HINT_LOCALIZE_HH;
3787 CopHINTHASH_set(&PL_compiling,
3788 mg->mg_len == HEf_SVKEY
3789 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3790 MUTABLE_SV(mg->mg_ptr), 0, 0)
3791 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3792 mg->mg_ptr, mg->mg_len, 0, 0));
3793 if (mg->mg_len == HEf_SVKEY)
3794 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3796 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
3801 =for apidoc magic_clearhints
3803 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3808 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3810 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3811 PERL_UNUSED_ARG(sv);
3812 PERL_UNUSED_ARG(mg);
3813 cophh_free(CopHINTHASH_get(&PL_compiling));
3814 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3820 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3821 const char *name, I32 namlen)
3825 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3826 PERL_UNUSED_ARG(sv);
3827 PERL_UNUSED_ARG(name);
3828 PERL_UNUSED_ARG(namlen);
3830 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3831 nmg = mg_find(nsv, mg->mg_type);
3833 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3834 nmg->mg_ptr = mg->mg_ptr;
3835 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3836 nmg->mg_flags |= MGf_REFCOUNTED;
3841 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3842 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3844 #if DBVARMG_SINGLE != 0
3845 assert(mg->mg_private >= DBVARMG_SINGLE);
3847 assert(mg->mg_private < DBVARMG_COUNT);
3849 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3855 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3856 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3858 #if DBVARMG_SINGLE != 0
3859 assert(mg->mg_private >= DBVARMG_SINGLE);
3861 assert(mg->mg_private < DBVARMG_COUNT);
3862 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3868 * ex: set ts=8 sts=4 sw=4 et: