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);
560 if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
561 /* collate magic uses string len not buffer len, so
562 * free even with mg_len == 0 */
563 Safefree(mg->mg_ptr);
564 else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
565 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
566 Safefree(mg->mg_ptr);
567 else if (mg->mg_len == HEf_SVKEY)
568 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
571 if (mg->mg_flags & MGf_REFCOUNTED)
572 SvREFCNT_dec(mg->mg_obj);
579 Free any magic storage used by the SV. See C<L</sv_magic>>.
585 Perl_mg_free(pTHX_ SV *sv)
590 PERL_ARGS_ASSERT_MG_FREE;
592 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
593 moremagic = mg->mg_moremagic;
594 mg_free_struct(sv, mg);
595 SvMAGIC_set(sv, moremagic);
597 SvMAGIC_set(sv, NULL);
603 =for apidoc mg_free_type
605 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
611 Perl_mg_free_type(pTHX_ SV *sv, int how)
613 MAGIC *mg, *prevmg, *moremg;
614 PERL_ARGS_ASSERT_MG_FREE_TYPE;
615 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
616 moremg = mg->mg_moremagic;
617 if (mg->mg_type == how) {
619 /* temporarily move to the head of the magic chain, in case
620 custom free code relies on this historical aspect of mg_free */
622 prevmg->mg_moremagic = moremg;
623 mg->mg_moremagic = SvMAGIC(sv);
626 newhead = mg->mg_moremagic;
627 mg_free_struct(sv, mg);
628 SvMAGIC_set(sv, newhead);
636 =for apidoc mg_freeext
638 Remove any magic of type C<how> using virtual table C<vtbl> from the
639 SV C<sv>. See L</sv_magic>.
641 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
647 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
649 MAGIC *mg, *prevmg, *moremg;
650 PERL_ARGS_ASSERT_MG_FREEEXT;
651 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
653 moremg = mg->mg_moremagic;
654 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
655 /* temporarily move to the head of the magic chain, in case
656 custom free code relies on this historical aspect of mg_free */
658 prevmg->mg_moremagic = moremg;
659 mg->mg_moremagic = SvMAGIC(sv);
662 newhead = mg->mg_moremagic;
663 mg_free_struct(sv, mg);
664 SvMAGIC_set(sv, newhead);
674 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
678 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
681 REGEXP * const rx = PM_GETRE(PL_curpm);
683 const SSize_t n = (SSize_t)mg->mg_obj;
684 if (n == '+') { /* @+ */
685 /* return the number possible */
686 return RX_NPARENS(rx);
687 } else { /* @- @^CAPTURE @{^CAPTURE} */
688 I32 paren = RX_LASTPAREN(rx);
690 /* return the last filled */
692 && (RX_OFFS(rx)[paren].start == -1
693 || RX_OFFS(rx)[paren].end == -1) )
699 /* @^CAPTURE @{^CAPTURE} */
700 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
712 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
714 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
717 REGEXP * const rx = PM_GETRE(PL_curpm);
719 const SSize_t n = (SSize_t)mg->mg_obj;
720 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
721 const I32 paren = mg->mg_len
722 + (n == '\003' ? 1 : 0);
727 if (paren <= (I32)RX_NPARENS(rx) &&
728 (s = RX_OFFS(rx)[paren].start) != -1 &&
729 (t = RX_OFFS(rx)[paren].end) != -1)
733 if (n == '+') /* @+ */
735 else if (n == '-') /* @- */
737 else { /* @^CAPTURE @{^CAPTURE} */
738 CALLREG_NUMBUF_FETCH(rx,paren,sv);
742 if (RX_MATCH_UTF8(rx)) {
743 const char * const b = RX_SUBBEG(rx);
745 i = RX_SUBCOFFSET(rx) +
747 (U8*)(b-RX_SUBOFFSET(rx)+i));
762 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
764 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
768 Perl_croak_no_modify();
769 NORETURN_FUNCTION_END;
772 #define SvRTRIM(sv) STMT_START { \
774 STRLEN len = SvCUR(sv); \
775 char * const p = SvPVX(sv); \
776 while (len > 0 && isSPACE(p[len-1])) \
778 SvCUR_set(sv, len); \
784 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
786 PERL_ARGS_ASSERT_EMULATE_COP_IO;
788 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
793 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
794 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
799 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
800 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
808 S_fixup_errno_string(pTHX_ SV* sv)
810 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
813 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
817 if(strEQ(SvPVX(sv), "")) {
818 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
822 /* In some locales the error string may come back as UTF-8, in which
823 * case we should turn on that flag. This didn't use to happen, and to
824 * avoid as many possible backward compatibility issues as possible, we
825 * don't turn on the flag unless we have to. So the flag stays off for
826 * an entirely invariant string. We assume that if the string looks
827 * like UTF-8 in a single script, it really is UTF-8: "text in any
828 * other encoding that uses bytes with the high bit set is extremely
829 * unlikely to pass a UTF-8 validity test"
830 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
831 * potential that we will get it wrong however, especially on short
832 * error message text, so do an additional check. */
833 if ( ! IN_BYTES /* respect 'use bytes' */
834 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
836 #ifdef USE_LOCALE_MESSAGES
838 && _is_cur_LC_category_utf8(LC_MESSAGES)
840 #else /* If can't check directly, at least can see if script is consistent,
841 under UTF-8, which gives us an extra measure of confidence. */
843 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
844 TRUE) /* Means assume UTF-8 */
854 =for apidoc sv_string_from_errnum
856 Generates the message string describing an OS error and returns it as
857 an SV. C<errnum> must be a value that C<errno> could take, identifying
860 If C<tgtsv> is non-null then the string will be written into that SV
861 (overwriting existing content) and it will be returned. If C<tgtsv>
862 is a null pointer then the string will be written into a new mortal SV
863 which will be returned.
865 The message will be taken from whatever locale would be used by C<$!>,
866 and will be encoded in the SV in whatever manner would be used by C<$!>.
867 The details of this process are subject to future change. Currently,
868 the message is taken from the C locale by default (usually producing an
869 English message), and from the currently selected locale when in the scope
870 of the C<use locale> pragma. A heuristic attempt is made to decode the
871 message from the locale's character encoding, but it will only be decoded
872 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
873 locale, usually in an ISO-8859-1 locale, and never in any other locale.
875 The SV is always returned containing an actual string, and with no other
876 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
877 (meaning success), and if no useful message is available then a useless
878 string (currently empty) is returned.
884 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
888 tgtsv = sv_newmortal();
889 errstr = my_strerror(errnum);
891 sv_setpv(tgtsv, errstr);
892 fixup_errno_string(tgtsv);
905 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
908 const char *s = NULL;
910 const char * const remaining = mg->mg_ptr + 1;
913 PERL_ARGS_ASSERT_MAGIC_GET;
917 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
919 CALLREG_NUMBUF_FETCH(rx,paren,sv);
926 nextchar = *remaining;
927 switch (*mg->mg_ptr) {
928 case '\001': /* ^A */
929 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
932 if (SvTAINTED(PL_bodytarget))
935 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
936 if (nextchar == '\0') {
937 sv_setiv(sv, (IV)PL_minus_c);
939 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
940 sv_setiv(sv, (IV)STATUS_NATIVE);
944 case '\004': /* ^D */
945 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
947 case '\005': /* ^E */
948 if (nextchar != '\0') {
949 if (strEQ(remaining, "NCODING"))
954 #if defined(VMS) || defined(OS2) || defined(WIN32)
958 $DESCRIPTOR(msgdsc,msg);
959 sv_setnv(sv,(NV) vaxc$errno);
960 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
961 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
966 if (!(_emx_env & 0x200)) { /* Under DOS */
967 sv_setnv(sv, (NV)errno);
968 sv_setpv(sv, errno ? my_strerror(errno) : "");
970 if (errno != errno_isOS2) {
971 const int tmp = _syserrno();
972 if (tmp) /* 2nd call to _syserrno() makes it 0 */
975 sv_setnv(sv, (NV)Perl_rc);
976 sv_setpv(sv, os2error(Perl_rc));
978 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
979 fixup_errno_string(sv);
981 # elif defined(WIN32)
983 const DWORD dwErr = GetLastError();
984 sv_setnv(sv, (NV)dwErr);
986 PerlProc_GetOSError(sv, dwErr);
987 fixup_errno_string(sv);
994 # error Missing code for platform
997 SvNOK_on(sv); /* what a wonderful hack! */
999 #endif /* End of platforms with special handling for $^E; others just fall
1007 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1009 sv_setnv(sv, (NV)errno);
1012 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1013 sv_setpv(sv, os2error(Perl_rc));
1020 sv_string_from_errnum(errno, sv);
1021 /* If no useful string is available, don't
1022 * claim to have a string part. The SvNOK_on()
1023 * below will cause just the number part to be valid */
1031 SvNOK_on(sv); /* what a wonderful hack! */
1034 case '\006': /* ^F */
1035 sv_setiv(sv, (IV)PL_maxsysfd);
1037 case '\007': /* ^GLOBAL_PHASE */
1038 if (strEQ(remaining, "LOBAL_PHASE")) {
1039 sv_setpvn(sv, PL_phase_names[PL_phase],
1040 strlen(PL_phase_names[PL_phase]));
1043 case '\010': /* ^H */
1044 sv_setuv(sv, PL_hints);
1046 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1047 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1049 case '\014': /* ^LAST_FH */
1050 if (strEQ(remaining, "AST_FH")) {
1051 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1052 assert(isGV_with_GP(PL_last_in_gv));
1053 SV_CHECK_THINKFIRST_COW_DROP(sv);
1054 prepare_SV_for_RV(sv);
1056 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
1064 case '\017': /* ^O & ^OPEN */
1065 if (nextchar == '\0') {
1066 sv_setpv(sv, PL_osname);
1069 else if (strEQ(remaining, "PEN")) {
1070 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1074 sv_setiv(sv, (IV)PL_perldb);
1076 case '\023': /* ^S */
1077 if (nextchar == '\0') {
1078 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1080 else if (PL_in_eval)
1081 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1085 else if (strEQ(remaining, "AFE_LOCALES")) {
1087 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1089 sv_setuv(sv, (UV) 1);
1092 sv_setuv(sv, (UV) 0);
1098 case '\024': /* ^T */
1099 if (nextchar == '\0') {
1101 sv_setnv(sv, PL_basetime);
1103 sv_setiv(sv, (IV)PL_basetime);
1106 else if (strEQ(remaining, "AINT"))
1107 sv_setiv(sv, TAINTING_get
1108 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1111 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1112 if (strEQ(remaining, "NICODE"))
1113 sv_setuv(sv, (UV) PL_unicode);
1114 else if (strEQ(remaining, "TF8LOCALE"))
1115 sv_setuv(sv, (UV) PL_utf8locale);
1116 else if (strEQ(remaining, "TF8CACHE"))
1117 sv_setiv(sv, (IV) PL_utf8cache);
1119 case '\027': /* ^W & $^WARNING_BITS */
1120 if (nextchar == '\0')
1121 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1122 else if (strEQ(remaining, "ARNING_BITS")) {
1123 if (PL_compiling.cop_warnings == pWARN_NONE) {
1124 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1126 else if (PL_compiling.cop_warnings == pWARN_STD) {
1129 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1130 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1133 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1134 *PL_compiling.cop_warnings);
1138 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
1139 sv_setiv(sv, w32_sloppystat);
1144 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1145 paren = RX_LASTPAREN(rx);
1147 goto do_numbuf_fetch;
1150 case '\016': /* ^N */
1151 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1152 paren = RX_LASTCLOSEPAREN(rx);
1154 goto do_numbuf_fetch;
1158 if (GvIO(PL_last_in_gv)) {
1159 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1164 sv_setiv(sv, (IV)STATUS_CURRENT);
1165 #ifdef COMPLEX_STATUS
1166 SvUPGRADE(sv, SVt_PVLV);
1167 LvTARGOFF(sv) = PL_statusvalue;
1168 LvTARGLEN(sv) = PL_statusvalue_vms;
1173 if (GvIOp(PL_defoutgv))
1174 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1178 sv_setpv(sv,GvENAME(PL_defoutgv));
1179 sv_catpvs(sv,"_TOP");
1183 if (GvIOp(PL_defoutgv))
1184 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1186 s = GvENAME(PL_defoutgv);
1190 if (GvIO(PL_defoutgv))
1191 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1194 if (GvIO(PL_defoutgv))
1195 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1198 if (GvIO(PL_defoutgv))
1199 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1208 if (GvIO(PL_defoutgv))
1209 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1213 sv_copypv(sv, PL_ors_sv);
1219 IV const pid = (IV)PerlProc_getpid();
1220 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1221 /* never set manually, or at least not since last fork */
1223 /* never unsafe, even if reading in a tainted expression */
1226 /* else a value has been assigned manually, so do nothing */
1230 sv_setuid(sv, PerlProc_getuid());
1233 sv_setuid(sv, PerlProc_geteuid());
1236 sv_setgid(sv, PerlProc_getgid());
1239 sv_setgid(sv, PerlProc_getegid());
1241 #ifdef HAS_GETGROUPS
1243 Groups_t *gary = NULL;
1244 I32 num_groups = getgroups(0, gary);
1245 if (num_groups > 0) {
1247 Newx(gary, num_groups, Groups_t);
1248 num_groups = getgroups(num_groups, gary);
1249 for (i = 0; i < num_groups; i++)
1250 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1254 (void)SvIOK_on(sv); /* what a wonderful hack! */
1268 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1270 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1272 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1274 if (uf && uf->uf_val)
1275 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1280 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1282 STRLEN len = 0, klen;
1283 const char * const key = MgPV_const(mg,klen);
1286 PERL_ARGS_ASSERT_MAGIC_SETENV;
1290 /* defined environment variables are byte strings; unfortunately
1291 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1292 (void)SvPV_force_nomg_nolen(sv);
1293 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1295 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1301 my_setenv(key, s); /* does the deed */
1303 #ifdef DYNAMIC_ENV_FETCH
1304 /* We just undefd an environment var. Is a replacement */
1305 /* waiting in the wings? */
1307 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1309 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1313 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
1314 /* And you'll never guess what the dog had */
1315 /* in its mouth... */
1317 MgTAINTEDDIR_off(mg);
1319 if (s && memEQs(key, klen, "DCL$PATH")) {
1320 char pathbuf[256], eltbuf[256], *cp, *elt;
1323 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1325 do { /* DCL$PATH may be a search list */
1326 while (1) { /* as may dev portion of any element */
1327 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1328 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1329 cando_by_name(S_IWUSR,0,elt) ) {
1330 MgTAINTEDDIR_on(mg);
1334 if ((cp = strchr(elt, ':')) != NULL)
1336 if (my_trnlnm(elt, eltbuf, j++))
1342 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1345 if (s && memEQs(key, klen, "PATH")) {
1346 const char * const strend = s + len;
1348 /* set MGf_TAINTEDDIR if any component of the new path is
1349 * relative or world-writeable */
1350 while (s < strend) {
1354 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1355 const char path_sep = PL_perllib_sep;
1357 const char path_sep = ':';
1359 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1360 s, strend, path_sep, &i);
1362 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1364 /* no colon thus no device name -- assume relative path */
1365 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1366 /* Using Unix separator, e.g. under bash, so act line Unix */
1367 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1369 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1371 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1372 MgTAINTEDDIR_on(mg);
1378 #endif /* neither OS2 nor WIN32 nor MSDOS */
1384 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1386 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1387 PERL_UNUSED_ARG(sv);
1388 my_setenv(MgPV_nolen_const(mg),NULL);
1393 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1395 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1396 PERL_UNUSED_ARG(mg);
1398 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1400 if (PL_localizing) {
1403 hv_iterinit(MUTABLE_HV(sv));
1404 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1406 my_setenv(hv_iterkey(entry, &keylen),
1407 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1415 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1417 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1418 PERL_UNUSED_ARG(sv);
1419 PERL_UNUSED_ARG(mg);
1421 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1429 #ifdef HAS_SIGPROCMASK
1431 restore_sigmask(pTHX_ SV *save_sv)
1433 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1434 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1438 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1440 /* Are we fetching a signal entry? */
1441 int i = (I16)mg->mg_private;
1443 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1447 const char * sig = MgPV_const(mg, siglen);
1448 mg->mg_private = i = whichsig_pvn(sig, siglen);
1453 sv_setsv(sv,PL_psig_ptr[i]);
1455 Sighandler_t sigstate = rsignal_state(i);
1456 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1457 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1460 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1461 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1464 /* cache state so we don't fetch it again */
1465 if(sigstate == (Sighandler_t) SIG_IGN)
1466 sv_setpvs(sv,"IGNORE");
1469 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1476 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1480 magic_setsig(NULL, mg);
1481 return sv_unmagic(sv, mg->mg_type);
1485 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1486 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1488 Perl_csighandler(int sig)
1491 #ifdef PERL_GET_SIG_CONTEXT
1492 dTHXa(PERL_GET_SIG_CONTEXT);
1496 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1497 #if defined(__cplusplus) && defined(__GNUC__)
1498 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1499 * parameters would be warned about. */
1500 PERL_UNUSED_ARG(sip);
1501 PERL_UNUSED_ARG(uap);
1504 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1505 (void) rsignal(sig, PL_csighandlerp);
1506 if (PL_sig_ignoring[sig]) return;
1508 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1509 if (PL_sig_defaulting[sig])
1510 #ifdef KILL_BY_SIGPRC
1511 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1526 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1527 /* Call the perl level handler now--
1528 * with risk we may be in malloc() or being destructed etc. */
1529 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1530 (*PL_sighandlerp)(sig, NULL, NULL);
1532 (*PL_sighandlerp)(sig);
1535 if (!PL_psig_pend) return;
1536 /* Set a flag to say this signal is pending, that is awaiting delivery after
1537 * the current Perl opcode completes */
1538 PL_psig_pend[sig]++;
1540 #ifndef SIG_PENDING_DIE_COUNT
1541 # define SIG_PENDING_DIE_COUNT 120
1543 /* Add one to say _a_ signal is pending */
1544 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1545 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1546 (unsigned long)SIG_PENDING_DIE_COUNT);
1550 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1552 Perl_csighandler_init(void)
1555 if (PL_sig_handlers_initted) return;
1557 for (sig = 1; sig < SIG_SIZE; sig++) {
1558 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1560 PL_sig_defaulting[sig] = 1;
1561 (void) rsignal(sig, PL_csighandlerp);
1563 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1564 PL_sig_ignoring[sig] = 0;
1567 PL_sig_handlers_initted = 1;
1571 #if defined HAS_SIGPROCMASK
1573 unblock_sigmask(pTHX_ void* newset)
1575 PERL_UNUSED_CONTEXT;
1576 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1581 Perl_despatch_signals(pTHX)
1585 for (sig = 1; sig < SIG_SIZE; sig++) {
1586 if (PL_psig_pend[sig]) {
1588 #ifdef HAS_SIGPROCMASK
1589 /* From sigaction(2) (FreeBSD man page):
1590 * | Signal routines normally execute with the signal that
1591 * | caused their invocation blocked, but other signals may
1593 * Emulation of this behavior (from within Perl) is enabled
1597 sigset_t newset, oldset;
1599 sigemptyset(&newset);
1600 sigaddset(&newset, sig);
1601 sigprocmask(SIG_BLOCK, &newset, &oldset);
1602 was_blocked = sigismember(&oldset, sig);
1604 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1606 SAVEFREESV(save_sv);
1607 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1610 PL_psig_pend[sig] = 0;
1611 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1612 (*PL_sighandlerp)(sig, NULL, NULL);
1614 (*PL_sighandlerp)(sig);
1616 #ifdef HAS_SIGPROCMASK
1625 /* sv of NULL signifies that we're acting as magic_clearsig. */
1627 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1632 /* Need to be careful with SvREFCNT_dec(), because that can have side
1633 * effects (due to closures). We must make sure that the new disposition
1634 * is in place before it is called.
1638 #ifdef HAS_SIGPROCMASK
1642 const char *s = MgPV_const(mg,len);
1644 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1647 if (memEQs(s, len, "__DIE__"))
1649 else if (memEQs(s, len, "__WARN__")
1650 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1651 /* Merge the existing behaviours, which are as follows:
1652 magic_setsig, we always set svp to &PL_warnhook
1653 (hence we always change the warnings handler)
1654 For magic_clearsig, we don't change the warnings handler if it's
1655 set to the &PL_warnhook. */
1658 SV *tmp = sv_newmortal();
1659 Perl_croak(aTHX_ "No such hook: %s",
1660 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1664 if (*svp != PERL_WARNHOOK_FATAL)
1670 i = (I16)mg->mg_private;
1672 i = whichsig_pvn(s, len); /* ...no, a brick */
1673 mg->mg_private = (U16)i;
1677 SV *tmp = sv_newmortal();
1678 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1679 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1683 #ifdef HAS_SIGPROCMASK
1684 /* Avoid having the signal arrive at a bad time, if possible. */
1687 sigprocmask(SIG_BLOCK, &set, &save);
1689 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1690 SAVEFREESV(save_sv);
1691 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1694 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1695 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1697 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1698 PL_sig_ignoring[i] = 0;
1700 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1701 PL_sig_defaulting[i] = 0;
1703 to_dec = PL_psig_ptr[i];
1705 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1706 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1708 /* Signals don't change name during the program's execution, so once
1709 they're cached in the appropriate slot of PL_psig_name, they can
1712 Ideally we'd find some way of making SVs at (C) compile time, or
1713 at least, doing most of the work. */
1714 if (!PL_psig_name[i]) {
1715 PL_psig_name[i] = newSVpvn(s, len);
1716 SvREADONLY_on(PL_psig_name[i]);
1719 SvREFCNT_dec(PL_psig_name[i]);
1720 PL_psig_name[i] = NULL;
1721 PL_psig_ptr[i] = NULL;
1724 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1726 (void)rsignal(i, PL_csighandlerp);
1729 *svp = SvREFCNT_inc_simple_NN(sv);
1731 if (sv && SvOK(sv)) {
1732 s = SvPV_force(sv, len);
1736 if (sv && memEQs(s, len,"IGNORE")) {
1738 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1739 PL_sig_ignoring[i] = 1;
1740 (void)rsignal(i, PL_csighandlerp);
1742 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1746 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1748 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1749 PL_sig_defaulting[i] = 1;
1750 (void)rsignal(i, PL_csighandlerp);
1752 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1758 * We should warn if HINT_STRICT_REFS, but without
1759 * access to a known hint bit in a known OP, we can't
1760 * tell whether HINT_STRICT_REFS is in force or not.
1762 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1763 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1766 (void)rsignal(i, PL_csighandlerp);
1768 *svp = SvREFCNT_inc_simple_NN(sv);
1772 #ifdef HAS_SIGPROCMASK
1776 SvREFCNT_dec(to_dec);
1779 #endif /* !PERL_MICRO */
1782 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1784 PERL_ARGS_ASSERT_MAGIC_SETISA;
1785 PERL_UNUSED_ARG(sv);
1787 /* Skip _isaelem because _isa will handle it shortly */
1788 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1791 return magic_clearisa(NULL, mg);
1794 /* sv of NULL signifies that we're acting as magic_setisa. */
1796 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1799 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1801 /* Bail out if destruction is going on */
1802 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1805 av_clear(MUTABLE_AV(sv));
1807 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1808 /* This occurs with setisa_elem magic, which calls this
1810 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1813 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1814 SV **svp = AvARRAY((AV *)mg->mg_obj);
1815 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1817 stash = GvSTASH((GV *)*svp++);
1818 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1825 (const GV *)mg->mg_obj
1828 /* The stash may have been detached from the symbol table, so check its
1829 name before doing anything. */
1830 if (stash && HvENAME_get(stash))
1831 mro_isa_changed_in(stash);
1837 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1839 HV * const hv = MUTABLE_HV(LvTARG(sv));
1842 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1843 PERL_UNUSED_ARG(mg);
1846 (void) hv_iterinit(hv);
1847 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1850 while (hv_iternext(hv))
1855 sv_setiv(sv, (IV)i);
1860 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1862 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1863 PERL_UNUSED_ARG(mg);
1865 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1871 =for apidoc magic_methcall
1873 Invoke a magic method (like FETCH).
1875 C<sv> and C<mg> are the tied thingy and the tie magic.
1877 C<meth> is the name of the method to call.
1879 C<argc> is the number of args (in addition to $self) to pass to the method.
1881 The C<flags> can be:
1883 G_DISCARD invoke method with G_DISCARD flag and don't
1885 G_UNDEF_FILL fill the stack with argc pointers to
1888 The arguments themselves are any values following the C<flags> argument.
1890 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1897 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1903 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1907 if (flags & G_WRITING_TO_STDERR) {
1911 SAVESPTR(PL_stderrgv);
1915 PUSHSTACKi(PERLSI_MAGIC);
1918 /* EXTEND() expects a signed argc; don't wrap when casting */
1919 assert(argc <= I32_MAX);
1920 EXTEND(SP, (I32)argc+1);
1921 PUSHs(SvTIED_obj(sv, mg));
1922 if (flags & G_UNDEF_FILL) {
1924 PUSHs(&PL_sv_undef);
1926 } else if (argc > 0) {
1928 va_start(args, argc);
1931 SV *const sv = va_arg(args, SV *);
1938 if (flags & G_DISCARD) {
1939 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1942 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1943 ret = *PL_stack_sp--;
1946 if (flags & G_WRITING_TO_STDERR)
1952 /* wrapper for magic_methcall that creates the first arg */
1955 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1960 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1963 if (mg->mg_len >= 0) {
1964 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1966 else if (mg->mg_len == HEf_SVKEY)
1967 arg1 = MUTABLE_SV(mg->mg_ptr);
1969 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1970 arg1 = newSViv((IV)(mg->mg_len));
1974 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1976 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1980 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1984 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1986 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1993 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1995 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1997 if (mg->mg_type == PERL_MAGIC_tiedelem)
1998 mg->mg_flags |= MGf_GSKIP;
1999 magic_methpack(sv,mg,SV_CONST(FETCH));
2004 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2009 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2011 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2012 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2013 * public flags indicate its value based on copying from $val. Doing
2014 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2015 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2016 * wrong if $val happened to be tainted, as sv hasn't got magic
2017 * enabled, even though taint magic is in the chain. In which case,
2018 * fake up a temporary tainted value (this is easier than temporarily
2019 * re-enabling magic on sv). */
2021 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2022 && (tmg->mg_len & 1))
2024 val = sv_mortalcopy(sv);
2030 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2035 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2037 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2039 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2040 return magic_methpack(sv,mg,SV_CONST(DELETE));
2045 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2050 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2052 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2054 retval = SvIV(retsv)-1;
2056 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2058 return (U32) retval;
2062 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2064 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2066 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2071 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2075 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2077 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2078 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2085 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2087 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2089 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2093 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2096 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2097 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2099 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2101 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2103 if (HvEITER_get(hv))
2104 /* we are in an iteration so the hash cannot be empty */
2106 /* no xhv_eiter so now use FIRSTKEY */
2107 key = sv_newmortal();
2108 magic_nextpack(MUTABLE_SV(hv), mg, key);
2109 HvEITER_set(hv, NULL); /* need to reset iterator */
2110 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2113 /* there is a SCALAR method that we can call */
2114 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2116 retval = &PL_sv_undef;
2121 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2125 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2127 /* The magic ptr/len for the debugger's hash should always be an SV. */
2128 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2129 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2130 (IV)mg->mg_len, mg->mg_ptr);
2133 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2134 setting/clearing debugger breakpoints is not a hot path. */
2135 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2136 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2138 if (svp && SvIOKp(*svp)) {
2139 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2141 #ifdef PERL_DEBUG_READONLY_OPS
2142 Slab_to_rw(OpSLAB(o));
2144 /* set or clear breakpoint in the relevant control op */
2146 o->op_flags |= OPf_SPECIAL;
2148 o->op_flags &= ~OPf_SPECIAL;
2149 #ifdef PERL_DEBUG_READONLY_OPS
2150 Slab_to_ro(OpSLAB(o));
2158 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2160 AV * const obj = MUTABLE_AV(mg->mg_obj);
2162 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2165 sv_setiv(sv, AvFILL(obj));
2173 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2175 AV * const obj = MUTABLE_AV(mg->mg_obj);
2177 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2180 av_fill(obj, SvIV(sv));
2182 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2183 "Attempt to set length of freed array");
2189 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2191 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2192 PERL_UNUSED_ARG(sv);
2193 PERL_UNUSED_CONTEXT;
2195 /* Reset the iterator when the array is cleared */
2196 if (sizeof(IV) == sizeof(SSize_t)) {
2197 *((IV *) &(mg->mg_len)) = 0;
2200 *((IV *) mg->mg_ptr) = 0;
2207 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2209 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2210 PERL_UNUSED_ARG(sv);
2212 /* during global destruction, mg_obj may already have been freed */
2213 if (PL_in_clean_all)
2216 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2219 /* arylen scalar holds a pointer back to the array, but doesn't own a
2220 reference. Hence the we (the array) are about to go away with it
2221 still pointing at us. Clear its pointer, else it would be pointing
2222 at free memory. See the comment in sv_magic about reference loops,
2223 and why it can't own a reference to us. */
2230 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2232 SV* const lsv = LvTARG(sv);
2233 MAGIC * const found = mg_find_mglob(lsv);
2235 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2236 PERL_UNUSED_ARG(mg);
2238 if (found && found->mg_len != -1) {
2239 STRLEN i = found->mg_len;
2240 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2241 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2250 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2252 SV* const lsv = LvTARG(sv);
2258 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2259 PERL_UNUSED_ARG(mg);
2261 found = mg_find_mglob(lsv);
2265 found = sv_magicext_mglob(lsv);
2267 else if (!SvOK(sv)) {
2271 s = SvPV_const(lsv, len);
2276 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2286 else if (pos > (SSize_t)len)
2289 found->mg_len = pos;
2290 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2296 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2299 SV * const lsv = LvTARG(sv);
2300 const char * const tmps = SvPV_const(lsv,len);
2301 STRLEN offs = LvTARGOFF(sv);
2302 STRLEN rem = LvTARGLEN(sv);
2303 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2304 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2306 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2307 PERL_UNUSED_ARG(mg);
2309 if (!translate_substr_offsets(
2310 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2311 negoff ? -(IV)offs : (IV)offs, !negoff,
2312 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2314 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2320 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2321 sv_setpvn(sv, tmps + offs, rem);
2328 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2330 STRLEN len, lsv_len, oldtarglen, newtarglen;
2331 const char * const tmps = SvPV_const(sv, len);
2332 SV * const lsv = LvTARG(sv);
2333 STRLEN lvoff = LvTARGOFF(sv);
2334 STRLEN lvlen = LvTARGLEN(sv);
2335 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2336 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2338 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2339 PERL_UNUSED_ARG(mg);
2343 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2344 "Attempt to use reference as lvalue in substr"
2346 SvPV_force_nomg(lsv,lsv_len);
2347 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2348 if (!translate_substr_offsets(
2350 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2351 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2353 Perl_croak(aTHX_ "substr outside of string");
2356 sv_utf8_upgrade_nomg(lsv);
2357 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2358 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2359 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2362 else if (SvUTF8(lsv)) {
2364 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2366 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2367 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2371 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2374 if (!neglen) LvTARGLEN(sv) = newtarglen;
2375 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2381 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2383 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2384 PERL_UNUSED_ARG(sv);
2385 #ifdef NO_TAINT_SUPPORT
2386 PERL_UNUSED_ARG(mg);
2389 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2394 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2396 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2397 PERL_UNUSED_ARG(sv);
2399 /* update taint status */
2408 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2410 SV * const lsv = LvTARG(sv);
2411 char errflags = LvFLAGS(sv);
2413 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2414 PERL_UNUSED_ARG(mg);
2416 /* non-zero errflags implies deferred out-of-range condition */
2417 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2418 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2424 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2426 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2427 PERL_UNUSED_ARG(mg);
2428 do_vecset(sv); /* XXX slurp this routine */
2433 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2436 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2437 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2439 if (LvTARGLEN(sv)) {
2441 SV * const ahv = LvTARG(sv);
2442 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2446 else if (LvSTARGOFF(sv) >= 0) {
2447 AV *const av = MUTABLE_AV(LvTARG(sv));
2448 if (LvSTARGOFF(sv) <= AvFILL(av))
2450 if (SvRMAGICAL(av)) {
2451 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2452 targ = svp ? *svp : NULL;
2455 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2458 if (targ && (targ != &PL_sv_undef)) {
2459 /* somebody else defined it for us */
2460 SvREFCNT_dec(LvTARG(sv));
2461 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2463 SvREFCNT_dec(mg->mg_obj);
2465 mg->mg_flags &= ~MGf_REFCOUNTED;
2474 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2476 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2478 sv_setsv(sv, defelem_target(sv, mg));
2483 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2485 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2486 PERL_UNUSED_ARG(mg);
2490 sv_setsv(LvTARG(sv), sv);
2491 SvSETMAGIC(LvTARG(sv));
2497 Perl_vivify_defelem(pTHX_ SV *sv)
2502 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2504 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2507 SV * const ahv = LvTARG(sv);
2508 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2511 if (!value || value == &PL_sv_undef)
2512 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2514 else if (LvSTARGOFF(sv) < 0)
2515 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2517 AV *const av = MUTABLE_AV(LvTARG(sv));
2518 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2519 LvTARG(sv) = NULL; /* array can't be extended */
2521 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2522 if (!svp || !(value = *svp))
2523 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2526 SvREFCNT_inc_simple_void(value);
2527 SvREFCNT_dec(LvTARG(sv));
2530 SvREFCNT_dec(mg->mg_obj);
2532 mg->mg_flags &= ~MGf_REFCOUNTED;
2536 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2538 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2539 PERL_UNUSED_ARG(mg);
2540 sv_unmagic(sv, PERL_MAGIC_nonelem);
2545 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2547 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2548 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2553 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2555 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2556 PERL_UNUSED_CONTEXT;
2557 PERL_UNUSED_ARG(sv);
2563 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2565 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2567 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2569 if (uf && uf->uf_set)
2570 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2575 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2577 const char type = mg->mg_type;
2579 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2581 assert( type == PERL_MAGIC_fm
2582 || type == PERL_MAGIC_qr
2583 || type == PERL_MAGIC_bm);
2584 return sv_unmagic(sv, type);
2587 #ifdef USE_LOCALE_COLLATE
2589 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2591 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2594 * RenE<eacute> Descartes said "I think not."
2595 * and vanished with a faint plop.
2597 PERL_UNUSED_CONTEXT;
2598 PERL_UNUSED_ARG(sv);
2600 Safefree(mg->mg_ptr);
2606 #endif /* USE_LOCALE_COLLATE */
2608 /* Just clear the UTF-8 cache data. */
2610 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2612 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2613 PERL_UNUSED_CONTEXT;
2614 PERL_UNUSED_ARG(sv);
2615 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2617 mg->mg_len = -1; /* The mg_len holds the len cache. */
2622 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2624 const char *bad = NULL;
2625 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2626 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2627 switch (mg->mg_private & OPpLVREF_TYPE) {
2629 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2633 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2637 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2641 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2645 /* diag_listed_as: Assigned value is not %s reference */
2646 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2647 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2650 SV * const old = PAD_SV(mg->mg_len);
2651 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2656 gv_setref(mg->mg_obj, sv);
2657 SvSETMAGIC(mg->mg_obj);
2660 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2661 SvREFCNT_inc_simple_NN(SvRV(sv)));
2664 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2665 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2667 if (mg->mg_flags & MGf_PERSIST)
2668 NOOP; /* This sv is in use as an iterator var and will be reused,
2669 so we must leave the magic. */
2671 /* This sv could be returned by the assignment op, so clear the
2672 magic, as lvrefs are an implementation detail that must not be
2673 leaked to the user. */
2674 sv_unmagic(sv, PERL_MAGIC_lvref);
2679 S_set_dollarzero(pTHX_ SV *sv)
2680 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2687 #ifdef HAS_SETPROCTITLE
2688 /* The BSDs don't show the argv[] in ps(1) output, they
2689 * show a string from the process struct and provide
2690 * the setproctitle() routine to manipulate that. */
2691 if (PL_origalen != 1) {
2692 s = SvPV_const(sv, len);
2693 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2694 /* The leading "-" removes the "perl: " prefix,
2695 * but not the "(perl) suffix from the ps(1)
2696 * output, because that's what ps(1) shows if the
2697 * argv[] is modified. */
2698 setproctitle("-%s", s);
2699 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2700 /* This doesn't really work if you assume that
2701 * $0 = 'foobar'; will wipe out 'perl' from the $0
2702 * because in ps(1) output the result will be like
2703 * sprintf("perl: %s (perl)", s)
2704 * I guess this is a security feature:
2705 * one (a user process) cannot get rid of the original name.
2707 setproctitle("%s", s);
2710 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2711 if (PL_origalen != 1) {
2713 s = SvPV_const(sv, len);
2714 un.pst_command = (char *)s;
2715 pstat(PSTAT_SETCMD, un, len, 0, 0);
2718 if (PL_origalen > 1) {
2720 /* PL_origalen is set in perl_parse(). */
2721 s = SvPV_force(sv,len);
2722 if (len >= (STRLEN)PL_origalen-1) {
2723 /* Longer than original, will be truncated. We assume that
2724 * PL_origalen bytes are available. */
2725 Copy(s, PL_origargv[0], PL_origalen-1, char);
2728 /* Shorter than original, will be padded. */
2730 /* Special case for Mac OS X: see [perl #38868] */
2733 /* Is the space counterintuitive? Yes.
2734 * (You were expecting \0?)
2735 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2737 const int pad = ' ';
2739 Copy(s, PL_origargv[0], len, char);
2740 PL_origargv[0][len] = 0;
2741 memset(PL_origargv[0] + len + 1,
2742 pad, PL_origalen - len - 1);
2744 PL_origargv[0][PL_origalen-1] = 0;
2745 for (i = 1; i < PL_origargc; i++)
2747 #ifdef HAS_PRCTL_SET_NAME
2748 /* Set the legacy process name in addition to the POSIX name on Linux */
2749 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2750 /* diag_listed_as: SKIPME */
2751 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2759 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2770 PERL_ARGS_ASSERT_MAGIC_SET;
2774 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2776 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2778 /* Croak with a READONLY error when a numbered match var is
2779 * set without a previous pattern match. Unless it's C<local $1>
2782 if (!PL_localizing) {
2783 Perl_croak_no_modify();
2789 switch (*mg->mg_ptr) {
2790 case '\001': /* ^A */
2791 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2792 else SvOK_off(PL_bodytarget);
2793 FmLINES(PL_bodytarget) = 0;
2794 if (SvPOK(PL_bodytarget)) {
2795 char *s = SvPVX(PL_bodytarget);
2796 char *e = SvEND(PL_bodytarget);
2797 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2798 FmLINES(PL_bodytarget)++;
2802 /* mg_set() has temporarily made sv non-magical */
2804 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2805 SvTAINTED_on(PL_bodytarget);
2807 SvTAINTED_off(PL_bodytarget);
2810 case '\003': /* ^C */
2811 PL_minus_c = cBOOL(SvIV(sv));
2814 case '\004': /* ^D */
2817 const char *s = SvPV_nolen_const(sv);
2818 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2819 if (DEBUG_x_TEST || DEBUG_B_TEST)
2820 dump_all_perl(!DEBUG_B_TEST);
2823 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2826 case '\005': /* ^E */
2827 if (*(mg->mg_ptr+1) == '\0') {
2829 set_vaxc_errno(SvIV(sv));
2830 #elif defined(WIN32)
2831 SetLastError( SvIV(sv) );
2833 os2_setsyserrno(SvIV(sv));
2835 /* will anyone ever use this? */
2836 SETERRNO(SvIV(sv), 4);
2839 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2840 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2842 case '\006': /* ^F */
2843 PL_maxsysfd = SvIV(sv);
2845 case '\010': /* ^H */
2847 U32 save_hints = PL_hints;
2848 PL_hints = SvUV(sv);
2850 /* If wasn't UTF-8, and now is, notify the parser */
2851 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2852 notify_parser_that_changed_to_utf8();
2856 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2857 Safefree(PL_inplace);
2858 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2860 case '\016': /* ^N */
2861 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2862 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2864 case '\017': /* ^O */
2865 if (*(mg->mg_ptr+1) == '\0') {
2866 Safefree(PL_osname);
2869 TAINT_PROPER("assigning to $^O");
2870 PL_osname = savesvpv(sv);
2873 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2875 const char *const start = SvPV(sv, len);
2876 const char *out = (const char*)memchr(start, '\0', len);
2880 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2881 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2883 /* Opening for input is more common than opening for output, so
2884 ensure that hints for input are sooner on linked list. */
2885 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2887 : newSVpvs_flags("", SvUTF8(sv));
2888 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2891 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2893 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2897 case '\020': /* ^P */
2898 PL_perldb = SvIV(sv);
2899 if (PL_perldb && !PL_DBsingle)
2902 case '\024': /* ^T */
2904 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2906 PL_basetime = (Time_t)SvIV(sv);
2909 case '\025': /* ^UTF8CACHE */
2910 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2911 PL_utf8cache = (signed char) sv_2iv(sv);
2914 case '\027': /* ^W & $^WARNING_BITS */
2915 if (*(mg->mg_ptr+1) == '\0') {
2916 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2918 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2919 | (i ? G_WARN_ON : G_WARN_OFF) ;
2922 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2923 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2925 if (!specialWARN(PL_compiling.cop_warnings))
2926 PerlMemShared_free(PL_compiling.cop_warnings);
2927 PL_compiling.cop_warnings = pWARN_STD;
2932 int not_none = 0, not_all = 0;
2933 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2934 for (i = 0 ; i < len ; ++i) {
2936 not_all |= ptr[i] ^ 0x55;
2939 if (!specialWARN(PL_compiling.cop_warnings))
2940 PerlMemShared_free(PL_compiling.cop_warnings);
2941 PL_compiling.cop_warnings = pWARN_NONE;
2942 } else if (len >= WARNsize && !not_all) {
2943 if (!specialWARN(PL_compiling.cop_warnings))
2944 PerlMemShared_free(PL_compiling.cop_warnings);
2945 PL_compiling.cop_warnings = pWARN_ALL;
2946 PL_dowarn |= G_WARN_ONCE ;
2950 const char *const p = SvPV_const(sv, len);
2952 PL_compiling.cop_warnings
2953 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2956 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2957 PL_dowarn |= G_WARN_ONCE ;
2964 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2965 w32_sloppystat = (bool)sv_true(sv);
2970 if (PL_localizing) {
2971 if (PL_localizing == 1)
2972 SAVESPTR(PL_last_in_gv);
2974 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2975 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2978 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2979 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2980 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2983 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2984 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2985 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2988 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2991 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2992 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2993 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2996 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3000 IO * const io = GvIO(PL_defoutgv);
3003 if ((SvIV(sv)) == 0)
3004 IoFLAGS(io) &= ~IOf_FLUSH;
3006 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3007 PerlIO *ofp = IoOFP(io);
3009 (void)PerlIO_flush(ofp);
3010 IoFLAGS(io) |= IOf_FLUSH;
3018 SV *referent = SvRV(sv);
3019 const char *reftype = sv_reftype(referent, 0);
3020 /* XXX: dodgy type check: This leaves me feeling dirty, but
3021 * the alternative is to copy pretty much the entire
3022 * sv_reftype() into this routine, or to do a full string
3023 * comparison on the return of sv_reftype() both of which
3024 * make me feel worse! NOTE, do not modify this comment
3025 * without reviewing the corresponding comment in
3026 * sv_reftype(). - Yves */
3027 if (reftype[0] == 'S' || reftype[0] == 'L') {
3028 IV val = SvIV(referent);
3030 sv_setsv(sv, PL_rs);
3031 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3032 val < 0 ? "a negative integer" : "zero");
3035 sv_setsv(sv, PL_rs);
3036 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3037 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3038 *reftype == 'A' ? "n" : "", reftype);
3041 SvREFCNT_dec(PL_rs);
3042 PL_rs = newSVsv(sv);
3046 SvREFCNT_dec(PL_ors_sv);
3048 PL_ors_sv = newSVsv(sv);
3056 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3059 #ifdef COMPLEX_STATUS
3060 if (PL_localizing == 2) {
3061 SvUPGRADE(sv, SVt_PVLV);
3062 PL_statusvalue = LvTARGOFF(sv);
3063 PL_statusvalue_vms = LvTARGLEN(sv);
3067 #ifdef VMSISH_STATUS
3069 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3072 STATUS_UNIX_EXIT_SET(SvIV(sv));
3077 # define PERL_VMS_BANG vaxc$errno
3079 # define PERL_VMS_BANG 0
3082 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3083 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3085 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3086 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3092 /* XXX $< currently silently ignores failures */
3093 const Uid_t new_uid = SvUID(sv);
3094 PL_delaymagic_uid = new_uid;
3095 if (PL_delaymagic) {
3096 PL_delaymagic |= DM_RUID;
3097 break; /* don't do magic till later */
3100 PERL_UNUSED_RESULT(setruid(new_uid));
3101 #elif defined(HAS_SETREUID)
3102 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3103 #elif defined(HAS_SETRESUID)
3104 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3106 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3108 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3109 if (new_uid != 0 && PerlProc_getuid() == 0)
3110 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3112 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3114 Perl_croak(aTHX_ "setruid() not implemented");
3121 /* XXX $> currently silently ignores failures */
3122 const Uid_t new_euid = SvUID(sv);
3123 PL_delaymagic_euid = new_euid;
3124 if (PL_delaymagic) {
3125 PL_delaymagic |= DM_EUID;
3126 break; /* don't do magic till later */
3129 PERL_UNUSED_RESULT(seteuid(new_euid));
3130 #elif defined(HAS_SETREUID)
3131 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3132 #elif defined(HAS_SETRESUID)
3133 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3135 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3136 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3138 Perl_croak(aTHX_ "seteuid() not implemented");
3145 /* XXX $( currently silently ignores failures */
3146 const Gid_t new_gid = SvGID(sv);
3147 PL_delaymagic_gid = new_gid;
3148 if (PL_delaymagic) {
3149 PL_delaymagic |= DM_RGID;
3150 break; /* don't do magic till later */
3153 PERL_UNUSED_RESULT(setrgid(new_gid));
3154 #elif defined(HAS_SETREGID)
3155 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3156 #elif defined(HAS_SETRESGID)
3157 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3159 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3160 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3162 Perl_croak(aTHX_ "setrgid() not implemented");
3169 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3170 * but you can override it if you need to.
3173 #define INVALID_GID ((Gid_t)-1)
3175 /* XXX $) currently silently ignores failures */
3177 #ifdef HAS_SETGROUPS
3179 const char *p = SvPV_const(sv, len);
3180 Groups_t *gary = NULL;
3181 const char* p_end = p + len;
3182 const char* endptr = p_end;
3184 #ifdef _SC_NGROUPS_MAX
3185 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3190 int maxgrp = NGROUPS;
3195 if (grok_atoUV(p, &uv, &endptr))
3196 new_egid = (Gid_t)uv;
3198 new_egid = INVALID_GID;
3201 for (i = 0; i < maxgrp; ++i) {
3211 Newx(gary, i + 1, Groups_t);
3213 Renew(gary, i + 1, Groups_t);
3214 if (grok_atoUV(p, &uv, &endptr))
3215 gary[i] = (Groups_t)uv;
3217 gary[i] = INVALID_GID;
3222 PERL_UNUSED_RESULT(setgroups(i, gary));
3225 #else /* HAS_SETGROUPS */
3226 new_egid = SvGID(sv);
3227 #endif /* HAS_SETGROUPS */
3228 PL_delaymagic_egid = new_egid;
3229 if (PL_delaymagic) {
3230 PL_delaymagic |= DM_EGID;
3231 break; /* don't do magic till later */
3234 PERL_UNUSED_RESULT(setegid(new_egid));
3235 #elif defined(HAS_SETREGID)
3236 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3237 #elif defined(HAS_SETRESGID)
3238 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3240 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3241 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3243 Perl_croak(aTHX_ "setegid() not implemented");
3249 PL_chopset = SvPV_force(sv,len);
3252 /* Store the pid in mg->mg_obj so we can tell when a fork has
3253 occurred. mg->mg_obj points to *$ by default, so clear it. */
3254 if (isGV(mg->mg_obj)) {
3255 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3256 SvREFCNT_dec(mg->mg_obj);
3257 mg->mg_flags |= MGf_REFCOUNTED;
3258 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3260 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3263 LOCK_DOLLARZERO_MUTEX;
3264 S_set_dollarzero(aTHX_ sv);
3265 UNLOCK_DOLLARZERO_MUTEX;
3272 Perl_whichsig_sv(pTHX_ SV *sigsv)
3276 PERL_ARGS_ASSERT_WHICHSIG_SV;
3277 sigpv = SvPV_const(sigsv, siglen);
3278 return whichsig_pvn(sigpv, siglen);
3282 Perl_whichsig_pv(pTHX_ const char *sig)
3284 PERL_ARGS_ASSERT_WHICHSIG_PV;
3285 return whichsig_pvn(sig, strlen(sig));
3289 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3293 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3294 PERL_UNUSED_CONTEXT;
3296 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3297 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3298 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3300 if (memEQs(sig, len, "CHLD"))
3304 if (memEQs(sig, len, "CLD"))
3311 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3312 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3314 Perl_sighandler(int sig)
3317 #ifdef PERL_GET_SIG_CONTEXT
3318 dTHXa(PERL_GET_SIG_CONTEXT);
3325 SV * const tSv = PL_Sv;
3329 XPV * const tXpv = PL_Xpv;
3330 I32 old_ss_ix = PL_savestack_ix;
3331 SV *errsv_save = NULL;
3334 if (!PL_psig_ptr[sig]) {
3335 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3340 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3341 /* Max number of items pushed there is 3*n or 4. We cannot fix
3342 infinity, so we fix 4 (in fact 5): */
3343 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3345 PL_savestack_ix += 5; /* Protect save in progress. */
3346 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3349 /* sv_2cv is too complicated, try a simpler variant first: */
3350 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3351 || SvTYPE(cv) != SVt_PVCV) {
3353 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3356 if (!cv || !CvROOT(cv)) {
3357 const HEK * const hek = gv
3361 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3363 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3364 "SIG%s handler \"%" HEKf "\" not defined.\n",
3365 PL_sig_name[sig], HEKfARG(hek));
3366 /* diag_listed_as: SIG%s handler "%s" not defined */
3367 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3368 "SIG%s handler \"__ANON__\" not defined.\n",
3373 sv = PL_psig_name[sig]
3374 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3375 : newSVpv(PL_sig_name[sig],0);
3379 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3380 /* make sure our assumption about the size of the SAVEs are correct:
3381 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3382 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3385 PUSHSTACKi(PERLSI_SIGNAL);
3388 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3390 struct sigaction oact;
3392 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3395 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3396 /* The siginfo fields signo, code, errno, pid, uid,
3397 * addr, status, and band are defined by POSIX/SUSv3. */
3398 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3399 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3400 #ifdef HAS_SIGINFO_SI_ERRNO
3401 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3403 #ifdef HAS_SIGINFO_SI_STATUS
3404 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3406 #ifdef HAS_SIGINFO_SI_UID
3409 sv_setuid(uid, sip->si_uid);
3410 (void)hv_stores(sih, "uid", uid);
3413 #ifdef HAS_SIGINFO_SI_PID
3414 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3416 #ifdef HAS_SIGINFO_SI_ADDR
3417 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3419 #ifdef HAS_SIGINFO_SI_BAND
3420 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3424 mPUSHp((char *)sip, sizeof(*sip));
3432 errsv_save = newSVsv(ERRSV);
3434 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3438 SV * const errsv = ERRSV;
3439 if (SvTRUE_NN(errsv)) {
3440 SvREFCNT_dec(errsv_save);
3442 /* Handler "died", for example to get out of a restart-able read().
3443 * Before we re-do that on its behalf re-enable the signal which was
3444 * blocked by the system when we entered.
3446 #ifdef HAS_SIGPROCMASK
3447 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3453 sigaddset(&set,sig);
3454 sigprocmask(SIG_UNBLOCK, &set, NULL);
3457 /* Not clear if this will work */
3458 (void)rsignal(sig, SIG_IGN);
3459 (void)rsignal(sig, PL_csighandlerp);
3461 #endif /* !PERL_MICRO */
3465 sv_setsv(errsv, errsv_save);
3466 SvREFCNT_dec(errsv_save);
3471 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3472 PL_savestack_ix = old_ss_ix;
3474 SvREFCNT_dec_NN(sv);
3475 PL_op = myop; /* Apparently not needed... */
3477 PL_Sv = tSv; /* Restore global temporaries. */
3484 S_restore_magic(pTHX_ const void *p)
3486 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3487 SV* const sv = mgs->mgs_sv;
3493 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3494 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3496 SvFLAGS(sv) |= mgs->mgs_flags;
3501 bumped = mgs->mgs_bumped;
3502 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3504 /* If we're still on top of the stack, pop us off. (That condition
3505 * will be satisfied if restore_magic was called explicitly, but *not*
3506 * if it's being called via leave_scope.)
3507 * The reason for doing this is that otherwise, things like sv_2cv()
3508 * may leave alloc gunk on the savestack, and some code
3509 * (e.g. sighandler) doesn't expect that...
3511 if (PL_savestack_ix == mgs->mgs_ss_ix)
3513 UV popval = SSPOPUV;
3514 assert(popval == SAVEt_DESTRUCTOR_X);
3515 PL_savestack_ix -= 2;
3517 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3518 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3521 if (SvREFCNT(sv) == 1) {
3522 /* We hold the last reference to this SV, which implies that the
3523 SV was deleted as a side effect of the routines we called.
3524 So artificially keep it alive a bit longer.
3525 We avoid turning on the TEMP flag, which can cause the SV's
3526 buffer to get stolen (and maybe other stuff). */
3531 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3535 /* clean up the mess created by Perl_sighandler().
3536 * Note that this is only called during an exit in a signal handler;
3537 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3541 S_unwind_handler_stack(pTHX_ const void *p)
3545 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3549 =for apidoc magic_sethint
3551 Triggered by a store to C<%^H>, records the key/value pair to
3552 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3553 anything that would need a deep copy. Maybe we should warn if we find a
3559 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3561 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3562 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3564 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3566 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3567 an alternative leaf in there, with PL_compiling.cop_hints being used if
3568 it's NULL. If needed for threads, the alternative could lock a mutex,
3569 or take other more complex action. */
3571 /* Something changed in %^H, so it will need to be restored on scope exit.
3572 Doing this here saves a lot of doing it manually in perl code (and
3573 forgetting to do it, and consequent subtle errors. */
3574 PL_hints |= HINT_LOCALIZE_HH;
3575 CopHINTHASH_set(&PL_compiling,
3576 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3581 =for apidoc magic_clearhint
3583 Triggered by a delete from C<%^H>, records the key to
3584 C<PL_compiling.cop_hints_hash>.
3589 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3591 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3592 PERL_UNUSED_ARG(sv);
3594 PL_hints |= HINT_LOCALIZE_HH;
3595 CopHINTHASH_set(&PL_compiling,
3596 mg->mg_len == HEf_SVKEY
3597 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3598 MUTABLE_SV(mg->mg_ptr), 0, 0)
3599 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3600 mg->mg_ptr, mg->mg_len, 0, 0));
3605 =for apidoc magic_clearhints
3607 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3612 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3614 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3615 PERL_UNUSED_ARG(sv);
3616 PERL_UNUSED_ARG(mg);
3617 cophh_free(CopHINTHASH_get(&PL_compiling));
3618 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3623 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3624 const char *name, I32 namlen)
3628 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3629 PERL_UNUSED_ARG(sv);
3630 PERL_UNUSED_ARG(name);
3631 PERL_UNUSED_ARG(namlen);
3633 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3634 nmg = mg_find(nsv, mg->mg_type);
3636 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3637 nmg->mg_ptr = mg->mg_ptr;
3638 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3639 nmg->mg_flags |= MGf_REFCOUNTED;
3644 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3645 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3647 #if DBVARMG_SINGLE != 0
3648 assert(mg->mg_private >= DBVARMG_SINGLE);
3650 assert(mg->mg_private < DBVARMG_COUNT);
3652 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3658 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3659 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3661 #if DBVARMG_SINGLE != 0
3662 assert(mg->mg_private >= DBVARMG_SINGLE);
3664 assert(mg->mg_private < DBVARMG_COUNT);
3665 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3671 * ex: set ts=8 sts=4 sw=4 et: