3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
20 "Magic" is special data attached to SV structures in order to give them
21 "magical" properties. When any Perl code tries to read from, or assign to,
22 an SV marked as magical, it calls the 'get' or 'set' function associated
23 with that SV's magic. A get is called prior to reading an SV, in order to
24 give it a chance to update its internal value (get on $. writes the line
25 number of the last read filehandle into the SV's IV slot), while
26 set is called after an SV has been written to, in order to allow it to make
27 use of its changed value (set on $/ copies the SV's new value to the
28 PL_rs global variable).
30 Magic is implemented as a linked list of MAGIC structures attached to the
31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
32 of functions that implement the get(), set(), length() etc functions,
33 plus space for some flags and pointers. For example, a tied variable has
34 a MAGIC structure that contains a pointer to the object associated with the
45 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
51 #if defined(HAS_SETGROUPS)
58 # include <sys/pstat.h>
61 #ifdef HAS_PRCTL_SET_NAME
62 # include <sys/prctl.h>
65 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
66 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
68 Signal_t Perl_csighandler(int sig);
72 /* Missing protos on LynxOS */
73 void setruid(uid_t id);
74 void seteuid(uid_t id);
75 void setrgid(uid_t id);
76 void setegid(uid_t id);
80 * Pre-magic setup and post-magic takedown.
81 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
90 /* MGS is typedef'ed to struct magic_state in perl.h */
93 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
98 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
100 assert(SvMAGICAL(sv));
102 /* we shouldn't really be called here with RC==0, but it can sometimes
103 * happen via mg_clear() (which also shouldn't be called when RC==0,
104 * but it can happen). Handle this case gracefully(ish) by not RC++
105 * and thus avoiding the resultant double free */
106 if (SvREFCNT(sv) > 0) {
107 /* guard against sv getting freed midway through the mg clearing,
108 * by holding a private reference for the duration. */
109 SvREFCNT_inc_simple_void_NN(sv);
113 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
115 mgs = SSPTR(mgs_ix, MGS*);
117 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
118 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
119 mgs->mgs_bumped = bumped;
121 SvFLAGS(sv) &= ~flags;
125 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
128 =for apidoc mg_magical
130 Turns on the magical status of an SV. See C<L</sv_magic>>.
136 Perl_mg_magical(SV *sv)
139 PERL_ARGS_ASSERT_MG_MAGICAL;
142 if ((mg = SvMAGIC(sv))) {
144 const MGVTBL* const vtbl = mg->mg_virtual;
146 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
153 } while ((mg = mg->mg_moremagic));
154 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
162 Do magic before a value is retrieved from the SV. The type of SV must
163 be >= C<SVt_PVMG>. See C<L</sv_magic>>.
169 Perl_mg_get(pTHX_ SV *sv)
171 const I32 mgs_ix = SSNEW(sizeof(MGS));
174 bool taint_only = TRUE; /* the only get method seen is taint */
175 MAGIC *newmg, *head, *cur, *mg;
177 PERL_ARGS_ASSERT_MG_GET;
179 if (PL_localizing == 1 && sv == DEFSV) return 0;
181 /* We must call svt_get(sv, mg) for each valid entry in the linked
182 list of magic. svt_get() may delete the current entry, add new
183 magic to the head of the list, or upgrade the SV. AMS 20010810 */
185 newmg = cur = head = mg = SvMAGIC(sv);
187 const MGVTBL * const vtbl = mg->mg_virtual;
188 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
190 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
192 /* taint's mg get is so dumb it doesn't need flag saving */
193 if (mg->mg_type != PERL_MAGIC_taint) {
196 save_magic(mgs_ix, sv);
201 vtbl->svt_get(aTHX_ sv, mg);
203 /* guard against magic having been deleted - eg FETCH calling
206 /* recalculate flags */
207 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
211 /* recalculate flags if this entry was deleted. */
212 if (mg->mg_flags & MGf_GSKIP)
213 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
214 ~(SVs_GMG|SVs_SMG|SVs_RMG);
216 else if (vtbl == &PL_vtbl_utf8) {
217 /* get-magic can reallocate the PV, unless there's only taint
221 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
222 if ( mg2->mg_type != PERL_MAGIC_taint
223 && !(mg2->mg_flags & MGf_GSKIP)
225 && mg2->mg_virtual->svt_get
233 magic_setutf8(sv, mg);
239 /* Have we finished with the new entries we saw? Start again
240 where we left off (unless there are more new entries). */
248 /* Were any new entries added? */
249 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
253 /* recalculate flags */
254 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
259 restore_magic(INT2PTR(void *, (IV)mgs_ix));
267 Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
273 Perl_mg_set(pTHX_ SV *sv)
275 const I32 mgs_ix = SSNEW(sizeof(MGS));
279 PERL_ARGS_ASSERT_MG_SET;
281 if (PL_localizing == 2 && sv == DEFSV) return 0;
283 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
285 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
286 const MGVTBL* vtbl = mg->mg_virtual;
287 nextmg = mg->mg_moremagic; /* it may delete itself */
288 if (mg->mg_flags & MGf_GSKIP) {
289 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
290 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
292 if (PL_localizing == 2
293 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
295 if (vtbl && vtbl->svt_set)
296 vtbl->svt_set(aTHX_ sv, mg);
299 restore_magic(INT2PTR(void*, (IV)mgs_ix));
304 =for apidoc mg_length
306 Reports on the SV's length in bytes, calling length magic if available,
307 but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
308 magic if there is no 'length' magic, but with no indication as to
309 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
310 higher. Use C<sv_len()> instead.
316 Perl_mg_length(pTHX_ SV *sv)
321 PERL_ARGS_ASSERT_MG_LENGTH;
323 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
324 const MGVTBL * const vtbl = mg->mg_virtual;
325 if (vtbl && vtbl->svt_len) {
326 const I32 mgs_ix = SSNEW(sizeof(MGS));
327 save_magic(mgs_ix, sv);
328 /* omit MGf_GSKIP -- not changed here */
329 len = vtbl->svt_len(aTHX_ sv, mg);
330 restore_magic(INT2PTR(void*, (IV)mgs_ix));
335 (void)SvPV_const(sv, len);
340 Perl_mg_size(pTHX_ SV *sv)
344 PERL_ARGS_ASSERT_MG_SIZE;
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 const MGVTBL* const vtbl = mg->mg_virtual;
348 if (vtbl && vtbl->svt_len) {
349 const I32 mgs_ix = SSNEW(sizeof(MGS));
351 save_magic(mgs_ix, sv);
352 /* omit MGf_GSKIP -- not changed here */
353 len = vtbl->svt_len(aTHX_ sv, mg);
354 restore_magic(INT2PTR(void*, (IV)mgs_ix));
361 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
365 Perl_croak(aTHX_ "Size magic not implemented");
368 NOT_REACHED; /* NOTREACHED */
374 Clear something magical that the SV represents. See C<L</sv_magic>>.
380 Perl_mg_clear(pTHX_ SV *sv)
382 const I32 mgs_ix = SSNEW(sizeof(MGS));
386 PERL_ARGS_ASSERT_MG_CLEAR;
388 save_magic(mgs_ix, sv);
390 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
391 const MGVTBL* const vtbl = mg->mg_virtual;
392 /* omit GSKIP -- never set here */
394 nextmg = mg->mg_moremagic; /* it may delete itself */
396 if (vtbl && vtbl->svt_clear)
397 vtbl->svt_clear(aTHX_ sv, mg);
400 restore_magic(INT2PTR(void*, (IV)mgs_ix));
405 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
425 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
431 Perl_mg_find(const SV *sv, int type)
433 return S_mg_findext_flags(sv, type, NULL, 0);
437 =for apidoc mg_findext
439 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
446 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
448 return S_mg_findext_flags(sv, type, vtbl, 1);
452 Perl_mg_find_mglob(pTHX_ SV *sv)
454 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
455 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
456 /* This sv is only a delegate. //g magic must be attached to
461 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
462 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
469 Copies the magic from one SV to another. See C<L</sv_magic>>.
475 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
480 PERL_ARGS_ASSERT_MG_COPY;
482 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
483 const MGVTBL* const vtbl = mg->mg_virtual;
484 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
485 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
488 const char type = mg->mg_type;
489 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
491 (type == PERL_MAGIC_tied)
494 toLOWER(type), key, klen);
503 =for apidoc mg_localize
505 Copy some of the magic from an existing SV to new localized version of that
506 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
507 gets copied, value magic doesn't (I<e.g.>,
510 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
511 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
512 and that will handle the magic.
518 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
522 PERL_ARGS_ASSERT_MG_LOCALIZE;
527 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
528 const MGVTBL* const vtbl = mg->mg_virtual;
529 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
532 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
533 (void)vtbl->svt_local(aTHX_ nsv, mg);
535 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
536 mg->mg_ptr, mg->mg_len);
538 /* container types should remain read-only across localization */
539 SvFLAGS(nsv) |= SvREADONLY(sv);
542 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
543 SvFLAGS(nsv) |= SvMAGICAL(sv);
552 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
554 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
556 const MGVTBL* const vtbl = mg->mg_virtual;
557 if (vtbl && vtbl->svt_free)
558 vtbl->svt_free(aTHX_ sv, mg);
559 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
560 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
561 Safefree(mg->mg_ptr);
562 else if (mg->mg_len == HEf_SVKEY)
563 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
565 if (mg->mg_flags & MGf_REFCOUNTED)
566 SvREFCNT_dec(mg->mg_obj);
573 Free any magic storage used by the SV. See C<L</sv_magic>>.
579 Perl_mg_free(pTHX_ SV *sv)
584 PERL_ARGS_ASSERT_MG_FREE;
586 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
587 moremagic = mg->mg_moremagic;
588 mg_free_struct(sv, mg);
589 SvMAGIC_set(sv, moremagic);
591 SvMAGIC_set(sv, NULL);
597 =for apidoc Am|void|mg_free_type|SV *sv|int how
599 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
605 Perl_mg_free_type(pTHX_ SV *sv, int how)
607 MAGIC *mg, *prevmg, *moremg;
608 PERL_ARGS_ASSERT_MG_FREE_TYPE;
609 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
610 moremg = mg->mg_moremagic;
611 if (mg->mg_type == how) {
613 /* temporarily move to the head of the magic chain, in case
614 custom free code relies on this historical aspect of mg_free */
616 prevmg->mg_moremagic = moremg;
617 mg->mg_moremagic = SvMAGIC(sv);
620 newhead = mg->mg_moremagic;
621 mg_free_struct(sv, mg);
622 SvMAGIC_set(sv, newhead);
630 =for apidoc mg_freeext
632 Remove any magic of type C<how> using virtual table C<vtbl> from the
633 SV C<sv>. See L</sv_magic>.
635 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
641 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
643 MAGIC *mg, *prevmg, *moremg;
644 PERL_ARGS_ASSERT_MG_FREEEXT;
645 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
647 moremg = mg->mg_moremagic;
648 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
649 /* temporarily move to the head of the magic chain, in case
650 custom free code relies on this historical aspect of mg_free */
652 prevmg->mg_moremagic = moremg;
653 mg->mg_moremagic = SvMAGIC(sv);
656 newhead = mg->mg_moremagic;
657 mg_free_struct(sv, mg);
658 SvMAGIC_set(sv, newhead);
668 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
672 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
675 REGEXP * const rx = PM_GETRE(PL_curpm);
677 const SSize_t n = (SSize_t)mg->mg_obj;
678 if (n == '+') { /* @+ */
679 /* return the number possible */
680 return RX_NPARENS(rx);
681 } else { /* @- @^CAPTURE @{^CAPTURE} */
682 I32 paren = RX_LASTPAREN(rx);
684 /* return the last filled */
686 && (RX_OFFS(rx)[paren].start == -1
687 || RX_OFFS(rx)[paren].end == -1) )
693 /* @^CAPTURE @{^CAPTURE} */
694 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
706 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
708 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
711 REGEXP * const rx = PM_GETRE(PL_curpm);
713 const SSize_t n = (SSize_t)mg->mg_obj;
714 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
715 const I32 paren = mg->mg_len
716 + (n == '\003' ? 1 : 0);
721 if (paren <= (I32)RX_NPARENS(rx) &&
722 (s = RX_OFFS(rx)[paren].start) != -1 &&
723 (t = RX_OFFS(rx)[paren].end) != -1)
727 if (n == '+') /* @+ */
729 else if (n == '-') /* @- */
731 else { /* @^CAPTURE @{^CAPTURE} */
732 CALLREG_NUMBUF_FETCH(rx,paren,sv);
736 if (RX_MATCH_UTF8(rx)) {
737 const char * const b = RX_SUBBEG(rx);
739 i = RX_SUBCOFFSET(rx) +
741 (U8*)(b-RX_SUBOFFSET(rx)+i));
756 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
758 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
762 Perl_croak_no_modify();
763 NORETURN_FUNCTION_END;
766 #define SvRTRIM(sv) STMT_START { \
768 STRLEN len = SvCUR(sv); \
769 char * const p = SvPVX(sv); \
770 while (len > 0 && isSPACE(p[len-1])) \
772 SvCUR_set(sv, len); \
778 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
780 PERL_ARGS_ASSERT_EMULATE_COP_IO;
782 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
787 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
788 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
793 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
794 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
802 S_fixup_errno_string(pTHX_ SV* sv)
804 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
807 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
811 if(strEQ(SvPVX(sv), "")) {
812 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
816 /* In some locales the error string may come back as UTF-8, in which
817 * case we should turn on that flag. This didn't use to happen, and to
818 * avoid as many possible backward compatibility issues as possible, we
819 * don't turn on the flag unless we have to. So the flag stays off for
820 * an entirely invariant string. We assume that if the string looks
821 * like UTF-8 in a single script, it really is UTF-8: "text in any
822 * other encoding that uses bytes with the high bit set is extremely
823 * unlikely to pass a UTF-8 validity test"
824 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
825 * potential that we will get it wrong however, especially on short
826 * error message text, so do an additional check. */
827 if ( ! IN_BYTES /* respect 'use bytes' */
828 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
830 #ifdef USE_LOCALE_MESSAGES
832 && _is_cur_LC_category_utf8(LC_MESSAGES)
834 #else /* If can't check directly, at least can see if script is consistent,
835 under UTF-8, which gives us an extra measure of confidence. */
837 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
838 TRUE) /* Means assume UTF-8 */
848 =for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv
850 Generates the message string describing an OS error and returns it as
851 an SV. C<errnum> must be a value that C<errno> could take, identifying
854 If C<tgtsv> is non-null then the string will be written into that SV
855 (overwriting existing content) and it will be returned. If C<tgtsv>
856 is a null pointer then the string will be written into a new mortal SV
857 which will be returned.
859 The message will be taken from whatever locale would be used by C<$!>,
860 and will be encoded in the SV in whatever manner would be used by C<$!>.
861 The details of this process are subject to future change. Currently,
862 the message is taken from the C locale by default (usually producing an
863 English message), and from the currently selected locale when in the scope
864 of the C<use locale> pragma. A heuristic attempt is made to decode the
865 message from the locale's character encoding, but it will only be decoded
866 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
867 locale, usually in an ISO-8859-1 locale, and never in any other locale.
869 The SV is always returned containing an actual string, and with no other
870 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
871 (meaning success), and if no useful message is available then a useless
872 string (currently empty) is returned.
878 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
882 tgtsv = sv_newmortal();
883 errstr = my_strerror(errnum);
885 sv_setpv(tgtsv, errstr);
886 fixup_errno_string(tgtsv);
899 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
902 const char *s = NULL;
904 const char * const remaining = mg->mg_ptr + 1;
907 PERL_ARGS_ASSERT_MAGIC_GET;
911 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
913 CALLREG_NUMBUF_FETCH(rx,paren,sv);
920 nextchar = *remaining;
921 switch (*mg->mg_ptr) {
922 case '\001': /* ^A */
923 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
926 if (SvTAINTED(PL_bodytarget))
929 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
930 if (nextchar == '\0') {
931 sv_setiv(sv, (IV)PL_minus_c);
933 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
934 sv_setiv(sv, (IV)STATUS_NATIVE);
938 case '\004': /* ^D */
939 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
941 case '\005': /* ^E */
942 if (nextchar != '\0') {
943 if (strEQ(remaining, "NCODING"))
948 #if defined(VMS) || defined(OS2) || defined(WIN32)
952 $DESCRIPTOR(msgdsc,msg);
953 sv_setnv(sv,(NV) vaxc$errno);
954 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
955 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
960 if (!(_emx_env & 0x200)) { /* Under DOS */
961 sv_setnv(sv, (NV)errno);
962 sv_setpv(sv, errno ? my_strerror(errno) : "");
964 if (errno != errno_isOS2) {
965 const int tmp = _syserrno();
966 if (tmp) /* 2nd call to _syserrno() makes it 0 */
969 sv_setnv(sv, (NV)Perl_rc);
970 sv_setpv(sv, os2error(Perl_rc));
972 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
973 fixup_errno_string(sv);
975 # elif defined(WIN32)
977 const DWORD dwErr = GetLastError();
978 sv_setnv(sv, (NV)dwErr);
980 PerlProc_GetOSError(sv, dwErr);
981 fixup_errno_string(sv);
988 # error Missing code for platform
991 SvNOK_on(sv); /* what a wonderful hack! */
993 #endif /* End of platforms with special handling for $^E; others just fall
1001 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1003 sv_setnv(sv, (NV)errno);
1006 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1007 sv_setpv(sv, os2error(Perl_rc));
1014 sv_string_from_errnum(errno, sv);
1015 /* If no useful string is available, don't
1016 * claim to have a string part. The SvNOK_on()
1017 * below will cause just the number part to be valid */
1025 SvNOK_on(sv); /* what a wonderful hack! */
1028 case '\006': /* ^F */
1029 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_CHECK_THINKFIRST_COW_DROP(sv);
1048 prepare_SV_for_RV(sv);
1050 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
1058 case '\017': /* ^O & ^OPEN */
1059 if (nextchar == '\0') {
1060 sv_setpv(sv, PL_osname);
1063 else if (strEQ(remaining, "PEN")) {
1064 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1068 sv_setiv(sv, (IV)PL_perldb);
1070 case '\023': /* ^S */
1071 if (nextchar == '\0') {
1072 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1074 else if (PL_in_eval)
1075 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1079 else if (strEQ(remaining, "AFE_LOCALES")) {
1081 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1083 sv_setuv(sv, (UV) 1);
1086 sv_setuv(sv, (UV) 0);
1092 case '\024': /* ^T */
1093 if (nextchar == '\0') {
1095 sv_setnv(sv, PL_basetime);
1097 sv_setiv(sv, (IV)PL_basetime);
1100 else if (strEQ(remaining, "AINT"))
1101 sv_setiv(sv, TAINTING_get
1102 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1105 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1106 if (strEQ(remaining, "NICODE"))
1107 sv_setuv(sv, (UV) PL_unicode);
1108 else if (strEQ(remaining, "TF8LOCALE"))
1109 sv_setuv(sv, (UV) PL_utf8locale);
1110 else if (strEQ(remaining, "TF8CACHE"))
1111 sv_setiv(sv, (IV) PL_utf8cache);
1113 case '\027': /* ^W & $^WARNING_BITS */
1114 if (nextchar == '\0')
1115 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1116 else if (strEQ(remaining, "ARNING_BITS")) {
1117 if (PL_compiling.cop_warnings == pWARN_NONE) {
1118 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1120 else if (PL_compiling.cop_warnings == pWARN_STD) {
1123 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1124 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1127 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1128 *PL_compiling.cop_warnings);
1132 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
1133 sv_setiv(sv, w32_sloppystat);
1138 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1139 paren = RX_LASTPAREN(rx);
1141 goto do_numbuf_fetch;
1144 case '\016': /* ^N */
1145 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1146 paren = RX_LASTCLOSEPAREN(rx);
1148 goto do_numbuf_fetch;
1152 if (GvIO(PL_last_in_gv)) {
1153 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1158 sv_setiv(sv, (IV)STATUS_CURRENT);
1159 #ifdef COMPLEX_STATUS
1160 SvUPGRADE(sv, SVt_PVLV);
1161 LvTARGOFF(sv) = PL_statusvalue;
1162 LvTARGLEN(sv) = PL_statusvalue_vms;
1167 if (GvIOp(PL_defoutgv))
1168 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1172 sv_setpv(sv,GvENAME(PL_defoutgv));
1173 sv_catpvs(sv,"_TOP");
1177 if (GvIOp(PL_defoutgv))
1178 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1180 s = GvENAME(PL_defoutgv);
1184 if (GvIO(PL_defoutgv))
1185 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1188 if (GvIO(PL_defoutgv))
1189 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1192 if (GvIO(PL_defoutgv))
1193 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1202 if (GvIO(PL_defoutgv))
1203 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1207 sv_copypv(sv, PL_ors_sv);
1213 IV const pid = (IV)PerlProc_getpid();
1214 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1215 /* never set manually, or at least not since last fork */
1217 /* never unsafe, even if reading in a tainted expression */
1220 /* else a value has been assigned manually, so do nothing */
1224 sv_setuid(sv, PerlProc_getuid());
1227 sv_setuid(sv, PerlProc_geteuid());
1230 sv_setgid(sv, PerlProc_getgid());
1233 sv_setgid(sv, PerlProc_getegid());
1235 #ifdef HAS_GETGROUPS
1237 Groups_t *gary = NULL;
1238 I32 num_groups = getgroups(0, gary);
1239 if (num_groups > 0) {
1241 Newx(gary, num_groups, Groups_t);
1242 num_groups = getgroups(num_groups, gary);
1243 for (i = 0; i < num_groups; i++)
1244 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1248 (void)SvIOK_on(sv); /* what a wonderful hack! */
1262 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1264 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1266 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1268 if (uf && uf->uf_val)
1269 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1274 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1276 STRLEN len = 0, klen;
1277 const char * const key = MgPV_const(mg,klen);
1280 PERL_ARGS_ASSERT_MAGIC_SETENV;
1284 /* defined environment variables are byte strings; unfortunately
1285 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1286 (void)SvPV_force_nomg_nolen(sv);
1287 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1289 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1295 my_setenv(key, s); /* does the deed */
1297 #ifdef DYNAMIC_ENV_FETCH
1298 /* We just undefd an environment var. Is a replacement */
1299 /* waiting in the wings? */
1301 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1303 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1307 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
1308 /* And you'll never guess what the dog had */
1309 /* in its mouth... */
1311 MgTAINTEDDIR_off(mg);
1313 if (s && memEQs(key, klen, "DCL$PATH")) {
1314 char pathbuf[256], eltbuf[256], *cp, *elt;
1317 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1319 do { /* DCL$PATH may be a search list */
1320 while (1) { /* as may dev portion of any element */
1321 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1322 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1323 cando_by_name(S_IWUSR,0,elt) ) {
1324 MgTAINTEDDIR_on(mg);
1328 if ((cp = strchr(elt, ':')) != NULL)
1330 if (my_trnlnm(elt, eltbuf, j++))
1336 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1339 if (s && memEQs(key, klen, "PATH")) {
1340 const char * const strend = s + len;
1342 /* set MGf_TAINTEDDIR if any component of the new path is
1343 * relative or world-writeable */
1344 while (s < strend) {
1348 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1349 const char path_sep = PL_perllib_sep;
1351 const char path_sep = ':';
1353 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1354 s, strend, path_sep, &i);
1356 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1358 /* no colon thus no device name -- assume relative path */
1359 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1360 /* Using Unix separator, e.g. under bash, so act line Unix */
1361 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1363 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1365 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1366 MgTAINTEDDIR_on(mg);
1372 #endif /* neither OS2 nor WIN32 nor MSDOS */
1378 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1380 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1381 PERL_UNUSED_ARG(sv);
1382 my_setenv(MgPV_nolen_const(mg),NULL);
1387 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1389 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1390 PERL_UNUSED_ARG(mg);
1392 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1394 if (PL_localizing) {
1397 hv_iterinit(MUTABLE_HV(sv));
1398 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1400 my_setenv(hv_iterkey(entry, &keylen),
1401 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1409 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1411 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1412 PERL_UNUSED_ARG(sv);
1413 PERL_UNUSED_ARG(mg);
1415 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1423 #ifdef HAS_SIGPROCMASK
1425 restore_sigmask(pTHX_ SV *save_sv)
1427 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1428 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1432 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1434 /* Are we fetching a signal entry? */
1435 int i = (I16)mg->mg_private;
1437 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1441 const char * sig = MgPV_const(mg, siglen);
1442 mg->mg_private = i = whichsig_pvn(sig, siglen);
1447 sv_setsv(sv,PL_psig_ptr[i]);
1449 Sighandler_t sigstate = rsignal_state(i);
1450 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1451 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1454 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1455 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1458 /* cache state so we don't fetch it again */
1459 if(sigstate == (Sighandler_t) SIG_IGN)
1460 sv_setpvs(sv,"IGNORE");
1463 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1470 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1472 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1474 magic_setsig(NULL, mg);
1475 return sv_unmagic(sv, mg->mg_type);
1479 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1480 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1482 Perl_csighandler(int sig)
1485 #ifdef PERL_GET_SIG_CONTEXT
1486 dTHXa(PERL_GET_SIG_CONTEXT);
1490 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1491 #if defined(__cplusplus) && defined(__GNUC__)
1492 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1493 * parameters would be warned about. */
1494 PERL_UNUSED_ARG(sip);
1495 PERL_UNUSED_ARG(uap);
1498 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1499 (void) rsignal(sig, PL_csighandlerp);
1500 if (PL_sig_ignoring[sig]) return;
1502 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1503 if (PL_sig_defaulting[sig])
1504 #ifdef KILL_BY_SIGPRC
1505 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1520 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1521 /* Call the perl level handler now--
1522 * with risk we may be in malloc() or being destructed etc. */
1523 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1524 (*PL_sighandlerp)(sig, NULL, NULL);
1526 (*PL_sighandlerp)(sig);
1529 if (!PL_psig_pend) return;
1530 /* Set a flag to say this signal is pending, that is awaiting delivery after
1531 * the current Perl opcode completes */
1532 PL_psig_pend[sig]++;
1534 #ifndef SIG_PENDING_DIE_COUNT
1535 # define SIG_PENDING_DIE_COUNT 120
1537 /* Add one to say _a_ signal is pending */
1538 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1539 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1540 (unsigned long)SIG_PENDING_DIE_COUNT);
1544 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1546 Perl_csighandler_init(void)
1549 if (PL_sig_handlers_initted) return;
1551 for (sig = 1; sig < SIG_SIZE; sig++) {
1552 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1554 PL_sig_defaulting[sig] = 1;
1555 (void) rsignal(sig, PL_csighandlerp);
1557 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1558 PL_sig_ignoring[sig] = 0;
1561 PL_sig_handlers_initted = 1;
1565 #if defined HAS_SIGPROCMASK
1567 unblock_sigmask(pTHX_ void* newset)
1569 PERL_UNUSED_CONTEXT;
1570 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1575 Perl_despatch_signals(pTHX)
1579 for (sig = 1; sig < SIG_SIZE; sig++) {
1580 if (PL_psig_pend[sig]) {
1582 #ifdef HAS_SIGPROCMASK
1583 /* From sigaction(2) (FreeBSD man page):
1584 * | Signal routines normally execute with the signal that
1585 * | caused their invocation blocked, but other signals may
1587 * Emulation of this behavior (from within Perl) is enabled
1591 sigset_t newset, oldset;
1593 sigemptyset(&newset);
1594 sigaddset(&newset, sig);
1595 sigprocmask(SIG_BLOCK, &newset, &oldset);
1596 was_blocked = sigismember(&oldset, sig);
1598 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1600 SAVEFREESV(save_sv);
1601 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1604 PL_psig_pend[sig] = 0;
1605 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1606 (*PL_sighandlerp)(sig, NULL, NULL);
1608 (*PL_sighandlerp)(sig);
1610 #ifdef HAS_SIGPROCMASK
1619 /* sv of NULL signifies that we're acting as magic_clearsig. */
1621 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1626 /* Need to be careful with SvREFCNT_dec(), because that can have side
1627 * effects (due to closures). We must make sure that the new disposition
1628 * is in place before it is called.
1632 #ifdef HAS_SIGPROCMASK
1636 const char *s = MgPV_const(mg,len);
1638 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1641 if (memEQs(s, len, "__DIE__"))
1643 else if (memEQs(s, len, "__WARN__")
1644 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1645 /* Merge the existing behaviours, which are as follows:
1646 magic_setsig, we always set svp to &PL_warnhook
1647 (hence we always change the warnings handler)
1648 For magic_clearsig, we don't change the warnings handler if it's
1649 set to the &PL_warnhook. */
1652 SV *tmp = sv_newmortal();
1653 Perl_croak(aTHX_ "No such hook: %s",
1654 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1658 if (*svp != PERL_WARNHOOK_FATAL)
1664 i = (I16)mg->mg_private;
1666 i = whichsig_pvn(s, len); /* ...no, a brick */
1667 mg->mg_private = (U16)i;
1671 SV *tmp = sv_newmortal();
1672 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1673 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1677 #ifdef HAS_SIGPROCMASK
1678 /* Avoid having the signal arrive at a bad time, if possible. */
1681 sigprocmask(SIG_BLOCK, &set, &save);
1683 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1684 SAVEFREESV(save_sv);
1685 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1688 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1689 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1691 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1692 PL_sig_ignoring[i] = 0;
1694 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1695 PL_sig_defaulting[i] = 0;
1697 to_dec = PL_psig_ptr[i];
1699 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1700 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1702 /* Signals don't change name during the program's execution, so once
1703 they're cached in the appropriate slot of PL_psig_name, they can
1706 Ideally we'd find some way of making SVs at (C) compile time, or
1707 at least, doing most of the work. */
1708 if (!PL_psig_name[i]) {
1709 PL_psig_name[i] = newSVpvn(s, len);
1710 SvREADONLY_on(PL_psig_name[i]);
1713 SvREFCNT_dec(PL_psig_name[i]);
1714 PL_psig_name[i] = NULL;
1715 PL_psig_ptr[i] = NULL;
1718 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1720 (void)rsignal(i, PL_csighandlerp);
1723 *svp = SvREFCNT_inc_simple_NN(sv);
1725 if (sv && SvOK(sv)) {
1726 s = SvPV_force(sv, len);
1730 if (sv && memEQs(s, len,"IGNORE")) {
1732 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1733 PL_sig_ignoring[i] = 1;
1734 (void)rsignal(i, PL_csighandlerp);
1736 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1740 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1742 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1743 PL_sig_defaulting[i] = 1;
1744 (void)rsignal(i, PL_csighandlerp);
1746 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1752 * We should warn if HINT_STRICT_REFS, but without
1753 * access to a known hint bit in a known OP, we can't
1754 * tell whether HINT_STRICT_REFS is in force or not.
1756 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1757 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1760 (void)rsignal(i, PL_csighandlerp);
1762 *svp = SvREFCNT_inc_simple_NN(sv);
1766 #ifdef HAS_SIGPROCMASK
1770 SvREFCNT_dec(to_dec);
1773 #endif /* !PERL_MICRO */
1776 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1778 PERL_ARGS_ASSERT_MAGIC_SETISA;
1779 PERL_UNUSED_ARG(sv);
1781 /* Skip _isaelem because _isa will handle it shortly */
1782 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1785 return magic_clearisa(NULL, mg);
1788 /* sv of NULL signifies that we're acting as magic_setisa. */
1790 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1793 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1795 /* Bail out if destruction is going on */
1796 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1799 av_clear(MUTABLE_AV(sv));
1801 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1802 /* This occurs with setisa_elem magic, which calls this
1804 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1807 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1808 SV **svp = AvARRAY((AV *)mg->mg_obj);
1809 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1811 stash = GvSTASH((GV *)*svp++);
1812 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1819 (const GV *)mg->mg_obj
1822 /* The stash may have been detached from the symbol table, so check its
1823 name before doing anything. */
1824 if (stash && HvENAME_get(stash))
1825 mro_isa_changed_in(stash);
1831 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1833 HV * const hv = MUTABLE_HV(LvTARG(sv));
1836 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1837 PERL_UNUSED_ARG(mg);
1840 (void) hv_iterinit(hv);
1841 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1844 while (hv_iternext(hv))
1849 sv_setiv(sv, (IV)i);
1854 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1856 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1857 PERL_UNUSED_ARG(mg);
1859 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1865 =for apidoc magic_methcall
1867 Invoke a magic method (like FETCH).
1869 C<sv> and C<mg> are the tied thingy and the tie magic.
1871 C<meth> is the name of the method to call.
1873 C<argc> is the number of args (in addition to $self) to pass to the method.
1875 The C<flags> can be:
1877 G_DISCARD invoke method with G_DISCARD flag and don't
1879 G_UNDEF_FILL fill the stack with argc pointers to
1882 The arguments themselves are any values following the C<flags> argument.
1884 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1891 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1897 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1901 if (flags & G_WRITING_TO_STDERR) {
1905 SAVESPTR(PL_stderrgv);
1909 PUSHSTACKi(PERLSI_MAGIC);
1912 /* EXTEND() expects a signed argc; don't wrap when casting */
1913 assert(argc <= I32_MAX);
1914 EXTEND(SP, (I32)argc+1);
1915 PUSHs(SvTIED_obj(sv, mg));
1916 if (flags & G_UNDEF_FILL) {
1918 PUSHs(&PL_sv_undef);
1920 } else if (argc > 0) {
1922 va_start(args, argc);
1925 SV *const sv = va_arg(args, SV *);
1932 if (flags & G_DISCARD) {
1933 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1936 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1937 ret = *PL_stack_sp--;
1940 if (flags & G_WRITING_TO_STDERR)
1946 /* wrapper for magic_methcall that creates the first arg */
1949 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1954 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1957 if (mg->mg_len >= 0) {
1958 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1960 else if (mg->mg_len == HEf_SVKEY)
1961 arg1 = MUTABLE_SV(mg->mg_ptr);
1963 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1964 arg1 = newSViv((IV)(mg->mg_len));
1968 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1970 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1974 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1978 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1980 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1987 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1989 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1991 if (mg->mg_type == PERL_MAGIC_tiedelem)
1992 mg->mg_flags |= MGf_GSKIP;
1993 magic_methpack(sv,mg,SV_CONST(FETCH));
1998 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2003 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2005 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2006 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2007 * public flags indicate its value based on copying from $val. Doing
2008 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2009 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2010 * wrong if $val happened to be tainted, as sv hasn't got magic
2011 * enabled, even though taint magic is in the chain. In which case,
2012 * fake up a temporary tainted value (this is easier than temporarily
2013 * re-enabling magic on sv). */
2015 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2016 && (tmg->mg_len & 1))
2018 val = sv_mortalcopy(sv);
2024 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2029 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2031 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2033 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2034 return magic_methpack(sv,mg,SV_CONST(DELETE));
2039 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2044 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2046 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2048 retval = SvIV(retsv)-1;
2050 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2052 return (U32) retval;
2056 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2058 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2060 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2065 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2069 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2071 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2072 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2079 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2081 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2083 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2087 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2090 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2091 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2093 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2095 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2097 if (HvEITER_get(hv))
2098 /* we are in an iteration so the hash cannot be empty */
2100 /* no xhv_eiter so now use FIRSTKEY */
2101 key = sv_newmortal();
2102 magic_nextpack(MUTABLE_SV(hv), mg, key);
2103 HvEITER_set(hv, NULL); /* need to reset iterator */
2104 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2107 /* there is a SCALAR method that we can call */
2108 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2110 retval = &PL_sv_undef;
2115 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2119 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2121 /* The magic ptr/len for the debugger's hash should always be an SV. */
2122 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2123 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2124 (IV)mg->mg_len, mg->mg_ptr);
2127 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2128 setting/clearing debugger breakpoints is not a hot path. */
2129 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2130 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2132 if (svp && SvIOKp(*svp)) {
2133 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2135 #ifdef PERL_DEBUG_READONLY_OPS
2136 Slab_to_rw(OpSLAB(o));
2138 /* set or clear breakpoint in the relevant control op */
2140 o->op_flags |= OPf_SPECIAL;
2142 o->op_flags &= ~OPf_SPECIAL;
2143 #ifdef PERL_DEBUG_READONLY_OPS
2144 Slab_to_ro(OpSLAB(o));
2152 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2154 AV * const obj = MUTABLE_AV(mg->mg_obj);
2156 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2159 sv_setiv(sv, AvFILL(obj));
2167 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2169 AV * const obj = MUTABLE_AV(mg->mg_obj);
2171 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2174 av_fill(obj, SvIV(sv));
2176 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2177 "Attempt to set length of freed array");
2183 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2185 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2186 PERL_UNUSED_ARG(sv);
2187 PERL_UNUSED_CONTEXT;
2189 /* Reset the iterator when the array is cleared */
2190 if (sizeof(IV) == sizeof(SSize_t)) {
2191 *((IV *) &(mg->mg_len)) = 0;
2194 *((IV *) mg->mg_ptr) = 0;
2201 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2203 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2204 PERL_UNUSED_ARG(sv);
2206 /* during global destruction, mg_obj may already have been freed */
2207 if (PL_in_clean_all)
2210 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2213 /* arylen scalar holds a pointer back to the array, but doesn't own a
2214 reference. Hence the we (the array) are about to go away with it
2215 still pointing at us. Clear its pointer, else it would be pointing
2216 at free memory. See the comment in sv_magic about reference loops,
2217 and why it can't own a reference to us. */
2224 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2226 SV* const lsv = LvTARG(sv);
2227 MAGIC * const found = mg_find_mglob(lsv);
2229 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2230 PERL_UNUSED_ARG(mg);
2232 if (found && found->mg_len != -1) {
2233 STRLEN i = found->mg_len;
2234 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2235 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2244 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2246 SV* const lsv = LvTARG(sv);
2252 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2253 PERL_UNUSED_ARG(mg);
2255 found = mg_find_mglob(lsv);
2259 found = sv_magicext_mglob(lsv);
2261 else if (!SvOK(sv)) {
2265 s = SvPV_const(lsv, len);
2270 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2280 else if (pos > (SSize_t)len)
2283 found->mg_len = pos;
2284 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2290 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2293 SV * const lsv = LvTARG(sv);
2294 const char * const tmps = SvPV_const(lsv,len);
2295 STRLEN offs = LvTARGOFF(sv);
2296 STRLEN rem = LvTARGLEN(sv);
2297 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2298 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2300 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2301 PERL_UNUSED_ARG(mg);
2303 if (!translate_substr_offsets(
2304 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2305 negoff ? -(IV)offs : (IV)offs, !negoff,
2306 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2308 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2314 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2315 sv_setpvn(sv, tmps + offs, rem);
2322 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2324 STRLEN len, lsv_len, oldtarglen, newtarglen;
2325 const char * const tmps = SvPV_const(sv, len);
2326 SV * const lsv = LvTARG(sv);
2327 STRLEN lvoff = LvTARGOFF(sv);
2328 STRLEN lvlen = LvTARGLEN(sv);
2329 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2330 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2332 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2333 PERL_UNUSED_ARG(mg);
2337 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2338 "Attempt to use reference as lvalue in substr"
2340 SvPV_force_nomg(lsv,lsv_len);
2341 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2342 if (!translate_substr_offsets(
2344 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2345 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2347 Perl_croak(aTHX_ "substr outside of string");
2350 sv_utf8_upgrade_nomg(lsv);
2351 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2352 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2353 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2356 else if (SvUTF8(lsv)) {
2358 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2360 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2361 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2365 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2368 if (!neglen) LvTARGLEN(sv) = newtarglen;
2369 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2375 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2377 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2378 PERL_UNUSED_ARG(sv);
2379 #ifdef NO_TAINT_SUPPORT
2380 PERL_UNUSED_ARG(mg);
2383 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2388 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2390 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2391 PERL_UNUSED_ARG(sv);
2393 /* update taint status */
2402 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2404 SV * const lsv = LvTARG(sv);
2405 char errflags = LvFLAGS(sv);
2407 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2408 PERL_UNUSED_ARG(mg);
2410 /* non-zero errflags implies deferred out-of-range condition */
2411 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2412 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2418 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2420 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2421 PERL_UNUSED_ARG(mg);
2422 do_vecset(sv); /* XXX slurp this routine */
2427 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2430 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2431 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2433 if (LvTARGLEN(sv)) {
2435 SV * const ahv = LvTARG(sv);
2436 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2440 else if (LvSTARGOFF(sv) >= 0) {
2441 AV *const av = MUTABLE_AV(LvTARG(sv));
2442 if (LvSTARGOFF(sv) <= AvFILL(av))
2444 if (SvRMAGICAL(av)) {
2445 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2446 targ = svp ? *svp : NULL;
2449 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2452 if (targ && (targ != &PL_sv_undef)) {
2453 /* somebody else defined it for us */
2454 SvREFCNT_dec(LvTARG(sv));
2455 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2457 SvREFCNT_dec(mg->mg_obj);
2459 mg->mg_flags &= ~MGf_REFCOUNTED;
2468 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2470 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2472 sv_setsv(sv, defelem_target(sv, mg));
2477 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2479 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2480 PERL_UNUSED_ARG(mg);
2484 sv_setsv(LvTARG(sv), sv);
2485 SvSETMAGIC(LvTARG(sv));
2491 Perl_vivify_defelem(pTHX_ SV *sv)
2496 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2498 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2501 SV * const ahv = LvTARG(sv);
2502 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2505 if (!value || value == &PL_sv_undef)
2506 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2508 else if (LvSTARGOFF(sv) < 0)
2509 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2511 AV *const av = MUTABLE_AV(LvTARG(sv));
2512 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2513 LvTARG(sv) = NULL; /* array can't be extended */
2515 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2516 if (!svp || !(value = *svp))
2517 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2520 SvREFCNT_inc_simple_void(value);
2521 SvREFCNT_dec(LvTARG(sv));
2524 SvREFCNT_dec(mg->mg_obj);
2526 mg->mg_flags &= ~MGf_REFCOUNTED;
2530 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2532 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2533 PERL_UNUSED_ARG(mg);
2534 sv_unmagic(sv, PERL_MAGIC_nonelem);
2539 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2541 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2542 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2547 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2549 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2550 PERL_UNUSED_CONTEXT;
2551 PERL_UNUSED_ARG(sv);
2557 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2559 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2561 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2563 if (uf && uf->uf_set)
2564 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2569 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2571 const char type = mg->mg_type;
2573 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2575 assert( type == PERL_MAGIC_fm
2576 || type == PERL_MAGIC_qr
2577 || type == PERL_MAGIC_bm);
2578 return sv_unmagic(sv, type);
2581 #ifdef USE_LOCALE_COLLATE
2583 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2585 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2588 * RenE<eacute> Descartes said "I think not."
2589 * and vanished with a faint plop.
2591 PERL_UNUSED_CONTEXT;
2592 PERL_UNUSED_ARG(sv);
2594 Safefree(mg->mg_ptr);
2600 #endif /* USE_LOCALE_COLLATE */
2602 /* Just clear the UTF-8 cache data. */
2604 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2606 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2607 PERL_UNUSED_CONTEXT;
2608 PERL_UNUSED_ARG(sv);
2609 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2611 mg->mg_len = -1; /* The mg_len holds the len cache. */
2616 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2618 const char *bad = NULL;
2619 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2620 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2621 switch (mg->mg_private & OPpLVREF_TYPE) {
2623 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2627 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2631 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2635 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2639 /* diag_listed_as: Assigned value is not %s reference */
2640 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2641 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2644 SV * const old = PAD_SV(mg->mg_len);
2645 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2650 gv_setref(mg->mg_obj, sv);
2651 SvSETMAGIC(mg->mg_obj);
2654 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2655 SvREFCNT_inc_simple_NN(SvRV(sv)));
2658 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2659 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2661 if (mg->mg_flags & MGf_PERSIST)
2662 NOOP; /* This sv is in use as an iterator var and will be reused,
2663 so we must leave the magic. */
2665 /* This sv could be returned by the assignment op, so clear the
2666 magic, as lvrefs are an implementation detail that must not be
2667 leaked to the user. */
2668 sv_unmagic(sv, PERL_MAGIC_lvref);
2673 S_set_dollarzero(pTHX_ SV *sv)
2674 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2681 #ifdef HAS_SETPROCTITLE
2682 /* The BSDs don't show the argv[] in ps(1) output, they
2683 * show a string from the process struct and provide
2684 * the setproctitle() routine to manipulate that. */
2685 if (PL_origalen != 1) {
2686 s = SvPV_const(sv, len);
2687 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2688 /* The leading "-" removes the "perl: " prefix,
2689 * but not the "(perl) suffix from the ps(1)
2690 * output, because that's what ps(1) shows if the
2691 * argv[] is modified. */
2692 setproctitle("-%s", s);
2693 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2694 /* This doesn't really work if you assume that
2695 * $0 = 'foobar'; will wipe out 'perl' from the $0
2696 * because in ps(1) output the result will be like
2697 * sprintf("perl: %s (perl)", s)
2698 * I guess this is a security feature:
2699 * one (a user process) cannot get rid of the original name.
2701 setproctitle("%s", s);
2704 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2705 if (PL_origalen != 1) {
2707 s = SvPV_const(sv, len);
2708 un.pst_command = (char *)s;
2709 pstat(PSTAT_SETCMD, un, len, 0, 0);
2712 if (PL_origalen > 1) {
2714 /* PL_origalen is set in perl_parse(). */
2715 s = SvPV_force(sv,len);
2716 if (len >= (STRLEN)PL_origalen-1) {
2717 /* Longer than original, will be truncated. We assume that
2718 * PL_origalen bytes are available. */
2719 Copy(s, PL_origargv[0], PL_origalen-1, char);
2722 /* Shorter than original, will be padded. */
2724 /* Special case for Mac OS X: see [perl #38868] */
2727 /* Is the space counterintuitive? Yes.
2728 * (You were expecting \0?)
2729 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2731 const int pad = ' ';
2733 Copy(s, PL_origargv[0], len, char);
2734 PL_origargv[0][len] = 0;
2735 memset(PL_origargv[0] + len + 1,
2736 pad, PL_origalen - len - 1);
2738 PL_origargv[0][PL_origalen-1] = 0;
2739 for (i = 1; i < PL_origargc; i++)
2741 #ifdef HAS_PRCTL_SET_NAME
2742 /* Set the legacy process name in addition to the POSIX name on Linux */
2743 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2744 /* diag_listed_as: SKIPME */
2745 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2753 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2764 PERL_ARGS_ASSERT_MAGIC_SET;
2768 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2770 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2772 /* Croak with a READONLY error when a numbered match var is
2773 * set without a previous pattern match. Unless it's C<local $1>
2776 if (!PL_localizing) {
2777 Perl_croak_no_modify();
2783 switch (*mg->mg_ptr) {
2784 case '\001': /* ^A */
2785 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2786 else SvOK_off(PL_bodytarget);
2787 FmLINES(PL_bodytarget) = 0;
2788 if (SvPOK(PL_bodytarget)) {
2789 char *s = SvPVX(PL_bodytarget);
2790 char *e = SvEND(PL_bodytarget);
2791 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2792 FmLINES(PL_bodytarget)++;
2796 /* mg_set() has temporarily made sv non-magical */
2798 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2799 SvTAINTED_on(PL_bodytarget);
2801 SvTAINTED_off(PL_bodytarget);
2804 case '\003': /* ^C */
2805 PL_minus_c = cBOOL(SvIV(sv));
2808 case '\004': /* ^D */
2811 const char *s = SvPV_nolen_const(sv);
2812 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2813 if (DEBUG_x_TEST || DEBUG_B_TEST)
2814 dump_all_perl(!DEBUG_B_TEST);
2817 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2820 case '\005': /* ^E */
2821 if (*(mg->mg_ptr+1) == '\0') {
2823 set_vaxc_errno(SvIV(sv));
2824 #elif defined(WIN32)
2825 SetLastError( SvIV(sv) );
2827 os2_setsyserrno(SvIV(sv));
2829 /* will anyone ever use this? */
2830 SETERRNO(SvIV(sv), 4);
2833 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2834 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2836 case '\006': /* ^F */
2837 PL_maxsysfd = SvIV(sv);
2839 case '\010': /* ^H */
2841 U32 save_hints = PL_hints;
2842 PL_hints = SvUV(sv);
2844 /* If wasn't UTF-8, and now is, notify the parser */
2845 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2846 notify_parser_that_changed_to_utf8();
2850 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2851 Safefree(PL_inplace);
2852 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2854 case '\016': /* ^N */
2855 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2856 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2858 case '\017': /* ^O */
2859 if (*(mg->mg_ptr+1) == '\0') {
2860 Safefree(PL_osname);
2863 TAINT_PROPER("assigning to $^O");
2864 PL_osname = savesvpv(sv);
2867 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2869 const char *const start = SvPV(sv, len);
2870 const char *out = (const char*)memchr(start, '\0', len);
2874 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2875 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2877 /* Opening for input is more common than opening for output, so
2878 ensure that hints for input are sooner on linked list. */
2879 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2881 : newSVpvs_flags("", SvUTF8(sv));
2882 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2885 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2887 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2891 case '\020': /* ^P */
2892 PL_perldb = SvIV(sv);
2893 if (PL_perldb && !PL_DBsingle)
2896 case '\024': /* ^T */
2898 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2900 PL_basetime = (Time_t)SvIV(sv);
2903 case '\025': /* ^UTF8CACHE */
2904 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2905 PL_utf8cache = (signed char) sv_2iv(sv);
2908 case '\027': /* ^W & $^WARNING_BITS */
2909 if (*(mg->mg_ptr+1) == '\0') {
2910 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2912 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2913 | (i ? G_WARN_ON : G_WARN_OFF) ;
2916 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2917 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2919 PL_compiling.cop_warnings = pWARN_STD;
2924 int not_none = 0, not_all = 0;
2925 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2926 for (i = 0 ; i < len ; ++i) {
2928 not_all |= ptr[i] ^ 0x55;
2931 if (!specialWARN(PL_compiling.cop_warnings))
2932 PerlMemShared_free(PL_compiling.cop_warnings);
2933 PL_compiling.cop_warnings = pWARN_NONE;
2934 } else if (len >= WARNsize && !not_all) {
2935 if (!specialWARN(PL_compiling.cop_warnings))
2936 PerlMemShared_free(PL_compiling.cop_warnings);
2937 PL_compiling.cop_warnings = pWARN_ALL;
2938 PL_dowarn |= G_WARN_ONCE ;
2942 const char *const p = SvPV_const(sv, len);
2944 PL_compiling.cop_warnings
2945 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2948 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2949 PL_dowarn |= G_WARN_ONCE ;
2956 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2957 w32_sloppystat = (bool)sv_true(sv);
2962 if (PL_localizing) {
2963 if (PL_localizing == 1)
2964 SAVESPTR(PL_last_in_gv);
2966 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2967 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2970 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2971 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2972 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2975 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2976 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2977 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2980 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2983 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2984 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2985 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2988 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2992 IO * const io = GvIO(PL_defoutgv);
2995 if ((SvIV(sv)) == 0)
2996 IoFLAGS(io) &= ~IOf_FLUSH;
2998 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2999 PerlIO *ofp = IoOFP(io);
3001 (void)PerlIO_flush(ofp);
3002 IoFLAGS(io) |= IOf_FLUSH;
3010 SV *referent = SvRV(sv);
3011 const char *reftype = sv_reftype(referent, 0);
3012 /* XXX: dodgy type check: This leaves me feeling dirty, but
3013 * the alternative is to copy pretty much the entire
3014 * sv_reftype() into this routine, or to do a full string
3015 * comparison on the return of sv_reftype() both of which
3016 * make me feel worse! NOTE, do not modify this comment
3017 * without reviewing the corresponding comment in
3018 * sv_reftype(). - Yves */
3019 if (reftype[0] == 'S' || reftype[0] == 'L') {
3020 IV val = SvIV(referent);
3022 sv_setsv(sv, PL_rs);
3023 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3024 val < 0 ? "a negative integer" : "zero");
3027 sv_setsv(sv, PL_rs);
3028 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3029 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3030 *reftype == 'A' ? "n" : "", reftype);
3033 SvREFCNT_dec(PL_rs);
3034 PL_rs = newSVsv(sv);
3038 SvREFCNT_dec(PL_ors_sv);
3040 PL_ors_sv = newSVsv(sv);
3048 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3051 #ifdef COMPLEX_STATUS
3052 if (PL_localizing == 2) {
3053 SvUPGRADE(sv, SVt_PVLV);
3054 PL_statusvalue = LvTARGOFF(sv);
3055 PL_statusvalue_vms = LvTARGLEN(sv);
3059 #ifdef VMSISH_STATUS
3061 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3064 STATUS_UNIX_EXIT_SET(SvIV(sv));
3069 # define PERL_VMS_BANG vaxc$errno
3071 # define PERL_VMS_BANG 0
3073 #if defined(WIN32) && ! defined(UNDER_CE)
3074 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3075 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3077 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3078 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3084 /* XXX $< currently silently ignores failures */
3085 const Uid_t new_uid = SvUID(sv);
3086 PL_delaymagic_uid = new_uid;
3087 if (PL_delaymagic) {
3088 PL_delaymagic |= DM_RUID;
3089 break; /* don't do magic till later */
3092 PERL_UNUSED_RESULT(setruid(new_uid));
3093 #elif defined(HAS_SETREUID)
3094 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3095 #elif defined(HAS_SETRESUID)
3096 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3098 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3100 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3101 if (new_uid != 0 && PerlProc_getuid() == 0)
3102 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3104 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3106 Perl_croak(aTHX_ "setruid() not implemented");
3113 /* XXX $> currently silently ignores failures */
3114 const Uid_t new_euid = SvUID(sv);
3115 PL_delaymagic_euid = new_euid;
3116 if (PL_delaymagic) {
3117 PL_delaymagic |= DM_EUID;
3118 break; /* don't do magic till later */
3121 PERL_UNUSED_RESULT(seteuid(new_euid));
3122 #elif defined(HAS_SETREUID)
3123 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3124 #elif defined(HAS_SETRESUID)
3125 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3127 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3128 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3130 Perl_croak(aTHX_ "seteuid() not implemented");
3137 /* XXX $( currently silently ignores failures */
3138 const Gid_t new_gid = SvGID(sv);
3139 PL_delaymagic_gid = new_gid;
3140 if (PL_delaymagic) {
3141 PL_delaymagic |= DM_RGID;
3142 break; /* don't do magic till later */
3145 PERL_UNUSED_RESULT(setrgid(new_gid));
3146 #elif defined(HAS_SETREGID)
3147 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3148 #elif defined(HAS_SETRESGID)
3149 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3151 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3152 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3154 Perl_croak(aTHX_ "setrgid() not implemented");
3161 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3162 * but you can override it if you need to.
3165 #define INVALID_GID ((Gid_t)-1)
3167 /* XXX $) currently silently ignores failures */
3169 #ifdef HAS_SETGROUPS
3171 const char *p = SvPV_const(sv, len);
3172 Groups_t *gary = NULL;
3173 const char* endptr = p + len;
3175 #ifdef _SC_NGROUPS_MAX
3176 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3181 int maxgrp = NGROUPS;
3186 if (grok_atoUV(p, &uv, &endptr))
3187 new_egid = (Gid_t)uv;
3189 new_egid = INVALID_GID;
3192 for (i = 0; i < maxgrp; ++i) {
3201 Newx(gary, i + 1, Groups_t);
3203 Renew(gary, i + 1, Groups_t);
3204 if (grok_atoUV(p, &uv, &endptr))
3205 gary[i] = (Groups_t)uv;
3207 gary[i] = INVALID_GID;
3212 PERL_UNUSED_RESULT(setgroups(i, gary));
3215 #else /* HAS_SETGROUPS */
3216 new_egid = SvGID(sv);
3217 #endif /* HAS_SETGROUPS */
3218 PL_delaymagic_egid = new_egid;
3219 if (PL_delaymagic) {
3220 PL_delaymagic |= DM_EGID;
3221 break; /* don't do magic till later */
3224 PERL_UNUSED_RESULT(setegid(new_egid));
3225 #elif defined(HAS_SETREGID)
3226 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3227 #elif defined(HAS_SETRESGID)
3228 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3230 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3231 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3233 Perl_croak(aTHX_ "setegid() not implemented");
3239 PL_chopset = SvPV_force(sv,len);
3242 /* Store the pid in mg->mg_obj so we can tell when a fork has
3243 occurred. mg->mg_obj points to *$ by default, so clear it. */
3244 if (isGV(mg->mg_obj)) {
3245 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3246 SvREFCNT_dec(mg->mg_obj);
3247 mg->mg_flags |= MGf_REFCOUNTED;
3248 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3250 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3253 LOCK_DOLLARZERO_MUTEX;
3254 S_set_dollarzero(aTHX_ sv);
3255 UNLOCK_DOLLARZERO_MUTEX;
3262 Perl_whichsig_sv(pTHX_ SV *sigsv)
3266 PERL_ARGS_ASSERT_WHICHSIG_SV;
3267 sigpv = SvPV_const(sigsv, siglen);
3268 return whichsig_pvn(sigpv, siglen);
3272 Perl_whichsig_pv(pTHX_ const char *sig)
3274 PERL_ARGS_ASSERT_WHICHSIG_PV;
3275 return whichsig_pvn(sig, strlen(sig));
3279 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3283 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3284 PERL_UNUSED_CONTEXT;
3286 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3287 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3288 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3290 if (memEQs(sig, len, "CHLD"))
3294 if (memEQs(sig, len, "CLD"))
3301 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3302 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3304 Perl_sighandler(int sig)
3307 #ifdef PERL_GET_SIG_CONTEXT
3308 dTHXa(PERL_GET_SIG_CONTEXT);
3315 SV * const tSv = PL_Sv;
3319 XPV * const tXpv = PL_Xpv;
3320 I32 old_ss_ix = PL_savestack_ix;
3321 SV *errsv_save = NULL;
3324 if (!PL_psig_ptr[sig]) {
3325 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3330 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3331 /* Max number of items pushed there is 3*n or 4. We cannot fix
3332 infinity, so we fix 4 (in fact 5): */
3333 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3335 PL_savestack_ix += 5; /* Protect save in progress. */
3336 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3339 /* sv_2cv is too complicated, try a simpler variant first: */
3340 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3341 || SvTYPE(cv) != SVt_PVCV) {
3343 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3346 if (!cv || !CvROOT(cv)) {
3347 const HEK * const hek = gv
3351 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3353 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3354 "SIG%s handler \"%" HEKf "\" not defined.\n",
3355 PL_sig_name[sig], HEKfARG(hek));
3356 /* diag_listed_as: SIG%s handler "%s" not defined */
3357 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3358 "SIG%s handler \"__ANON__\" not defined.\n",
3363 sv = PL_psig_name[sig]
3364 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3365 : newSVpv(PL_sig_name[sig],0);
3369 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3370 /* make sure our assumption about the size of the SAVEs are correct:
3371 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3372 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3375 PUSHSTACKi(PERLSI_SIGNAL);
3378 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3380 struct sigaction oact;
3382 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3385 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3386 /* The siginfo fields signo, code, errno, pid, uid,
3387 * addr, status, and band are defined by POSIX/SUSv3. */
3388 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3389 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3390 #ifdef HAS_SIGINFO_SI_ERRNO
3391 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3393 #ifdef HAS_SIGINFO_SI_STATUS
3394 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3396 #ifdef HAS_SIGINFO_SI_UID
3399 sv_setuid(uid, sip->si_uid);
3400 (void)hv_stores(sih, "uid", uid);
3403 #ifdef HAS_SIGINFO_SI_PID
3404 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3406 #ifdef HAS_SIGINFO_SI_ADDR
3407 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3409 #ifdef HAS_SIGINFO_SI_BAND
3410 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3414 mPUSHp((char *)sip, sizeof(*sip));
3422 errsv_save = newSVsv(ERRSV);
3424 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3428 SV * const errsv = ERRSV;
3429 if (SvTRUE_NN(errsv)) {
3430 SvREFCNT_dec(errsv_save);
3432 /* Handler "died", for example to get out of a restart-able read().
3433 * Before we re-do that on its behalf re-enable the signal which was
3434 * blocked by the system when we entered.
3436 #ifdef HAS_SIGPROCMASK
3437 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3443 sigaddset(&set,sig);
3444 sigprocmask(SIG_UNBLOCK, &set, NULL);
3447 /* Not clear if this will work */
3448 (void)rsignal(sig, SIG_IGN);
3449 (void)rsignal(sig, PL_csighandlerp);
3451 #endif /* !PERL_MICRO */
3455 sv_setsv(errsv, errsv_save);
3456 SvREFCNT_dec(errsv_save);
3461 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3462 PL_savestack_ix = old_ss_ix;
3464 SvREFCNT_dec_NN(sv);
3465 PL_op = myop; /* Apparently not needed... */
3467 PL_Sv = tSv; /* Restore global temporaries. */
3474 S_restore_magic(pTHX_ const void *p)
3476 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3477 SV* const sv = mgs->mgs_sv;
3483 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3484 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3486 SvFLAGS(sv) |= mgs->mgs_flags;
3491 bumped = mgs->mgs_bumped;
3492 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3494 /* If we're still on top of the stack, pop us off. (That condition
3495 * will be satisfied if restore_magic was called explicitly, but *not*
3496 * if it's being called via leave_scope.)
3497 * The reason for doing this is that otherwise, things like sv_2cv()
3498 * may leave alloc gunk on the savestack, and some code
3499 * (e.g. sighandler) doesn't expect that...
3501 if (PL_savestack_ix == mgs->mgs_ss_ix)
3503 UV popval = SSPOPUV;
3504 assert(popval == SAVEt_DESTRUCTOR_X);
3505 PL_savestack_ix -= 2;
3507 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3508 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3511 if (SvREFCNT(sv) == 1) {
3512 /* We hold the last reference to this SV, which implies that the
3513 SV was deleted as a side effect of the routines we called.
3514 So artificially keep it alive a bit longer.
3515 We avoid turning on the TEMP flag, which can cause the SV's
3516 buffer to get stolen (and maybe other stuff). */
3521 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3525 /* clean up the mess created by Perl_sighandler().
3526 * Note that this is only called during an exit in a signal handler;
3527 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3531 S_unwind_handler_stack(pTHX_ const void *p)
3535 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3539 =for apidoc magic_sethint
3541 Triggered by a store to C<%^H>, records the key/value pair to
3542 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3543 anything that would need a deep copy. Maybe we should warn if we find a
3549 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3551 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3552 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3554 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3556 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3557 an alternative leaf in there, with PL_compiling.cop_hints being used if
3558 it's NULL. If needed for threads, the alternative could lock a mutex,
3559 or take other more complex action. */
3561 /* Something changed in %^H, so it will need to be restored on scope exit.
3562 Doing this here saves a lot of doing it manually in perl code (and
3563 forgetting to do it, and consequent subtle errors. */
3564 PL_hints |= HINT_LOCALIZE_HH;
3565 CopHINTHASH_set(&PL_compiling,
3566 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3571 =for apidoc magic_clearhint
3573 Triggered by a delete from C<%^H>, records the key to
3574 C<PL_compiling.cop_hints_hash>.
3579 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3581 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3582 PERL_UNUSED_ARG(sv);
3584 PL_hints |= HINT_LOCALIZE_HH;
3585 CopHINTHASH_set(&PL_compiling,
3586 mg->mg_len == HEf_SVKEY
3587 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3588 MUTABLE_SV(mg->mg_ptr), 0, 0)
3589 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3590 mg->mg_ptr, mg->mg_len, 0, 0));
3595 =for apidoc magic_clearhints
3597 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3602 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3604 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3605 PERL_UNUSED_ARG(sv);
3606 PERL_UNUSED_ARG(mg);
3607 cophh_free(CopHINTHASH_get(&PL_compiling));
3608 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3613 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3614 const char *name, I32 namlen)
3618 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3619 PERL_UNUSED_ARG(sv);
3620 PERL_UNUSED_ARG(name);
3621 PERL_UNUSED_ARG(namlen);
3623 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3624 nmg = mg_find(nsv, mg->mg_type);
3626 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3627 nmg->mg_ptr = mg->mg_ptr;
3628 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3629 nmg->mg_flags |= MGf_REFCOUNTED;
3634 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3635 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3637 #if DBVARMG_SINGLE != 0
3638 assert(mg->mg_private >= DBVARMG_SINGLE);
3640 assert(mg->mg_private < DBVARMG_COUNT);
3642 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3648 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3649 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3651 #if DBVARMG_SINGLE != 0
3652 assert(mg->mg_private >= DBVARMG_SINGLE);
3654 assert(mg->mg_private < DBVARMG_COUNT);
3655 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3661 * ex: set ts=8 sts=4 sw=4 et: