3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
20 "Magic" is special data attached to SV structures in order to give them
21 "magical" properties. When any Perl code tries to read from, or assign to,
22 an SV marked as magical, it calls the 'get' or 'set' function associated
23 with that SV's magic. A get is called prior to reading an SV, in order to
24 give it a chance to update its internal value (get on $. writes the line
25 number of the last read filehandle into the SV's IV slot), while
26 set is called after an SV has been written to, in order to allow it to make
27 use of its changed value (set on $/ copies the SV's new value to the
28 PL_rs global variable).
30 Magic is implemented as a linked list of MAGIC structures attached to the
31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
32 of functions that implement the get(), set(), length() etc functions,
33 plus space for some flags and pointers. For example, a tied variable has
34 a MAGIC structure that contains a pointer to the object associated with the
45 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
51 #if defined(HAS_SETGROUPS)
58 # include <sys/pstat.h>
61 #ifdef HAS_PRCTL_SET_NAME
62 # include <sys/prctl.h>
66 #ifdef PERL_USE_3ARG_SIGHANDLER
67 Signal_t Perl_csighandler(int sig, Siginfo_t *, void *);
69 Signal_t Perl_csighandler(int sig);
73 /* Missing protos on LynxOS */
74 void setruid(uid_t id);
75 void seteuid(uid_t id);
76 void setrgid(uid_t id);
77 void setegid(uid_t id);
81 * Pre-magic setup and post-magic takedown.
82 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
91 /* MGS is typedef'ed to struct magic_state in perl.h */
94 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
99 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
101 assert(SvMAGICAL(sv));
103 /* we shouldn't really be called here with RC==0, but it can sometimes
104 * happen via mg_clear() (which also shouldn't be called when RC==0,
105 * but it can happen). Handle this case gracefully(ish) by not RC++
106 * and thus avoiding the resultant double free */
107 if (SvREFCNT(sv) > 0) {
108 /* guard against sv getting freed midway through the mg clearing,
109 * by holding a private reference for the duration. */
110 SvREFCNT_inc_simple_void_NN(sv);
114 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
116 mgs = SSPTR(mgs_ix, MGS*);
118 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
119 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
120 mgs->mgs_bumped = bumped;
122 SvFLAGS(sv) &= ~flags;
126 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
129 =for apidoc mg_magical
131 Turns on the magical status of an SV. See C<L</sv_magic>>.
137 Perl_mg_magical(SV *sv)
140 PERL_ARGS_ASSERT_MG_MAGICAL;
143 if ((mg = SvMAGIC(sv))) {
145 const MGVTBL* const vtbl = mg->mg_virtual;
147 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
154 } while ((mg = mg->mg_moremagic));
155 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
163 Do magic before a value is retrieved from the SV. The type of SV must
164 be >= C<SVt_PVMG>. See C<L</sv_magic>>.
170 Perl_mg_get(pTHX_ SV *sv)
172 const I32 mgs_ix = SSNEW(sizeof(MGS));
175 bool taint_only = TRUE; /* the only get method seen is taint */
176 MAGIC *newmg, *head, *cur, *mg;
178 PERL_ARGS_ASSERT_MG_GET;
180 if (PL_localizing == 1 && sv == DEFSV) return 0;
182 /* We must call svt_get(sv, mg) for each valid entry in the linked
183 list of magic. svt_get() may delete the current entry, add new
184 magic to the head of the list, or upgrade the SV. AMS 20010810 */
186 newmg = cur = head = mg = SvMAGIC(sv);
188 const MGVTBL * const vtbl = mg->mg_virtual;
189 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
191 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
193 /* taint's mg get is so dumb it doesn't need flag saving */
194 if (mg->mg_type != PERL_MAGIC_taint) {
197 save_magic(mgs_ix, sv);
202 vtbl->svt_get(aTHX_ sv, mg);
204 /* guard against magic having been deleted - eg FETCH calling
207 /* recalculate flags */
208 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
212 /* recalculate flags if this entry was deleted. */
213 if (mg->mg_flags & MGf_GSKIP)
214 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
215 ~(SVs_GMG|SVs_SMG|SVs_RMG);
217 else if (vtbl == &PL_vtbl_utf8) {
218 /* get-magic can reallocate the PV, unless there's only taint
222 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
223 if ( mg2->mg_type != PERL_MAGIC_taint
224 && !(mg2->mg_flags & MGf_GSKIP)
226 && mg2->mg_virtual->svt_get
234 magic_setutf8(sv, mg);
240 /* Have we finished with the new entries we saw? Start again
241 where we left off (unless there are more new entries). */
249 /* Were any new entries added? */
250 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
254 /* recalculate flags */
255 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
260 restore_magic(INT2PTR(void *, (IV)mgs_ix));
268 Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
274 Perl_mg_set(pTHX_ SV *sv)
276 const I32 mgs_ix = SSNEW(sizeof(MGS));
280 PERL_ARGS_ASSERT_MG_SET;
282 if (PL_localizing == 2 && sv == DEFSV) return 0;
284 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
286 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
287 const MGVTBL* vtbl = mg->mg_virtual;
288 nextmg = mg->mg_moremagic; /* it may delete itself */
289 if (mg->mg_flags & MGf_GSKIP) {
290 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
291 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
293 if (PL_localizing == 2
294 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
296 if (vtbl && vtbl->svt_set)
297 vtbl->svt_set(aTHX_ sv, mg);
300 restore_magic(INT2PTR(void*, (IV)mgs_ix));
305 =for apidoc mg_length
307 Reports on the SV's length in bytes, calling length magic if available,
308 but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
309 magic if there is no 'length' magic, but with no indication as to
310 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
311 higher. Use C<sv_len()> instead.
317 Perl_mg_length(pTHX_ SV *sv)
322 PERL_ARGS_ASSERT_MG_LENGTH;
324 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
325 const MGVTBL * const vtbl = mg->mg_virtual;
326 if (vtbl && vtbl->svt_len) {
327 const I32 mgs_ix = SSNEW(sizeof(MGS));
328 save_magic(mgs_ix, sv);
329 /* omit MGf_GSKIP -- not changed here */
330 len = vtbl->svt_len(aTHX_ sv, mg);
331 restore_magic(INT2PTR(void*, (IV)mgs_ix));
336 (void)SvPV_const(sv, len);
341 Perl_mg_size(pTHX_ SV *sv)
345 PERL_ARGS_ASSERT_MG_SIZE;
347 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
348 const MGVTBL* const vtbl = mg->mg_virtual;
349 if (vtbl && vtbl->svt_len) {
350 const I32 mgs_ix = SSNEW(sizeof(MGS));
352 save_magic(mgs_ix, sv);
353 /* omit MGf_GSKIP -- not changed here */
354 len = vtbl->svt_len(aTHX_ sv, mg);
355 restore_magic(INT2PTR(void*, (IV)mgs_ix));
362 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
366 Perl_croak(aTHX_ "Size magic not implemented");
369 NOT_REACHED; /* NOTREACHED */
375 Clear something magical that the SV represents. See C<L</sv_magic>>.
381 Perl_mg_clear(pTHX_ SV *sv)
383 const I32 mgs_ix = SSNEW(sizeof(MGS));
387 PERL_ARGS_ASSERT_MG_CLEAR;
389 save_magic(mgs_ix, sv);
391 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
392 const MGVTBL* const vtbl = mg->mg_virtual;
393 /* omit GSKIP -- never set here */
395 nextmg = mg->mg_moremagic; /* it may delete itself */
397 if (vtbl && vtbl->svt_clear)
398 vtbl->svt_clear(aTHX_ sv, mg);
401 restore_magic(INT2PTR(void*, (IV)mgs_ix));
406 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
413 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
414 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
426 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
432 Perl_mg_find(const SV *sv, int type)
434 return S_mg_findext_flags(sv, type, NULL, 0);
438 =for apidoc mg_findext
440 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
447 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
449 return S_mg_findext_flags(sv, type, vtbl, 1);
453 Perl_mg_find_mglob(pTHX_ SV *sv)
455 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
456 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
457 /* This sv is only a delegate. //g magic must be attached to
462 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
463 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
470 Copies the magic from one SV to another. See C<L</sv_magic>>.
476 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
481 PERL_ARGS_ASSERT_MG_COPY;
483 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
484 const MGVTBL* const vtbl = mg->mg_virtual;
485 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
486 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
489 const char type = mg->mg_type;
490 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
492 (type == PERL_MAGIC_tied)
495 toLOWER(type), key, klen);
504 =for apidoc mg_localize
506 Copy some of the magic from an existing SV to new localized version of that
507 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
508 gets copied, value magic doesn't (I<e.g.>,
511 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
512 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
513 and that will handle the magic.
519 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
523 PERL_ARGS_ASSERT_MG_LOCALIZE;
528 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
529 const MGVTBL* const vtbl = mg->mg_virtual;
530 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
533 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
534 (void)vtbl->svt_local(aTHX_ nsv, mg);
536 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
537 mg->mg_ptr, mg->mg_len);
539 /* container types should remain read-only across localization */
540 SvFLAGS(nsv) |= SvREADONLY(sv);
543 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
544 SvFLAGS(nsv) |= SvMAGICAL(sv);
553 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
555 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
557 const MGVTBL* const vtbl = mg->mg_virtual;
558 if (vtbl && vtbl->svt_free)
559 vtbl->svt_free(aTHX_ sv, mg);
561 if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
562 /* collate magic uses string len not buffer len, so
563 * free even with mg_len == 0 */
564 Safefree(mg->mg_ptr);
565 else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
566 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
567 Safefree(mg->mg_ptr);
568 else if (mg->mg_len == HEf_SVKEY)
569 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
572 if (mg->mg_flags & MGf_REFCOUNTED)
573 SvREFCNT_dec(mg->mg_obj);
580 Free any magic storage used by the SV. See C<L</sv_magic>>.
586 Perl_mg_free(pTHX_ SV *sv)
591 PERL_ARGS_ASSERT_MG_FREE;
593 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
594 moremagic = mg->mg_moremagic;
595 mg_free_struct(sv, mg);
596 SvMAGIC_set(sv, moremagic);
598 SvMAGIC_set(sv, NULL);
604 =for apidoc mg_free_type
606 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
612 Perl_mg_free_type(pTHX_ SV *sv, int how)
614 MAGIC *mg, *prevmg, *moremg;
615 PERL_ARGS_ASSERT_MG_FREE_TYPE;
616 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
617 moremg = mg->mg_moremagic;
618 if (mg->mg_type == how) {
620 /* temporarily move to the head of the magic chain, in case
621 custom free code relies on this historical aspect of mg_free */
623 prevmg->mg_moremagic = moremg;
624 mg->mg_moremagic = SvMAGIC(sv);
627 newhead = mg->mg_moremagic;
628 mg_free_struct(sv, mg);
629 SvMAGIC_set(sv, newhead);
637 =for apidoc mg_freeext
639 Remove any magic of type C<how> using virtual table C<vtbl> from the
640 SV C<sv>. See L</sv_magic>.
642 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
648 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
650 MAGIC *mg, *prevmg, *moremg;
651 PERL_ARGS_ASSERT_MG_FREEEXT;
652 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
654 moremg = mg->mg_moremagic;
655 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
656 /* temporarily move to the head of the magic chain, in case
657 custom free code relies on this historical aspect of mg_free */
659 prevmg->mg_moremagic = moremg;
660 mg->mg_moremagic = SvMAGIC(sv);
663 newhead = mg->mg_moremagic;
664 mg_free_struct(sv, mg);
665 SvMAGIC_set(sv, newhead);
675 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
679 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
682 REGEXP * const rx = PM_GETRE(PL_curpm);
684 const SSize_t n = (SSize_t)mg->mg_obj;
685 if (n == '+') { /* @+ */
686 /* return the number possible */
687 return RX_NPARENS(rx);
688 } else { /* @- @^CAPTURE @{^CAPTURE} */
689 I32 paren = RX_LASTPAREN(rx);
691 /* return the last filled */
693 && (RX_OFFS(rx)[paren].start == -1
694 || RX_OFFS(rx)[paren].end == -1) )
700 /* @^CAPTURE @{^CAPTURE} */
701 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
713 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
715 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
718 REGEXP * const rx = PM_GETRE(PL_curpm);
720 const SSize_t n = (SSize_t)mg->mg_obj;
721 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
722 const I32 paren = mg->mg_len
723 + (n == '\003' ? 1 : 0);
728 if (paren <= (I32)RX_NPARENS(rx) &&
729 (s = RX_OFFS(rx)[paren].start) != -1 &&
730 (t = RX_OFFS(rx)[paren].end) != -1)
734 if (n == '+') /* @+ */
736 else if (n == '-') /* @- */
738 else { /* @^CAPTURE @{^CAPTURE} */
739 CALLREG_NUMBUF_FETCH(rx,paren,sv);
743 if (RX_MATCH_UTF8(rx)) {
744 const char * const b = RX_SUBBEG(rx);
746 i = RX_SUBCOFFSET(rx) +
748 (U8*)(b-RX_SUBOFFSET(rx)+i));
763 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
765 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
769 Perl_croak_no_modify();
770 NORETURN_FUNCTION_END;
773 #define SvRTRIM(sv) STMT_START { \
775 STRLEN len = SvCUR(sv); \
776 char * const p = SvPVX(sv); \
777 while (len > 0 && isSPACE(p[len-1])) \
779 SvCUR_set(sv, len); \
785 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
787 PERL_ARGS_ASSERT_EMULATE_COP_IO;
789 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
794 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
795 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
800 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
801 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
809 S_fixup_errno_string(pTHX_ SV* sv)
811 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
814 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
818 if(strEQ(SvPVX(sv), "")) {
819 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
823 /* In some locales the error string may come back as UTF-8, in which
824 * case we should turn on that flag. This didn't use to happen, and to
825 * avoid as many possible backward compatibility issues as possible, we
826 * don't turn on the flag unless we have to. So the flag stays off for
827 * an entirely invariant string. We assume that if the string looks
828 * like UTF-8 in a single script, it really is UTF-8: "text in any
829 * other encoding that uses bytes with the high bit set is extremely
830 * unlikely to pass a UTF-8 validity test"
831 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
832 * potential that we will get it wrong however, especially on short
833 * error message text, so do an additional check. */
834 if ( ! IN_BYTES /* respect 'use bytes' */
835 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
837 #ifdef USE_LOCALE_MESSAGES
839 && _is_cur_LC_category_utf8(LC_MESSAGES)
841 #else /* If can't check directly, at least can see if script is consistent,
842 under UTF-8, which gives us an extra measure of confidence. */
844 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
845 TRUE) /* Means assume UTF-8 */
855 =for apidoc sv_string_from_errnum
857 Generates the message string describing an OS error and returns it as
858 an SV. C<errnum> must be a value that C<errno> could take, identifying
861 If C<tgtsv> is non-null then the string will be written into that SV
862 (overwriting existing content) and it will be returned. If C<tgtsv>
863 is a null pointer then the string will be written into a new mortal SV
864 which will be returned.
866 The message will be taken from whatever locale would be used by C<$!>,
867 and will be encoded in the SV in whatever manner would be used by C<$!>.
868 The details of this process are subject to future change. Currently,
869 the message is taken from the C locale by default (usually producing an
870 English message), and from the currently selected locale when in the scope
871 of the C<use locale> pragma. A heuristic attempt is made to decode the
872 message from the locale's character encoding, but it will only be decoded
873 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
874 locale, usually in an ISO-8859-1 locale, and never in any other locale.
876 The SV is always returned containing an actual string, and with no other
877 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
878 (meaning success), and if no useful message is available then a useless
879 string (currently empty) is returned.
885 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
889 tgtsv = sv_newmortal();
890 errstr = my_strerror(errnum);
892 sv_setpv(tgtsv, errstr);
893 fixup_errno_string(tgtsv);
906 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
909 const char *s = NULL;
911 const char * const remaining = mg->mg_ptr + 1;
914 PERL_ARGS_ASSERT_MAGIC_GET;
918 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
920 CALLREG_NUMBUF_FETCH(rx,paren,sv);
927 nextchar = *remaining;
928 switch (*mg->mg_ptr) {
929 case '\001': /* ^A */
930 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
933 if (SvTAINTED(PL_bodytarget))
936 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
937 if (nextchar == '\0') {
938 sv_setiv(sv, (IV)PL_minus_c);
940 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
941 sv_setiv(sv, (IV)STATUS_NATIVE);
945 case '\004': /* ^D */
946 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
948 case '\005': /* ^E */
949 if (nextchar != '\0') {
950 if (strEQ(remaining, "NCODING"))
955 #if defined(VMS) || defined(OS2) || defined(WIN32)
959 $DESCRIPTOR(msgdsc,msg);
960 sv_setnv(sv,(NV) vaxc$errno);
961 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
962 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
967 if (!(_emx_env & 0x200)) { /* Under DOS */
968 sv_setnv(sv, (NV)errno);
969 sv_setpv(sv, errno ? my_strerror(errno) : "");
971 if (errno != errno_isOS2) {
972 const int tmp = _syserrno();
973 if (tmp) /* 2nd call to _syserrno() makes it 0 */
976 sv_setnv(sv, (NV)Perl_rc);
977 sv_setpv(sv, os2error(Perl_rc));
979 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
980 fixup_errno_string(sv);
982 # elif defined(WIN32)
984 const DWORD dwErr = GetLastError();
985 sv_setnv(sv, (NV)dwErr);
987 PerlProc_GetOSError(sv, dwErr);
988 fixup_errno_string(sv);
995 # error Missing code for platform
998 SvNOK_on(sv); /* what a wonderful hack! */
1000 #endif /* End of platforms with special handling for $^E; others just fall
1008 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1010 sv_setnv(sv, (NV)errno);
1013 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1014 sv_setpv(sv, os2error(Perl_rc));
1021 sv_string_from_errnum(errno, sv);
1022 /* If no useful string is available, don't
1023 * claim to have a string part. The SvNOK_on()
1024 * below will cause just the number part to be valid */
1032 SvNOK_on(sv); /* what a wonderful hack! */
1035 case '\006': /* ^F */
1036 if (nextchar == '\0') {
1037 sv_setiv(sv, (IV)PL_maxsysfd);
1039 else if (strEQ(remaining, "EATURE_BITS")) {
1040 sv_setuv(sv, PL_compiling.cop_features);
1043 case '\007': /* ^GLOBAL_PHASE */
1044 if (strEQ(remaining, "LOBAL_PHASE")) {
1045 sv_setpvn(sv, PL_phase_names[PL_phase],
1046 strlen(PL_phase_names[PL_phase]));
1049 case '\010': /* ^H */
1050 sv_setuv(sv, PL_hints);
1052 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1053 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1055 case '\014': /* ^LAST_FH */
1056 if (strEQ(remaining, "AST_FH")) {
1057 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1058 assert(isGV_with_GP(PL_last_in_gv));
1059 SV_CHECK_THINKFIRST_COW_DROP(sv);
1060 prepare_SV_for_RV(sv);
1062 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
1070 case '\017': /* ^O & ^OPEN */
1071 if (nextchar == '\0') {
1072 sv_setpv(sv, PL_osname);
1075 else if (strEQ(remaining, "PEN")) {
1076 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1080 sv_setiv(sv, (IV)PL_perldb);
1082 case '\023': /* ^S */
1083 if (nextchar == '\0') {
1084 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1086 else if (PL_in_eval)
1087 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1091 else if (strEQ(remaining, "AFE_LOCALES")) {
1093 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1095 sv_setuv(sv, (UV) 1);
1098 sv_setuv(sv, (UV) 0);
1104 case '\024': /* ^T */
1105 if (nextchar == '\0') {
1107 sv_setnv(sv, PL_basetime);
1109 sv_setiv(sv, (IV)PL_basetime);
1112 else if (strEQ(remaining, "AINT"))
1113 sv_setiv(sv, TAINTING_get
1114 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1117 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1118 if (strEQ(remaining, "NICODE"))
1119 sv_setuv(sv, (UV) PL_unicode);
1120 else if (strEQ(remaining, "TF8LOCALE"))
1121 sv_setuv(sv, (UV) PL_utf8locale);
1122 else if (strEQ(remaining, "TF8CACHE"))
1123 sv_setiv(sv, (IV) PL_utf8cache);
1125 case '\027': /* ^W & $^WARNING_BITS */
1126 if (nextchar == '\0')
1127 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1128 else if (strEQ(remaining, "ARNING_BITS")) {
1129 if (PL_compiling.cop_warnings == pWARN_NONE) {
1130 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1132 else if (PL_compiling.cop_warnings == pWARN_STD) {
1135 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1136 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1139 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1140 *PL_compiling.cop_warnings);
1144 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
1145 sv_setiv(sv, w32_sloppystat);
1150 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1151 paren = RX_LASTPAREN(rx);
1153 goto do_numbuf_fetch;
1156 case '\016': /* ^N */
1157 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1158 paren = RX_LASTCLOSEPAREN(rx);
1160 goto do_numbuf_fetch;
1164 if (GvIO(PL_last_in_gv)) {
1165 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1170 sv_setiv(sv, (IV)STATUS_CURRENT);
1171 #ifdef COMPLEX_STATUS
1172 SvUPGRADE(sv, SVt_PVLV);
1173 LvTARGOFF(sv) = PL_statusvalue;
1174 LvTARGLEN(sv) = PL_statusvalue_vms;
1179 if (GvIOp(PL_defoutgv))
1180 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1184 sv_setpv(sv,GvENAME(PL_defoutgv));
1185 sv_catpvs(sv,"_TOP");
1189 if (GvIOp(PL_defoutgv))
1190 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1192 s = GvENAME(PL_defoutgv);
1196 if (GvIO(PL_defoutgv))
1197 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1200 if (GvIO(PL_defoutgv))
1201 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1204 if (GvIO(PL_defoutgv))
1205 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1214 if (GvIO(PL_defoutgv))
1215 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1219 sv_copypv(sv, PL_ors_sv);
1225 IV const pid = (IV)PerlProc_getpid();
1226 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1227 /* never set manually, or at least not since last fork */
1229 /* never unsafe, even if reading in a tainted expression */
1232 /* else a value has been assigned manually, so do nothing */
1236 sv_setuid(sv, PerlProc_getuid());
1239 sv_setuid(sv, PerlProc_geteuid());
1242 sv_setgid(sv, PerlProc_getgid());
1245 sv_setgid(sv, PerlProc_getegid());
1247 #ifdef HAS_GETGROUPS
1249 Groups_t *gary = NULL;
1250 I32 num_groups = getgroups(0, gary);
1251 if (num_groups > 0) {
1253 Newx(gary, num_groups, Groups_t);
1254 num_groups = getgroups(num_groups, gary);
1255 for (i = 0; i < num_groups; i++)
1256 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1260 (void)SvIOK_on(sv); /* what a wonderful hack! */
1274 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1276 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1278 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1280 if (uf && uf->uf_val)
1281 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1286 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1288 STRLEN len = 0, klen;
1289 const char * const key = MgPV_const(mg,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) && !defined(MSDOS)
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 nor MSDOS */
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);
1559 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1560 /* Call the perl level handler now--
1561 * with risk we may be in malloc() or being destructed etc. */
1563 if (PL_sighandlerp == Perl_sighandler)
1564 /* default handler, so can call perly_sighandler() directly
1565 * rather than via Perl_sighandler, passing the extra
1566 * 'safe = false' arg
1568 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
1570 #ifdef PERL_USE_3ARG_SIGHANDLER
1571 (*PL_sighandlerp)(sig, NULL, NULL);
1573 (*PL_sighandlerp)(sig);
1577 if (!PL_psig_pend) return;
1578 /* Set a flag to say this signal is pending, that is awaiting delivery after
1579 * the current Perl opcode completes */
1580 PL_psig_pend[sig]++;
1582 #ifndef SIG_PENDING_DIE_COUNT
1583 # define SIG_PENDING_DIE_COUNT 120
1585 /* Add one to say _a_ signal is pending */
1586 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1587 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1588 (unsigned long)SIG_PENDING_DIE_COUNT);
1592 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1594 Perl_csighandler_init(void)
1597 if (PL_sig_handlers_initted) return;
1599 for (sig = 1; sig < SIG_SIZE; sig++) {
1600 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1602 PL_sig_defaulting[sig] = 1;
1603 (void) rsignal(sig, PL_csighandlerp);
1605 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1606 PL_sig_ignoring[sig] = 0;
1609 PL_sig_handlers_initted = 1;
1613 #if defined HAS_SIGPROCMASK
1615 unblock_sigmask(pTHX_ void* newset)
1617 PERL_UNUSED_CONTEXT;
1618 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1623 Perl_despatch_signals(pTHX)
1627 for (sig = 1; sig < SIG_SIZE; sig++) {
1628 if (PL_psig_pend[sig]) {
1630 #ifdef HAS_SIGPROCMASK
1631 /* From sigaction(2) (FreeBSD man page):
1632 * | Signal routines normally execute with the signal that
1633 * | caused their invocation blocked, but other signals may
1635 * Emulation of this behavior (from within Perl) is enabled
1639 sigset_t newset, oldset;
1641 sigemptyset(&newset);
1642 sigaddset(&newset, sig);
1643 sigprocmask(SIG_BLOCK, &newset, &oldset);
1644 was_blocked = sigismember(&oldset, sig);
1646 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1648 SAVEFREESV(save_sv);
1649 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1652 PL_psig_pend[sig] = 0;
1653 if (PL_sighandlerp == Perl_sighandler)
1654 /* default handler, so can call perly_sighandler() directly
1655 * rather than via Perl_sighandler, passing the extra
1658 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1660 #ifdef PERL_USE_3ARG_SIGHANDLER
1661 (*PL_sighandlerp)(sig, NULL, NULL);
1663 (*PL_sighandlerp)(sig);
1666 #ifdef HAS_SIGPROCMASK
1675 /* sv of NULL signifies that we're acting as magic_clearsig. */
1677 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1682 /* Need to be careful with SvREFCNT_dec(), because that can have side
1683 * effects (due to closures). We must make sure that the new disposition
1684 * is in place before it is called.
1688 #ifdef HAS_SIGPROCMASK
1692 const char *s = MgPV_const(mg,len);
1694 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1697 if (memEQs(s, len, "__DIE__"))
1699 else if (memEQs(s, len, "__WARN__")
1700 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1701 /* Merge the existing behaviours, which are as follows:
1702 magic_setsig, we always set svp to &PL_warnhook
1703 (hence we always change the warnings handler)
1704 For magic_clearsig, we don't change the warnings handler if it's
1705 set to the &PL_warnhook. */
1708 SV *tmp = sv_newmortal();
1709 Perl_croak(aTHX_ "No such hook: %s",
1710 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1714 if (*svp != PERL_WARNHOOK_FATAL)
1720 i = (I16)mg->mg_private;
1722 i = whichsig_pvn(s, len); /* ...no, a brick */
1723 mg->mg_private = (U16)i;
1727 SV *tmp = sv_newmortal();
1728 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1729 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1733 #ifdef HAS_SIGPROCMASK
1734 /* Avoid having the signal arrive at a bad time, if possible. */
1737 sigprocmask(SIG_BLOCK, &set, &save);
1739 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1740 SAVEFREESV(save_sv);
1741 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1744 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1745 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1747 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1748 PL_sig_ignoring[i] = 0;
1750 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1751 PL_sig_defaulting[i] = 0;
1753 to_dec = PL_psig_ptr[i];
1755 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1756 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1758 /* Signals don't change name during the program's execution, so once
1759 they're cached in the appropriate slot of PL_psig_name, they can
1762 Ideally we'd find some way of making SVs at (C) compile time, or
1763 at least, doing most of the work. */
1764 if (!PL_psig_name[i]) {
1765 PL_psig_name[i] = newSVpvn(s, len);
1766 SvREADONLY_on(PL_psig_name[i]);
1769 SvREFCNT_dec(PL_psig_name[i]);
1770 PL_psig_name[i] = NULL;
1771 PL_psig_ptr[i] = NULL;
1774 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1776 (void)rsignal(i, PL_csighandlerp);
1779 *svp = SvREFCNT_inc_simple_NN(sv);
1781 if (sv && SvOK(sv)) {
1782 s = SvPV_force(sv, len);
1786 if (sv && memEQs(s, len,"IGNORE")) {
1788 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1789 PL_sig_ignoring[i] = 1;
1790 (void)rsignal(i, PL_csighandlerp);
1792 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1796 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1798 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1799 PL_sig_defaulting[i] = 1;
1800 (void)rsignal(i, PL_csighandlerp);
1802 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1808 * We should warn if HINT_STRICT_REFS, but without
1809 * access to a known hint bit in a known OP, we can't
1810 * tell whether HINT_STRICT_REFS is in force or not.
1812 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1813 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1816 (void)rsignal(i, PL_csighandlerp);
1818 *svp = SvREFCNT_inc_simple_NN(sv);
1822 #ifdef HAS_SIGPROCMASK
1826 SvREFCNT_dec(to_dec);
1829 #endif /* !PERL_MICRO */
1832 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1834 PERL_ARGS_ASSERT_MAGIC_SETISA;
1835 PERL_UNUSED_ARG(sv);
1837 /* Skip _isaelem because _isa will handle it shortly */
1838 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1841 return magic_clearisa(NULL, mg);
1844 /* sv of NULL signifies that we're acting as magic_setisa. */
1846 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1849 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1851 /* Bail out if destruction is going on */
1852 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1855 av_clear(MUTABLE_AV(sv));
1857 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1858 /* This occurs with setisa_elem magic, which calls this
1860 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1863 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1864 SV **svp = AvARRAY((AV *)mg->mg_obj);
1865 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1867 stash = GvSTASH((GV *)*svp++);
1868 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1875 (const GV *)mg->mg_obj
1878 /* The stash may have been detached from the symbol table, so check its
1879 name before doing anything. */
1880 if (stash && HvENAME_get(stash))
1881 mro_isa_changed_in(stash);
1887 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1889 HV * const hv = MUTABLE_HV(LvTARG(sv));
1892 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1893 PERL_UNUSED_ARG(mg);
1896 (void) hv_iterinit(hv);
1897 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1900 while (hv_iternext(hv))
1905 sv_setiv(sv, (IV)i);
1910 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1912 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1913 PERL_UNUSED_ARG(mg);
1915 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1921 =for apidoc magic_methcall
1923 Invoke a magic method (like FETCH).
1925 C<sv> and C<mg> are the tied thingy and the tie magic.
1927 C<meth> is the name of the method to call.
1929 C<argc> is the number of args (in addition to $self) to pass to the method.
1931 The C<flags> can be:
1933 G_DISCARD invoke method with G_DISCARD flag and don't
1935 G_UNDEF_FILL fill the stack with argc pointers to
1938 The arguments themselves are any values following the C<flags> argument.
1940 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1947 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1953 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1957 if (flags & G_WRITING_TO_STDERR) {
1961 SAVESPTR(PL_stderrgv);
1965 PUSHSTACKi(PERLSI_MAGIC);
1968 /* EXTEND() expects a signed argc; don't wrap when casting */
1969 assert(argc <= I32_MAX);
1970 EXTEND(SP, (I32)argc+1);
1971 PUSHs(SvTIED_obj(sv, mg));
1972 if (flags & G_UNDEF_FILL) {
1974 PUSHs(&PL_sv_undef);
1976 } else if (argc > 0) {
1978 va_start(args, argc);
1981 SV *const this_sv = va_arg(args, SV *);
1988 if (flags & G_DISCARD) {
1989 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1992 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1993 ret = *PL_stack_sp--;
1996 if (flags & G_WRITING_TO_STDERR)
2002 /* wrapper for magic_methcall that creates the first arg */
2005 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2010 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2013 if (mg->mg_len >= 0) {
2014 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2016 else if (mg->mg_len == HEf_SVKEY)
2017 arg1 = MUTABLE_SV(mg->mg_ptr);
2019 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2020 arg1 = newSViv((IV)(mg->mg_len));
2024 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2026 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2030 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2034 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2036 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2043 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2045 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2047 if (mg->mg_type == PERL_MAGIC_tiedelem)
2048 mg->mg_flags |= MGf_GSKIP;
2049 magic_methpack(sv,mg,SV_CONST(FETCH));
2054 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2059 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2061 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2062 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2063 * public flags indicate its value based on copying from $val. Doing
2064 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2065 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2066 * wrong if $val happened to be tainted, as sv hasn't got magic
2067 * enabled, even though taint magic is in the chain. In which case,
2068 * fake up a temporary tainted value (this is easier than temporarily
2069 * re-enabling magic on sv). */
2071 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2072 && (tmg->mg_len & 1))
2074 val = sv_mortalcopy(sv);
2080 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2085 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2087 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2089 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2090 return magic_methpack(sv,mg,SV_CONST(DELETE));
2095 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2102 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2104 retval = SvIV(retsv)-1;
2106 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2108 return (U32) retval;
2112 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2114 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2116 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2121 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2125 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2127 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2128 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2135 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2137 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2139 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2143 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2146 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2147 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2149 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2151 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2153 if (HvEITER_get(hv))
2154 /* we are in an iteration so the hash cannot be empty */
2156 /* no xhv_eiter so now use FIRSTKEY */
2157 key = sv_newmortal();
2158 magic_nextpack(MUTABLE_SV(hv), mg, key);
2159 HvEITER_set(hv, NULL); /* need to reset iterator */
2160 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2163 /* there is a SCALAR method that we can call */
2164 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2166 retval = &PL_sv_undef;
2171 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2175 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2177 /* The magic ptr/len for the debugger's hash should always be an SV. */
2178 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2179 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2180 (IV)mg->mg_len, mg->mg_ptr);
2183 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2184 setting/clearing debugger breakpoints is not a hot path. */
2185 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2186 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2188 if (svp && SvIOKp(*svp)) {
2189 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2191 #ifdef PERL_DEBUG_READONLY_OPS
2192 Slab_to_rw(OpSLAB(o));
2194 /* set or clear breakpoint in the relevant control op */
2196 o->op_flags |= OPf_SPECIAL;
2198 o->op_flags &= ~OPf_SPECIAL;
2199 #ifdef PERL_DEBUG_READONLY_OPS
2200 Slab_to_ro(OpSLAB(o));
2208 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2210 AV * const obj = MUTABLE_AV(mg->mg_obj);
2212 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2215 sv_setiv(sv, AvFILL(obj));
2223 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2225 AV * const obj = MUTABLE_AV(mg->mg_obj);
2227 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2230 av_fill(obj, SvIV(sv));
2232 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2233 "Attempt to set length of freed array");
2239 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2241 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2242 PERL_UNUSED_ARG(sv);
2243 PERL_UNUSED_CONTEXT;
2245 /* Reset the iterator when the array is cleared */
2246 if (sizeof(IV) == sizeof(SSize_t)) {
2247 *((IV *) &(mg->mg_len)) = 0;
2250 *((IV *) mg->mg_ptr) = 0;
2257 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2259 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2260 PERL_UNUSED_ARG(sv);
2262 /* during global destruction, mg_obj may already have been freed */
2263 if (PL_in_clean_all)
2266 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2269 /* arylen scalar holds a pointer back to the array, but doesn't own a
2270 reference. Hence the we (the array) are about to go away with it
2271 still pointing at us. Clear its pointer, else it would be pointing
2272 at free memory. See the comment in sv_magic about reference loops,
2273 and why it can't own a reference to us. */
2280 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2282 SV* const lsv = LvTARG(sv);
2283 MAGIC * const found = mg_find_mglob(lsv);
2285 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2286 PERL_UNUSED_ARG(mg);
2288 if (found && found->mg_len != -1) {
2289 STRLEN i = found->mg_len;
2290 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2291 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2300 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2302 SV* const lsv = LvTARG(sv);
2308 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2309 PERL_UNUSED_ARG(mg);
2311 found = mg_find_mglob(lsv);
2315 found = sv_magicext_mglob(lsv);
2317 else if (!SvOK(sv)) {
2321 s = SvPV_const(lsv, len);
2326 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2336 else if (pos > (SSize_t)len)
2339 found->mg_len = pos;
2340 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2346 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2349 SV * const lsv = LvTARG(sv);
2350 const char * const tmps = SvPV_const(lsv,len);
2351 STRLEN offs = LvTARGOFF(sv);
2352 STRLEN rem = LvTARGLEN(sv);
2353 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2354 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2356 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2357 PERL_UNUSED_ARG(mg);
2359 if (!translate_substr_offsets(
2360 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2361 negoff ? -(IV)offs : (IV)offs, !negoff,
2362 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2364 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2370 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2371 sv_setpvn(sv, tmps + offs, rem);
2378 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2380 STRLEN len, lsv_len, oldtarglen, newtarglen;
2381 const char * const tmps = SvPV_const(sv, len);
2382 SV * const lsv = LvTARG(sv);
2383 STRLEN lvoff = LvTARGOFF(sv);
2384 STRLEN lvlen = LvTARGLEN(sv);
2385 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2386 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2388 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2389 PERL_UNUSED_ARG(mg);
2393 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2394 "Attempt to use reference as lvalue in substr"
2396 SvPV_force_nomg(lsv,lsv_len);
2397 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2398 if (!translate_substr_offsets(
2400 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2401 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2403 Perl_croak(aTHX_ "substr outside of string");
2406 sv_utf8_upgrade_nomg(lsv);
2407 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2408 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2409 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2412 else if (SvUTF8(lsv)) {
2414 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2416 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2417 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2421 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2424 if (!neglen) LvTARGLEN(sv) = newtarglen;
2425 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2431 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2433 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2434 PERL_UNUSED_ARG(sv);
2435 #ifdef NO_TAINT_SUPPORT
2436 PERL_UNUSED_ARG(mg);
2439 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2444 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2446 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2447 PERL_UNUSED_ARG(sv);
2449 /* update taint status */
2458 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2460 SV * const lsv = LvTARG(sv);
2461 char errflags = LvFLAGS(sv);
2463 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2464 PERL_UNUSED_ARG(mg);
2466 /* non-zero errflags implies deferred out-of-range condition */
2467 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2468 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2474 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2476 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2477 PERL_UNUSED_ARG(mg);
2478 do_vecset(sv); /* XXX slurp this routine */
2483 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2486 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2487 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2489 if (LvTARGLEN(sv)) {
2491 SV * const ahv = LvTARG(sv);
2492 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2496 else if (LvSTARGOFF(sv) >= 0) {
2497 AV *const av = MUTABLE_AV(LvTARG(sv));
2498 if (LvSTARGOFF(sv) <= AvFILL(av))
2500 if (SvRMAGICAL(av)) {
2501 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2502 targ = svp ? *svp : NULL;
2505 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2508 if (targ && (targ != &PL_sv_undef)) {
2509 /* somebody else defined it for us */
2510 SvREFCNT_dec(LvTARG(sv));
2511 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2513 SvREFCNT_dec(mg->mg_obj);
2515 mg->mg_flags &= ~MGf_REFCOUNTED;
2524 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2526 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2528 sv_setsv(sv, defelem_target(sv, mg));
2533 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2535 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2536 PERL_UNUSED_ARG(mg);
2540 sv_setsv(LvTARG(sv), sv);
2541 SvSETMAGIC(LvTARG(sv));
2547 Perl_vivify_defelem(pTHX_ SV *sv)
2552 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2554 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2557 SV * const ahv = LvTARG(sv);
2558 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2561 if (!value || value == &PL_sv_undef)
2562 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2564 else if (LvSTARGOFF(sv) < 0)
2565 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2567 AV *const av = MUTABLE_AV(LvTARG(sv));
2568 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2569 LvTARG(sv) = NULL; /* array can't be extended */
2571 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2572 if (!svp || !(value = *svp))
2573 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2576 SvREFCNT_inc_simple_void(value);
2577 SvREFCNT_dec(LvTARG(sv));
2580 SvREFCNT_dec(mg->mg_obj);
2582 mg->mg_flags &= ~MGf_REFCOUNTED;
2586 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2588 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2589 PERL_UNUSED_ARG(mg);
2590 sv_unmagic(sv, PERL_MAGIC_nonelem);
2595 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2597 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2598 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2603 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2605 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2606 PERL_UNUSED_CONTEXT;
2607 PERL_UNUSED_ARG(sv);
2613 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2615 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2617 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2619 if (uf && uf->uf_set)
2620 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2625 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2627 const char type = mg->mg_type;
2629 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2631 assert( type == PERL_MAGIC_fm
2632 || type == PERL_MAGIC_qr
2633 || type == PERL_MAGIC_bm);
2634 return sv_unmagic(sv, type);
2637 #ifdef USE_LOCALE_COLLATE
2639 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2641 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2644 * RenE<eacute> Descartes said "I think not."
2645 * and vanished with a faint plop.
2647 PERL_UNUSED_CONTEXT;
2648 PERL_UNUSED_ARG(sv);
2650 Safefree(mg->mg_ptr);
2656 #endif /* USE_LOCALE_COLLATE */
2658 /* Just clear the UTF-8 cache data. */
2660 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2662 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2663 PERL_UNUSED_CONTEXT;
2664 PERL_UNUSED_ARG(sv);
2665 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2667 mg->mg_len = -1; /* The mg_len holds the len cache. */
2672 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2674 const char *bad = NULL;
2675 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2676 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2677 switch (mg->mg_private & OPpLVREF_TYPE) {
2679 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2683 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2687 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2691 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2695 /* diag_listed_as: Assigned value is not %s reference */
2696 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2697 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2700 SV * const old = PAD_SV(mg->mg_len);
2701 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2706 gv_setref(mg->mg_obj, sv);
2707 SvSETMAGIC(mg->mg_obj);
2710 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2711 SvREFCNT_inc_simple_NN(SvRV(sv)));
2714 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2715 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2717 if (mg->mg_flags & MGf_PERSIST)
2718 NOOP; /* This sv is in use as an iterator var and will be reused,
2719 so we must leave the magic. */
2721 /* This sv could be returned by the assignment op, so clear the
2722 magic, as lvrefs are an implementation detail that must not be
2723 leaked to the user. */
2724 sv_unmagic(sv, PERL_MAGIC_lvref);
2729 S_set_dollarzero(pTHX_ SV *sv)
2730 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2737 #ifdef HAS_SETPROCTITLE
2738 /* The BSDs don't show the argv[] in ps(1) output, they
2739 * show a string from the process struct and provide
2740 * the setproctitle() routine to manipulate that. */
2741 if (PL_origalen != 1) {
2742 s = SvPV_const(sv, len);
2743 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2744 /* The leading "-" removes the "perl: " prefix,
2745 * but not the "(perl) suffix from the ps(1)
2746 * output, because that's what ps(1) shows if the
2747 * argv[] is modified. */
2748 setproctitle("-%s", s);
2749 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2750 /* This doesn't really work if you assume that
2751 * $0 = 'foobar'; will wipe out 'perl' from the $0
2752 * because in ps(1) output the result will be like
2753 * sprintf("perl: %s (perl)", s)
2754 * I guess this is a security feature:
2755 * one (a user process) cannot get rid of the original name.
2757 setproctitle("%s", s);
2760 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2761 if (PL_origalen != 1) {
2763 s = SvPV_const(sv, len);
2764 un.pst_command = (char *)s;
2765 pstat(PSTAT_SETCMD, un, len, 0, 0);
2768 if (PL_origalen > 1) {
2770 /* PL_origalen is set in perl_parse(). */
2771 s = SvPV_force(sv,len);
2772 if (len >= (STRLEN)PL_origalen-1) {
2773 /* Longer than original, will be truncated. We assume that
2774 * PL_origalen bytes are available. */
2775 Copy(s, PL_origargv[0], PL_origalen-1, char);
2778 /* Shorter than original, will be padded. */
2780 /* Special case for Mac OS X: see [perl #38868] */
2783 /* Is the space counterintuitive? Yes.
2784 * (You were expecting \0?)
2785 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2787 const int pad = ' ';
2789 Copy(s, PL_origargv[0], len, char);
2790 PL_origargv[0][len] = 0;
2791 memset(PL_origargv[0] + len + 1,
2792 pad, PL_origalen - len - 1);
2794 PL_origargv[0][PL_origalen-1] = 0;
2795 for (i = 1; i < PL_origargc; i++)
2797 #ifdef HAS_PRCTL_SET_NAME
2798 /* Set the legacy process name in addition to the POSIX name on Linux */
2799 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2800 /* diag_listed_as: SKIPME */
2801 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2809 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2820 PERL_ARGS_ASSERT_MAGIC_SET;
2824 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2826 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2828 /* Croak with a READONLY error when a numbered match var is
2829 * set without a previous pattern match. Unless it's C<local $1>
2832 if (!PL_localizing) {
2833 Perl_croak_no_modify();
2839 switch (*mg->mg_ptr) {
2840 case '\001': /* ^A */
2841 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2842 else SvOK_off(PL_bodytarget);
2843 FmLINES(PL_bodytarget) = 0;
2844 if (SvPOK(PL_bodytarget)) {
2845 char *s = SvPVX(PL_bodytarget);
2846 char *e = SvEND(PL_bodytarget);
2847 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2848 FmLINES(PL_bodytarget)++;
2852 /* mg_set() has temporarily made sv non-magical */
2854 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2855 SvTAINTED_on(PL_bodytarget);
2857 SvTAINTED_off(PL_bodytarget);
2860 case '\003': /* ^C */
2861 PL_minus_c = cBOOL(SvIV(sv));
2864 case '\004': /* ^D */
2867 const char *s = SvPV_nolen_const(sv);
2868 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2869 if (DEBUG_x_TEST || DEBUG_B_TEST)
2870 dump_all_perl(!DEBUG_B_TEST);
2873 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2876 case '\005': /* ^E */
2877 if (*(mg->mg_ptr+1) == '\0') {
2879 set_vaxc_errno(SvIV(sv));
2880 #elif defined(WIN32)
2881 SetLastError( SvIV(sv) );
2883 os2_setsyserrno(SvIV(sv));
2885 /* will anyone ever use this? */
2886 SETERRNO(SvIV(sv), 4);
2889 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2890 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2892 case '\006': /* ^F */
2893 if (mg->mg_ptr[1] == '\0') {
2894 PL_maxsysfd = SvIV(sv);
2896 else if (strEQ(mg->mg_ptr + 1, "EATURE_BITS")) {
2897 PL_compiling.cop_features = SvUV(sv);
2900 case '\010': /* ^H */
2902 U32 save_hints = PL_hints;
2903 PL_hints = SvUV(sv);
2905 /* If wasn't UTF-8, and now is, notify the parser */
2906 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2907 notify_parser_that_changed_to_utf8();
2911 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2912 Safefree(PL_inplace);
2913 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2915 case '\016': /* ^N */
2916 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2917 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2919 case '\017': /* ^O */
2920 if (*(mg->mg_ptr+1) == '\0') {
2921 Safefree(PL_osname);
2924 TAINT_PROPER("assigning to $^O");
2925 PL_osname = savesvpv(sv);
2928 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2930 const char *const start = SvPV(sv, len);
2931 const char *out = (const char*)memchr(start, '\0', len);
2935 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2936 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2938 /* Opening for input is more common than opening for output, so
2939 ensure that hints for input are sooner on linked list. */
2940 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2942 : newSVpvs_flags("", SvUTF8(sv));
2943 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2946 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2948 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2952 case '\020': /* ^P */
2953 PL_perldb = SvIV(sv);
2954 if (PL_perldb && !PL_DBsingle)
2957 case '\024': /* ^T */
2959 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2961 PL_basetime = (Time_t)SvIV(sv);
2964 case '\025': /* ^UTF8CACHE */
2965 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2966 PL_utf8cache = (signed char) sv_2iv(sv);
2969 case '\027': /* ^W & $^WARNING_BITS */
2970 if (*(mg->mg_ptr+1) == '\0') {
2971 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2973 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2974 | (i ? G_WARN_ON : G_WARN_OFF) ;
2977 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2978 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2980 if (!specialWARN(PL_compiling.cop_warnings))
2981 PerlMemShared_free(PL_compiling.cop_warnings);
2982 PL_compiling.cop_warnings = pWARN_STD;
2987 int not_none = 0, not_all = 0;
2988 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2989 for (i = 0 ; i < len ; ++i) {
2991 not_all |= ptr[i] ^ 0x55;
2994 if (!specialWARN(PL_compiling.cop_warnings))
2995 PerlMemShared_free(PL_compiling.cop_warnings);
2996 PL_compiling.cop_warnings = pWARN_NONE;
2997 } else if (len >= WARNsize && !not_all) {
2998 if (!specialWARN(PL_compiling.cop_warnings))
2999 PerlMemShared_free(PL_compiling.cop_warnings);
3000 PL_compiling.cop_warnings = pWARN_ALL;
3001 PL_dowarn |= G_WARN_ONCE ;
3005 const char *const p = SvPV_const(sv, len);
3007 PL_compiling.cop_warnings
3008 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3011 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3012 PL_dowarn |= G_WARN_ONCE ;
3019 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
3020 w32_sloppystat = (bool)sv_true(sv);
3025 if (PL_localizing) {
3026 if (PL_localizing == 1)
3027 SAVESPTR(PL_last_in_gv);
3029 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3030 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3033 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
3034 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3035 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3038 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
3039 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3040 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3043 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3046 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3047 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3048 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3051 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3055 IO * const io = GvIO(PL_defoutgv);
3058 if ((SvIV(sv)) == 0)
3059 IoFLAGS(io) &= ~IOf_FLUSH;
3061 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3062 PerlIO *ofp = IoOFP(io);
3064 (void)PerlIO_flush(ofp);
3065 IoFLAGS(io) |= IOf_FLUSH;
3073 SV *referent = SvRV(sv);
3074 const char *reftype = sv_reftype(referent, 0);
3075 /* XXX: dodgy type check: This leaves me feeling dirty, but
3076 * the alternative is to copy pretty much the entire
3077 * sv_reftype() into this routine, or to do a full string
3078 * comparison on the return of sv_reftype() both of which
3079 * make me feel worse! NOTE, do not modify this comment
3080 * without reviewing the corresponding comment in
3081 * sv_reftype(). - Yves */
3082 if (reftype[0] == 'S' || reftype[0] == 'L') {
3083 IV val = SvIV(referent);
3085 sv_setsv(sv, PL_rs);
3086 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3087 val < 0 ? "a negative integer" : "zero");
3090 sv_setsv(sv, PL_rs);
3091 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3092 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3093 *reftype == 'A' ? "n" : "", reftype);
3096 SvREFCNT_dec(PL_rs);
3097 PL_rs = newSVsv(sv);
3101 SvREFCNT_dec(PL_ors_sv);
3103 PL_ors_sv = newSVsv(sv);
3111 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3114 #ifdef COMPLEX_STATUS
3115 if (PL_localizing == 2) {
3116 SvUPGRADE(sv, SVt_PVLV);
3117 PL_statusvalue = LvTARGOFF(sv);
3118 PL_statusvalue_vms = LvTARGLEN(sv);
3122 #ifdef VMSISH_STATUS
3124 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3127 STATUS_UNIX_EXIT_SET(SvIV(sv));
3132 # define PERL_VMS_BANG vaxc$errno
3134 # define PERL_VMS_BANG 0
3137 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3138 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3140 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3141 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3147 /* XXX $< currently silently ignores failures */
3148 const Uid_t new_uid = SvUID(sv);
3149 PL_delaymagic_uid = new_uid;
3150 if (PL_delaymagic) {
3151 PL_delaymagic |= DM_RUID;
3152 break; /* don't do magic till later */
3155 PERL_UNUSED_RESULT(setruid(new_uid));
3156 #elif defined(HAS_SETREUID)
3157 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3158 #elif defined(HAS_SETRESUID)
3159 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3161 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3163 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3164 if (new_uid != 0 && PerlProc_getuid() == 0)
3165 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3167 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3169 Perl_croak(aTHX_ "setruid() not implemented");
3176 /* XXX $> currently silently ignores failures */
3177 const Uid_t new_euid = SvUID(sv);
3178 PL_delaymagic_euid = new_euid;
3179 if (PL_delaymagic) {
3180 PL_delaymagic |= DM_EUID;
3181 break; /* don't do magic till later */
3184 PERL_UNUSED_RESULT(seteuid(new_euid));
3185 #elif defined(HAS_SETREUID)
3186 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3187 #elif defined(HAS_SETRESUID)
3188 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3190 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3191 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3193 Perl_croak(aTHX_ "seteuid() not implemented");
3200 /* XXX $( currently silently ignores failures */
3201 const Gid_t new_gid = SvGID(sv);
3202 PL_delaymagic_gid = new_gid;
3203 if (PL_delaymagic) {
3204 PL_delaymagic |= DM_RGID;
3205 break; /* don't do magic till later */
3208 PERL_UNUSED_RESULT(setrgid(new_gid));
3209 #elif defined(HAS_SETREGID)
3210 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3211 #elif defined(HAS_SETRESGID)
3212 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3214 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3215 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3217 Perl_croak(aTHX_ "setrgid() not implemented");
3224 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3225 * but you can override it if you need to.
3228 #define INVALID_GID ((Gid_t)-1)
3230 /* XXX $) currently silently ignores failures */
3232 #ifdef HAS_SETGROUPS
3234 const char *p = SvPV_const(sv, len);
3235 Groups_t *gary = NULL;
3236 const char* p_end = p + len;
3237 const char* endptr = p_end;
3239 #ifdef _SC_NGROUPS_MAX
3240 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3245 int maxgrp = NGROUPS;
3250 if (grok_atoUV(p, &uv, &endptr))
3251 new_egid = (Gid_t)uv;
3253 new_egid = INVALID_GID;
3256 for (i = 0; i < maxgrp; ++i) {
3266 Newx(gary, i + 1, Groups_t);
3268 Renew(gary, i + 1, Groups_t);
3269 if (grok_atoUV(p, &uv, &endptr))
3270 gary[i] = (Groups_t)uv;
3272 gary[i] = INVALID_GID;
3277 PERL_UNUSED_RESULT(setgroups(i, gary));
3280 #else /* HAS_SETGROUPS */
3281 new_egid = SvGID(sv);
3282 #endif /* HAS_SETGROUPS */
3283 PL_delaymagic_egid = new_egid;
3284 if (PL_delaymagic) {
3285 PL_delaymagic |= DM_EGID;
3286 break; /* don't do magic till later */
3289 PERL_UNUSED_RESULT(setegid(new_egid));
3290 #elif defined(HAS_SETREGID)
3291 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3292 #elif defined(HAS_SETRESGID)
3293 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3295 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3296 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3298 Perl_croak(aTHX_ "setegid() not implemented");
3304 PL_chopset = SvPV_force(sv,len);
3307 /* Store the pid in mg->mg_obj so we can tell when a fork has
3308 occurred. mg->mg_obj points to *$ by default, so clear it. */
3309 if (isGV(mg->mg_obj)) {
3310 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3311 SvREFCNT_dec(mg->mg_obj);
3312 mg->mg_flags |= MGf_REFCOUNTED;
3313 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3315 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3318 LOCK_DOLLARZERO_MUTEX;
3319 S_set_dollarzero(aTHX_ sv);
3320 UNLOCK_DOLLARZERO_MUTEX;
3327 Perl_whichsig_sv(pTHX_ SV *sigsv)
3331 PERL_ARGS_ASSERT_WHICHSIG_SV;
3332 sigpv = SvPV_const(sigsv, siglen);
3333 return whichsig_pvn(sigpv, siglen);
3337 Perl_whichsig_pv(pTHX_ const char *sig)
3339 PERL_ARGS_ASSERT_WHICHSIG_PV;
3340 return whichsig_pvn(sig, strlen(sig));
3344 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3348 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3349 PERL_UNUSED_CONTEXT;
3351 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3352 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3353 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3355 if (memEQs(sig, len, "CHLD"))
3359 if (memEQs(sig, len, "CLD"))
3366 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3367 * these three function are intended to be called by the OS as 'C' level
3368 * signal handler functions in the case where unsafe signals are being
3369 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3370 * perl-level sighandler, rather than deferring.
3371 * In fact, the core itself will normally use Perl_csighandler as the
3372 * OS-level handler; that function will then decide whether to queue the
3373 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3374 * functions are more useful for e.g. POSIX.xs when it wants explicit
3375 * control of what's happening.
3379 #ifdef PERL_USE_3ARG_SIGHANDLER
3382 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3384 Perl_perly_sighandler(sig, sip, uap, 0);
3390 Perl_sighandler(int sig)
3392 Perl_perly_sighandler(sig, NULL, NULL, 0);
3398 Perl_sighandler1(int sig)
3400 Perl_perly_sighandler(sig, NULL, NULL, 0);
3404 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3406 Perl_perly_sighandler(sig, sip, uap, 0);
3410 /* Invoke the perl-level signal handler. This function is called either
3411 * directly from one of the C-level signals handlers (Perl_sighandler or
3412 * Perl_csighandler), or for safe signals, later from
3413 * Perl_despatch_signals() at a suitable safe point during execution.
3415 * 'safe' is a boolean indicating the latter call path.
3419 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3420 void *uap PERL_UNUSED_DECL, bool safe)
3422 #ifdef PERL_GET_SIG_CONTEXT
3423 dTHXa(PERL_GET_SIG_CONTEXT);
3430 SV * const tSv = PL_Sv;
3434 XPV * const tXpv = PL_Xpv;
3435 I32 old_ss_ix = PL_savestack_ix;
3436 SV *errsv_save = NULL;
3439 if (!PL_psig_ptr[sig]) {
3440 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3445 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3446 /* Max number of items pushed there is 3*n or 4. We cannot fix
3447 infinity, so we fix 4 (in fact 5): */
3448 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3450 PL_savestack_ix += 5; /* Protect save in progress. */
3451 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3454 /* sv_2cv is too complicated, try a simpler variant first: */
3455 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3456 || SvTYPE(cv) != SVt_PVCV) {
3458 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3461 if (!cv || !CvROOT(cv)) {
3462 const HEK * const hek = gv
3466 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3468 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3469 "SIG%s handler \"%" HEKf "\" not defined.\n",
3470 PL_sig_name[sig], HEKfARG(hek));
3471 /* diag_listed_as: SIG%s handler "%s" not defined */
3472 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3473 "SIG%s handler \"__ANON__\" not defined.\n",
3478 sv = PL_psig_name[sig]
3479 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3480 : newSVpv(PL_sig_name[sig],0);
3484 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3485 /* make sure our assumption about the size of the SAVEs are correct:
3486 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3487 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3490 PUSHSTACKi(PERLSI_SIGNAL);
3493 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3495 struct sigaction oact;
3497 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3500 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3501 /* The siginfo fields signo, code, errno, pid, uid,
3502 * addr, status, and band are defined by POSIX/SUSv3. */
3503 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3504 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3505 #ifdef HAS_SIGINFO_SI_ERRNO
3506 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3508 #ifdef HAS_SIGINFO_SI_STATUS
3509 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3511 #ifdef HAS_SIGINFO_SI_UID
3514 sv_setuid(uid, sip->si_uid);
3515 (void)hv_stores(sih, "uid", uid);
3518 #ifdef HAS_SIGINFO_SI_PID
3519 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3521 #ifdef HAS_SIGINFO_SI_ADDR
3522 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3524 #ifdef HAS_SIGINFO_SI_BAND
3525 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3529 mPUSHp((char *)sip, sizeof(*sip));
3537 errsv_save = newSVsv(ERRSV);
3539 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3543 SV * const errsv = ERRSV;
3544 if (SvTRUE_NN(errsv)) {
3545 SvREFCNT_dec(errsv_save);
3547 /* Handler "died", for example to get out of a restart-able read().
3548 * Before we re-do that on its behalf re-enable the signal which was
3549 * blocked by the system when we entered.
3551 #ifdef HAS_SIGPROCMASK
3553 /* safe signals called via dispatch_signals() set up a
3554 * savestack destructor, unblock_sigmask(), to
3555 * automatically unblock the handler at the end. If
3556 * instead we get here directly, we have to do it
3561 sigaddset(&set,sig);
3562 sigprocmask(SIG_UNBLOCK, &set, NULL);
3565 /* Not clear if this will work */
3566 /* XXX not clear if this should be protected by 'if (safe)'
3569 (void)rsignal(sig, SIG_IGN);
3570 (void)rsignal(sig, PL_csighandlerp);
3572 #endif /* !PERL_MICRO */
3576 sv_setsv(errsv, errsv_save);
3577 SvREFCNT_dec(errsv_save);
3582 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3583 PL_savestack_ix = old_ss_ix;
3585 SvREFCNT_dec_NN(sv);
3586 PL_op = myop; /* Apparently not needed... */
3588 PL_Sv = tSv; /* Restore global temporaries. */
3595 S_restore_magic(pTHX_ const void *p)
3597 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3598 SV* const sv = mgs->mgs_sv;
3604 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3605 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3607 SvFLAGS(sv) |= mgs->mgs_flags;
3612 bumped = mgs->mgs_bumped;
3613 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3615 /* If we're still on top of the stack, pop us off. (That condition
3616 * will be satisfied if restore_magic was called explicitly, but *not*
3617 * if it's being called via leave_scope.)
3618 * The reason for doing this is that otherwise, things like sv_2cv()
3619 * may leave alloc gunk on the savestack, and some code
3620 * (e.g. sighandler) doesn't expect that...
3622 if (PL_savestack_ix == mgs->mgs_ss_ix)
3624 UV popval = SSPOPUV;
3625 assert(popval == SAVEt_DESTRUCTOR_X);
3626 PL_savestack_ix -= 2;
3628 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3629 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3632 if (SvREFCNT(sv) == 1) {
3633 /* We hold the last reference to this SV, which implies that the
3634 SV was deleted as a side effect of the routines we called.
3635 So artificially keep it alive a bit longer.
3636 We avoid turning on the TEMP flag, which can cause the SV's
3637 buffer to get stolen (and maybe other stuff). */
3642 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3646 /* clean up the mess created by Perl_sighandler().
3647 * Note that this is only called during an exit in a signal handler;
3648 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3652 S_unwind_handler_stack(pTHX_ const void *p)
3656 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3660 =for apidoc magic_sethint
3662 Triggered by a store to C<%^H>, records the key/value pair to
3663 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3664 anything that would need a deep copy. Maybe we should warn if we find a
3670 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3672 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3673 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3675 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3677 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3678 an alternative leaf in there, with PL_compiling.cop_hints being used if
3679 it's NULL. If needed for threads, the alternative could lock a mutex,
3680 or take other more complex action. */
3682 /* Something changed in %^H, so it will need to be restored on scope exit.
3683 Doing this here saves a lot of doing it manually in perl code (and
3684 forgetting to do it, and consequent subtle errors. */
3685 PL_hints |= HINT_LOCALIZE_HH;
3686 CopHINTHASH_set(&PL_compiling,
3687 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3692 =for apidoc magic_clearhint
3694 Triggered by a delete from C<%^H>, records the key to
3695 C<PL_compiling.cop_hints_hash>.
3700 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3702 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3703 PERL_UNUSED_ARG(sv);
3705 PL_hints |= HINT_LOCALIZE_HH;
3706 CopHINTHASH_set(&PL_compiling,
3707 mg->mg_len == HEf_SVKEY
3708 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3709 MUTABLE_SV(mg->mg_ptr), 0, 0)
3710 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3711 mg->mg_ptr, mg->mg_len, 0, 0));
3716 =for apidoc magic_clearhints
3718 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3723 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3725 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3726 PERL_UNUSED_ARG(sv);
3727 PERL_UNUSED_ARG(mg);
3728 cophh_free(CopHINTHASH_get(&PL_compiling));
3729 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3734 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3735 const char *name, I32 namlen)
3739 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3740 PERL_UNUSED_ARG(sv);
3741 PERL_UNUSED_ARG(name);
3742 PERL_UNUSED_ARG(namlen);
3744 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3745 nmg = mg_find(nsv, mg->mg_type);
3747 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3748 nmg->mg_ptr = mg->mg_ptr;
3749 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3750 nmg->mg_flags |= MGf_REFCOUNTED;
3755 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3756 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3758 #if DBVARMG_SINGLE != 0
3759 assert(mg->mg_private >= DBVARMG_SINGLE);
3761 assert(mg->mg_private < DBVARMG_COUNT);
3763 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3769 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3770 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3772 #if DBVARMG_SINGLE != 0
3773 assert(mg->mg_private >= DBVARMG_SINGLE);
3775 assert(mg->mg_private < DBVARMG_COUNT);
3776 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3782 * ex: set ts=8 sts=4 sw=4 et: