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, it really is UTF-8: "text in any other encoding that
822 * uses bytes with the high bit set is extremely unlikely to pass a
823 * 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 #elif defined(USE_LOCLAE_CTYPE)
836 /* For systems that don't have a separate message category,
837 * this assumes that they follow the CTYPE one */
838 && _is_cur_LC_category_utf8(LC_CTYPE)
849 =for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv
851 Generates the message string describing an OS error and returns it as
852 an SV. C<errnum> must be a value that C<errno> could take, identifying
855 If C<tgtsv> is non-null then the string will be written into that SV
856 (overwriting existing content) and it will be returned. If C<tgtsv>
857 is a null pointer then the string will be written into a new mortal SV
858 which will be returned.
860 The message will be taken from whatever locale would be used by C<$!>,
861 and will be encoded in the SV in whatever manner would be used by C<$!>.
862 The details of this process are subject to future change. Currently,
863 the message is taken from the C locale by default (usually producing an
864 English message), and from the currently selected locale when in the scope
865 of the C<use locale> pragma. A heuristic attempt is made to decode the
866 message from the locale's character encoding, but it will only be decoded
867 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
868 locale, usually in an ISO-8859-1 locale, and never in any other locale.
870 The SV is always returned containing an actual string, and with no other
871 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
872 (meaning success), and if no useful message is available then a useless
873 string (currently empty) is returned.
879 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
883 tgtsv = sv_newmortal();
884 errstr = my_strerror(errnum);
886 sv_setpv(tgtsv, errstr);
887 fixup_errno_string(tgtsv);
900 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
903 const char *s = NULL;
905 const char * const remaining = mg->mg_ptr + 1;
908 PERL_ARGS_ASSERT_MAGIC_GET;
912 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
914 CALLREG_NUMBUF_FETCH(rx,paren,sv);
921 nextchar = *remaining;
922 switch (*mg->mg_ptr) {
923 case '\001': /* ^A */
924 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
927 if (SvTAINTED(PL_bodytarget))
930 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
931 if (nextchar == '\0') {
932 sv_setiv(sv, (IV)PL_minus_c);
934 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
935 sv_setiv(sv, (IV)STATUS_NATIVE);
939 case '\004': /* ^D */
940 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
942 case '\005': /* ^E */
943 if (nextchar != '\0') {
944 if (strEQ(remaining, "NCODING"))
949 #if defined(VMS) || defined(OS2) || defined(WIN32)
953 $DESCRIPTOR(msgdsc,msg);
954 sv_setnv(sv,(NV) vaxc$errno);
955 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
956 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
961 if (!(_emx_env & 0x200)) { /* Under DOS */
962 sv_setnv(sv, (NV)errno);
963 sv_setpv(sv, errno ? my_strerror(errno) : "");
965 if (errno != errno_isOS2) {
966 const int tmp = _syserrno();
967 if (tmp) /* 2nd call to _syserrno() makes it 0 */
970 sv_setnv(sv, (NV)Perl_rc);
971 sv_setpv(sv, os2error(Perl_rc));
973 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
974 fixup_errno_string(sv);
976 # elif defined(WIN32)
978 const DWORD dwErr = GetLastError();
979 sv_setnv(sv, (NV)dwErr);
981 PerlProc_GetOSError(sv, dwErr);
982 fixup_errno_string(sv);
989 # error Missing code for platform
992 SvNOK_on(sv); /* what a wonderful hack! */
994 #endif /* End of platforms with special handling for $^E; others just fall
1002 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1004 sv_setnv(sv, (NV)errno);
1007 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1008 sv_setpv(sv, os2error(Perl_rc));
1015 sv_string_from_errnum(errno, sv);
1016 /* If no useful string is available, don't
1017 * claim to have a string part. The SvNOK_on()
1018 * below will cause just the number part to be valid */
1026 SvNOK_on(sv); /* what a wonderful hack! */
1029 case '\006': /* ^F */
1030 sv_setiv(sv, (IV)PL_maxsysfd);
1032 case '\007': /* ^GLOBAL_PHASE */
1033 if (strEQ(remaining, "LOBAL_PHASE")) {
1034 sv_setpvn(sv, PL_phase_names[PL_phase],
1035 strlen(PL_phase_names[PL_phase]));
1038 case '\010': /* ^H */
1039 sv_setuv(sv, PL_hints);
1041 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1042 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1044 case '\014': /* ^LAST_FH */
1045 if (strEQ(remaining, "AST_FH")) {
1046 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1047 assert(isGV_with_GP(PL_last_in_gv));
1048 SV_CHECK_THINKFIRST_COW_DROP(sv);
1049 prepare_SV_for_RV(sv);
1051 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
1059 case '\017': /* ^O & ^OPEN */
1060 if (nextchar == '\0') {
1061 sv_setpv(sv, PL_osname);
1064 else if (strEQ(remaining, "PEN")) {
1065 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1069 sv_setiv(sv, (IV)PL_perldb);
1071 case '\023': /* ^S */
1073 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1075 else if (PL_in_eval)
1076 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1081 case '\024': /* ^T */
1082 if (nextchar == '\0') {
1084 sv_setnv(sv, PL_basetime);
1086 sv_setiv(sv, (IV)PL_basetime);
1089 else if (strEQ(remaining, "AINT"))
1090 sv_setiv(sv, TAINTING_get
1091 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1094 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1095 if (strEQ(remaining, "NICODE"))
1096 sv_setuv(sv, (UV) PL_unicode);
1097 else if (strEQ(remaining, "TF8LOCALE"))
1098 sv_setuv(sv, (UV) PL_utf8locale);
1099 else if (strEQ(remaining, "TF8CACHE"))
1100 sv_setiv(sv, (IV) PL_utf8cache);
1102 case '\027': /* ^W & $^WARNING_BITS */
1103 if (nextchar == '\0')
1104 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1105 else if (strEQ(remaining, "ARNING_BITS")) {
1106 if (PL_compiling.cop_warnings == pWARN_NONE) {
1107 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1109 else if (PL_compiling.cop_warnings == pWARN_STD) {
1112 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1113 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1116 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1117 *PL_compiling.cop_warnings);
1121 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
1122 sv_setiv(sv, w32_sloppystat);
1127 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1128 paren = RX_LASTPAREN(rx);
1130 goto do_numbuf_fetch;
1133 case '\016': /* ^N */
1134 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1135 paren = RX_LASTCLOSEPAREN(rx);
1137 goto do_numbuf_fetch;
1141 if (GvIO(PL_last_in_gv)) {
1142 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1147 sv_setiv(sv, (IV)STATUS_CURRENT);
1148 #ifdef COMPLEX_STATUS
1149 SvUPGRADE(sv, SVt_PVLV);
1150 LvTARGOFF(sv) = PL_statusvalue;
1151 LvTARGLEN(sv) = PL_statusvalue_vms;
1156 if (GvIOp(PL_defoutgv))
1157 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1161 sv_setpv(sv,GvENAME(PL_defoutgv));
1162 sv_catpvs(sv,"_TOP");
1166 if (GvIOp(PL_defoutgv))
1167 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1169 s = GvENAME(PL_defoutgv);
1173 if (GvIO(PL_defoutgv))
1174 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1177 if (GvIO(PL_defoutgv))
1178 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1181 if (GvIO(PL_defoutgv))
1182 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1191 if (GvIO(PL_defoutgv))
1192 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1196 sv_copypv(sv, PL_ors_sv);
1202 IV const pid = (IV)PerlProc_getpid();
1203 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1204 /* never set manually, or at least not since last fork */
1206 /* never unsafe, even if reading in a tainted expression */
1209 /* else a value has been assigned manually, so do nothing */
1213 sv_setuid(sv, PerlProc_getuid());
1216 sv_setuid(sv, PerlProc_geteuid());
1219 sv_setgid(sv, PerlProc_getgid());
1222 sv_setgid(sv, PerlProc_getegid());
1224 #ifdef HAS_GETGROUPS
1226 Groups_t *gary = NULL;
1227 I32 num_groups = getgroups(0, gary);
1228 if (num_groups > 0) {
1230 Newx(gary, num_groups, Groups_t);
1231 num_groups = getgroups(num_groups, gary);
1232 for (i = 0; i < num_groups; i++)
1233 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1237 (void)SvIOK_on(sv); /* what a wonderful hack! */
1251 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1253 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1255 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1257 if (uf && uf->uf_val)
1258 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1263 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1265 STRLEN len = 0, klen;
1266 const char * const key = MgPV_const(mg,klen);
1269 PERL_ARGS_ASSERT_MAGIC_SETENV;
1273 /* defined environment variables are byte strings; unfortunately
1274 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1275 (void)SvPV_force_nomg_nolen(sv);
1276 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1278 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1284 my_setenv(key, s); /* does the deed */
1286 #ifdef DYNAMIC_ENV_FETCH
1287 /* We just undefd an environment var. Is a replacement */
1288 /* waiting in the wings? */
1290 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1292 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1296 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
1297 /* And you'll never guess what the dog had */
1298 /* in its mouth... */
1300 MgTAINTEDDIR_off(mg);
1302 if (s && memEQs(key, klen, "DCL$PATH")) {
1303 char pathbuf[256], eltbuf[256], *cp, *elt;
1306 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1308 do { /* DCL$PATH may be a search list */
1309 while (1) { /* as may dev portion of any element */
1310 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1311 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1312 cando_by_name(S_IWUSR,0,elt) ) {
1313 MgTAINTEDDIR_on(mg);
1317 if ((cp = strchr(elt, ':')) != NULL)
1319 if (my_trnlnm(elt, eltbuf, j++))
1325 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1328 if (s && memEQs(key, klen, "PATH")) {
1329 const char * const strend = s + len;
1331 /* set MGf_TAINTEDDIR if any component of the new path is
1332 * relative or world-writeable */
1333 while (s < strend) {
1337 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1338 const char path_sep = PL_perllib_sep;
1340 const char path_sep = ':';
1342 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1343 s, strend, path_sep, &i);
1345 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1347 /* no colon thus no device name -- assume relative path */
1348 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1349 /* Using Unix separator, e.g. under bash, so act line Unix */
1350 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1352 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1354 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1355 MgTAINTEDDIR_on(mg);
1361 #endif /* neither OS2 nor WIN32 nor MSDOS */
1367 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1369 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1370 PERL_UNUSED_ARG(sv);
1371 my_setenv(MgPV_nolen_const(mg),NULL);
1376 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1378 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1379 PERL_UNUSED_ARG(mg);
1381 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1383 if (PL_localizing) {
1386 hv_iterinit(MUTABLE_HV(sv));
1387 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1389 my_setenv(hv_iterkey(entry, &keylen),
1390 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1398 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1400 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1401 PERL_UNUSED_ARG(sv);
1402 PERL_UNUSED_ARG(mg);
1404 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1412 #ifdef HAS_SIGPROCMASK
1414 restore_sigmask(pTHX_ SV *save_sv)
1416 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1417 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1421 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1423 /* Are we fetching a signal entry? */
1424 int i = (I16)mg->mg_private;
1426 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1430 const char * sig = MgPV_const(mg, siglen);
1431 mg->mg_private = i = whichsig_pvn(sig, siglen);
1436 sv_setsv(sv,PL_psig_ptr[i]);
1438 Sighandler_t sigstate = rsignal_state(i);
1439 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1440 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1443 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1444 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1447 /* cache state so we don't fetch it again */
1448 if(sigstate == (Sighandler_t) SIG_IGN)
1449 sv_setpvs(sv,"IGNORE");
1452 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1459 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1461 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1463 magic_setsig(NULL, mg);
1464 return sv_unmagic(sv, mg->mg_type);
1468 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1469 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1471 Perl_csighandler(int sig)
1474 #ifdef PERL_GET_SIG_CONTEXT
1475 dTHXa(PERL_GET_SIG_CONTEXT);
1479 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1480 #if defined(__cplusplus) && defined(__GNUC__)
1481 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1482 * parameters would be warned about. */
1483 PERL_UNUSED_ARG(sip);
1484 PERL_UNUSED_ARG(uap);
1487 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1488 (void) rsignal(sig, PL_csighandlerp);
1489 if (PL_sig_ignoring[sig]) return;
1491 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1492 if (PL_sig_defaulting[sig])
1493 #ifdef KILL_BY_SIGPRC
1494 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1509 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1510 /* Call the perl level handler now--
1511 * with risk we may be in malloc() or being destructed etc. */
1512 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1513 (*PL_sighandlerp)(sig, NULL, NULL);
1515 (*PL_sighandlerp)(sig);
1518 if (!PL_psig_pend) return;
1519 /* Set a flag to say this signal is pending, that is awaiting delivery after
1520 * the current Perl opcode completes */
1521 PL_psig_pend[sig]++;
1523 #ifndef SIG_PENDING_DIE_COUNT
1524 # define SIG_PENDING_DIE_COUNT 120
1526 /* Add one to say _a_ signal is pending */
1527 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1528 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1529 (unsigned long)SIG_PENDING_DIE_COUNT);
1533 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1535 Perl_csighandler_init(void)
1538 if (PL_sig_handlers_initted) return;
1540 for (sig = 1; sig < SIG_SIZE; sig++) {
1541 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1543 PL_sig_defaulting[sig] = 1;
1544 (void) rsignal(sig, PL_csighandlerp);
1546 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1547 PL_sig_ignoring[sig] = 0;
1550 PL_sig_handlers_initted = 1;
1554 #if defined HAS_SIGPROCMASK
1556 unblock_sigmask(pTHX_ void* newset)
1558 PERL_UNUSED_CONTEXT;
1559 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1564 Perl_despatch_signals(pTHX)
1568 for (sig = 1; sig < SIG_SIZE; sig++) {
1569 if (PL_psig_pend[sig]) {
1571 #ifdef HAS_SIGPROCMASK
1572 /* From sigaction(2) (FreeBSD man page):
1573 * | Signal routines normally execute with the signal that
1574 * | caused their invocation blocked, but other signals may
1576 * Emulation of this behavior (from within Perl) is enabled
1580 sigset_t newset, oldset;
1582 sigemptyset(&newset);
1583 sigaddset(&newset, sig);
1584 sigprocmask(SIG_BLOCK, &newset, &oldset);
1585 was_blocked = sigismember(&oldset, sig);
1587 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1589 SAVEFREESV(save_sv);
1590 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1593 PL_psig_pend[sig] = 0;
1594 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1595 (*PL_sighandlerp)(sig, NULL, NULL);
1597 (*PL_sighandlerp)(sig);
1599 #ifdef HAS_SIGPROCMASK
1608 /* sv of NULL signifies that we're acting as magic_clearsig. */
1610 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1615 /* Need to be careful with SvREFCNT_dec(), because that can have side
1616 * effects (due to closures). We must make sure that the new disposition
1617 * is in place before it is called.
1621 #ifdef HAS_SIGPROCMASK
1625 const char *s = MgPV_const(mg,len);
1627 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1630 if (memEQs(s, len, "__DIE__"))
1632 else if (memEQs(s, len, "__WARN__")
1633 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1634 /* Merge the existing behaviours, which are as follows:
1635 magic_setsig, we always set svp to &PL_warnhook
1636 (hence we always change the warnings handler)
1637 For magic_clearsig, we don't change the warnings handler if it's
1638 set to the &PL_warnhook. */
1641 SV *tmp = sv_newmortal();
1642 Perl_croak(aTHX_ "No such hook: %s",
1643 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1647 if (*svp != PERL_WARNHOOK_FATAL)
1653 i = (I16)mg->mg_private;
1655 i = whichsig_pvn(s, len); /* ...no, a brick */
1656 mg->mg_private = (U16)i;
1660 SV *tmp = sv_newmortal();
1661 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1662 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1666 #ifdef HAS_SIGPROCMASK
1667 /* Avoid having the signal arrive at a bad time, if possible. */
1670 sigprocmask(SIG_BLOCK, &set, &save);
1672 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1673 SAVEFREESV(save_sv);
1674 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1677 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1678 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1680 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1681 PL_sig_ignoring[i] = 0;
1683 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1684 PL_sig_defaulting[i] = 0;
1686 to_dec = PL_psig_ptr[i];
1688 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1689 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1691 /* Signals don't change name during the program's execution, so once
1692 they're cached in the appropriate slot of PL_psig_name, they can
1695 Ideally we'd find some way of making SVs at (C) compile time, or
1696 at least, doing most of the work. */
1697 if (!PL_psig_name[i]) {
1698 PL_psig_name[i] = newSVpvn(s, len);
1699 SvREADONLY_on(PL_psig_name[i]);
1702 SvREFCNT_dec(PL_psig_name[i]);
1703 PL_psig_name[i] = NULL;
1704 PL_psig_ptr[i] = NULL;
1707 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1709 (void)rsignal(i, PL_csighandlerp);
1712 *svp = SvREFCNT_inc_simple_NN(sv);
1714 if (sv && SvOK(sv)) {
1715 s = SvPV_force(sv, len);
1719 if (sv && memEQs(s, len,"IGNORE")) {
1721 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1722 PL_sig_ignoring[i] = 1;
1723 (void)rsignal(i, PL_csighandlerp);
1725 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1729 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1731 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1732 PL_sig_defaulting[i] = 1;
1733 (void)rsignal(i, PL_csighandlerp);
1735 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1741 * We should warn if HINT_STRICT_REFS, but without
1742 * access to a known hint bit in a known OP, we can't
1743 * tell whether HINT_STRICT_REFS is in force or not.
1745 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1746 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1749 (void)rsignal(i, PL_csighandlerp);
1751 *svp = SvREFCNT_inc_simple_NN(sv);
1755 #ifdef HAS_SIGPROCMASK
1759 SvREFCNT_dec(to_dec);
1762 #endif /* !PERL_MICRO */
1765 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1767 PERL_ARGS_ASSERT_MAGIC_SETISA;
1768 PERL_UNUSED_ARG(sv);
1770 /* Skip _isaelem because _isa will handle it shortly */
1771 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1774 return magic_clearisa(NULL, mg);
1777 /* sv of NULL signifies that we're acting as magic_setisa. */
1779 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1782 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1784 /* Bail out if destruction is going on */
1785 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1788 av_clear(MUTABLE_AV(sv));
1790 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1791 /* This occurs with setisa_elem magic, which calls this
1793 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1796 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1797 SV **svp = AvARRAY((AV *)mg->mg_obj);
1798 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1800 stash = GvSTASH((GV *)*svp++);
1801 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1808 (const GV *)mg->mg_obj
1811 /* The stash may have been detached from the symbol table, so check its
1812 name before doing anything. */
1813 if (stash && HvENAME_get(stash))
1814 mro_isa_changed_in(stash);
1820 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1822 HV * const hv = MUTABLE_HV(LvTARG(sv));
1825 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1826 PERL_UNUSED_ARG(mg);
1829 (void) hv_iterinit(hv);
1830 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1833 while (hv_iternext(hv))
1838 sv_setiv(sv, (IV)i);
1843 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1845 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1846 PERL_UNUSED_ARG(mg);
1848 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1854 =for apidoc magic_methcall
1856 Invoke a magic method (like FETCH).
1858 C<sv> and C<mg> are the tied thingy and the tie magic.
1860 C<meth> is the name of the method to call.
1862 C<argc> is the number of args (in addition to $self) to pass to the method.
1864 The C<flags> can be:
1866 G_DISCARD invoke method with G_DISCARD flag and don't
1868 G_UNDEF_FILL fill the stack with argc pointers to
1871 The arguments themselves are any values following the C<flags> argument.
1873 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1880 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1886 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1890 if (flags & G_WRITING_TO_STDERR) {
1894 SAVESPTR(PL_stderrgv);
1898 PUSHSTACKi(PERLSI_MAGIC);
1901 /* EXTEND() expects a signed argc; don't wrap when casting */
1902 assert(argc <= I32_MAX);
1903 EXTEND(SP, (I32)argc+1);
1904 PUSHs(SvTIED_obj(sv, mg));
1905 if (flags & G_UNDEF_FILL) {
1907 PUSHs(&PL_sv_undef);
1909 } else if (argc > 0) {
1911 va_start(args, argc);
1914 SV *const sv = va_arg(args, SV *);
1921 if (flags & G_DISCARD) {
1922 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1925 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1926 ret = *PL_stack_sp--;
1929 if (flags & G_WRITING_TO_STDERR)
1935 /* wrapper for magic_methcall that creates the first arg */
1938 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1943 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1946 if (mg->mg_len >= 0) {
1947 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1949 else if (mg->mg_len == HEf_SVKEY)
1950 arg1 = MUTABLE_SV(mg->mg_ptr);
1952 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1953 arg1 = newSViv((IV)(mg->mg_len));
1957 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1959 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1963 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1967 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1969 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1976 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1978 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1980 if (mg->mg_type == PERL_MAGIC_tiedelem)
1981 mg->mg_flags |= MGf_GSKIP;
1982 magic_methpack(sv,mg,SV_CONST(FETCH));
1987 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1992 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1994 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1995 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1996 * public flags indicate its value based on copying from $val. Doing
1997 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1998 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1999 * wrong if $val happened to be tainted, as sv hasn't got magic
2000 * enabled, even though taint magic is in the chain. In which case,
2001 * fake up a temporary tainted value (this is easier than temporarily
2002 * re-enabling magic on sv). */
2004 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2005 && (tmg->mg_len & 1))
2007 val = sv_mortalcopy(sv);
2013 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2018 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2020 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2022 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2023 return magic_methpack(sv,mg,SV_CONST(DELETE));
2028 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2033 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2035 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2037 retval = SvIV(retsv)-1;
2039 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2041 return (U32) retval;
2045 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2047 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2049 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2054 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2058 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2060 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2061 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2068 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2070 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2072 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2076 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2079 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2080 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2082 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2084 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2086 if (HvEITER_get(hv))
2087 /* we are in an iteration so the hash cannot be empty */
2089 /* no xhv_eiter so now use FIRSTKEY */
2090 key = sv_newmortal();
2091 magic_nextpack(MUTABLE_SV(hv), mg, key);
2092 HvEITER_set(hv, NULL); /* need to reset iterator */
2093 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2096 /* there is a SCALAR method that we can call */
2097 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2099 retval = &PL_sv_undef;
2104 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2108 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2110 /* The magic ptr/len for the debugger's hash should always be an SV. */
2111 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2112 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2113 (IV)mg->mg_len, mg->mg_ptr);
2116 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2117 setting/clearing debugger breakpoints is not a hot path. */
2118 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2119 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2121 if (svp && SvIOKp(*svp)) {
2122 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2124 #ifdef PERL_DEBUG_READONLY_OPS
2125 Slab_to_rw(OpSLAB(o));
2127 /* set or clear breakpoint in the relevant control op */
2129 o->op_flags |= OPf_SPECIAL;
2131 o->op_flags &= ~OPf_SPECIAL;
2132 #ifdef PERL_DEBUG_READONLY_OPS
2133 Slab_to_ro(OpSLAB(o));
2141 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2143 AV * const obj = MUTABLE_AV(mg->mg_obj);
2145 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2148 sv_setiv(sv, AvFILL(obj));
2156 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2158 AV * const obj = MUTABLE_AV(mg->mg_obj);
2160 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2163 av_fill(obj, SvIV(sv));
2165 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2166 "Attempt to set length of freed array");
2172 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2174 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2175 PERL_UNUSED_ARG(sv);
2176 PERL_UNUSED_CONTEXT;
2178 /* Reset the iterator when the array is cleared */
2179 if (sizeof(IV) == sizeof(SSize_t)) {
2180 *((IV *) &(mg->mg_len)) = 0;
2183 *((IV *) mg->mg_ptr) = 0;
2190 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2192 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2193 PERL_UNUSED_ARG(sv);
2195 /* during global destruction, mg_obj may already have been freed */
2196 if (PL_in_clean_all)
2199 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2202 /* arylen scalar holds a pointer back to the array, but doesn't own a
2203 reference. Hence the we (the array) are about to go away with it
2204 still pointing at us. Clear its pointer, else it would be pointing
2205 at free memory. See the comment in sv_magic about reference loops,
2206 and why it can't own a reference to us. */
2213 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2215 SV* const lsv = LvTARG(sv);
2216 MAGIC * const found = mg_find_mglob(lsv);
2218 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2219 PERL_UNUSED_ARG(mg);
2221 if (found && found->mg_len != -1) {
2222 STRLEN i = found->mg_len;
2223 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2224 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2233 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2235 SV* const lsv = LvTARG(sv);
2241 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2242 PERL_UNUSED_ARG(mg);
2244 found = mg_find_mglob(lsv);
2248 found = sv_magicext_mglob(lsv);
2250 else if (!SvOK(sv)) {
2254 s = SvPV_const(lsv, len);
2259 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2269 else if (pos > (SSize_t)len)
2272 found->mg_len = pos;
2273 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2279 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2282 SV * const lsv = LvTARG(sv);
2283 const char * const tmps = SvPV_const(lsv,len);
2284 STRLEN offs = LvTARGOFF(sv);
2285 STRLEN rem = LvTARGLEN(sv);
2286 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2287 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2289 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2290 PERL_UNUSED_ARG(mg);
2292 if (!translate_substr_offsets(
2293 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2294 negoff ? -(IV)offs : (IV)offs, !negoff,
2295 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2297 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2303 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2304 sv_setpvn(sv, tmps + offs, rem);
2311 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2313 STRLEN len, lsv_len, oldtarglen, newtarglen;
2314 const char * const tmps = SvPV_const(sv, len);
2315 SV * const lsv = LvTARG(sv);
2316 STRLEN lvoff = LvTARGOFF(sv);
2317 STRLEN lvlen = LvTARGLEN(sv);
2318 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2319 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2321 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2322 PERL_UNUSED_ARG(mg);
2326 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2327 "Attempt to use reference as lvalue in substr"
2329 SvPV_force_nomg(lsv,lsv_len);
2330 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2331 if (!translate_substr_offsets(
2333 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2334 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2336 Perl_croak(aTHX_ "substr outside of string");
2339 sv_utf8_upgrade_nomg(lsv);
2340 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2341 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2342 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2345 else if (SvUTF8(lsv)) {
2347 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2349 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2350 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2354 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2357 if (!neglen) LvTARGLEN(sv) = newtarglen;
2358 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2364 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2366 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2367 PERL_UNUSED_ARG(sv);
2368 #ifdef NO_TAINT_SUPPORT
2369 PERL_UNUSED_ARG(mg);
2372 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2377 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2379 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2380 PERL_UNUSED_ARG(sv);
2382 /* update taint status */
2391 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2393 SV * const lsv = LvTARG(sv);
2394 char errflags = LvFLAGS(sv);
2396 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2397 PERL_UNUSED_ARG(mg);
2399 /* non-zero errflags implies deferred out-of-range condition */
2400 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2401 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2407 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2409 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2410 PERL_UNUSED_ARG(mg);
2411 do_vecset(sv); /* XXX slurp this routine */
2416 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2419 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2420 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2422 if (LvTARGLEN(sv)) {
2424 SV * const ahv = LvTARG(sv);
2425 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2429 else if (LvSTARGOFF(sv) >= 0) {
2430 AV *const av = MUTABLE_AV(LvTARG(sv));
2431 if (LvSTARGOFF(sv) <= AvFILL(av))
2433 if (SvRMAGICAL(av)) {
2434 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2435 targ = svp ? *svp : NULL;
2438 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2441 if (targ && (targ != &PL_sv_undef)) {
2442 /* somebody else defined it for us */
2443 SvREFCNT_dec(LvTARG(sv));
2444 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2446 SvREFCNT_dec(mg->mg_obj);
2448 mg->mg_flags &= ~MGf_REFCOUNTED;
2457 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2459 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2461 sv_setsv(sv, defelem_target(sv, mg));
2466 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2468 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2469 PERL_UNUSED_ARG(mg);
2473 sv_setsv(LvTARG(sv), sv);
2474 SvSETMAGIC(LvTARG(sv));
2480 Perl_vivify_defelem(pTHX_ SV *sv)
2485 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2487 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2490 SV * const ahv = LvTARG(sv);
2491 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2494 if (!value || value == &PL_sv_undef)
2495 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2497 else if (LvSTARGOFF(sv) < 0)
2498 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2500 AV *const av = MUTABLE_AV(LvTARG(sv));
2501 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2502 LvTARG(sv) = NULL; /* array can't be extended */
2504 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2505 if (!svp || !(value = *svp))
2506 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2509 SvREFCNT_inc_simple_void(value);
2510 SvREFCNT_dec(LvTARG(sv));
2513 SvREFCNT_dec(mg->mg_obj);
2515 mg->mg_flags &= ~MGf_REFCOUNTED;
2519 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2521 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2522 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2527 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2529 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2530 PERL_UNUSED_CONTEXT;
2531 PERL_UNUSED_ARG(sv);
2537 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2539 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2541 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2543 if (uf && uf->uf_set)
2544 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2549 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2551 const char type = mg->mg_type;
2553 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2555 assert( type == PERL_MAGIC_fm
2556 || type == PERL_MAGIC_qr
2557 || type == PERL_MAGIC_bm);
2558 return sv_unmagic(sv, type);
2561 #ifdef USE_LOCALE_COLLATE
2563 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2565 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2568 * RenE<eacute> Descartes said "I think not."
2569 * and vanished with a faint plop.
2571 PERL_UNUSED_CONTEXT;
2572 PERL_UNUSED_ARG(sv);
2574 Safefree(mg->mg_ptr);
2580 #endif /* USE_LOCALE_COLLATE */
2582 /* Just clear the UTF-8 cache data. */
2584 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2586 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2587 PERL_UNUSED_CONTEXT;
2588 PERL_UNUSED_ARG(sv);
2589 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2591 mg->mg_len = -1; /* The mg_len holds the len cache. */
2596 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2598 const char *bad = NULL;
2599 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2600 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2601 switch (mg->mg_private & OPpLVREF_TYPE) {
2603 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2607 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2611 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2615 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2619 /* diag_listed_as: Assigned value is not %s reference */
2620 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2621 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2624 SV * const old = PAD_SV(mg->mg_len);
2625 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2630 gv_setref(mg->mg_obj, sv);
2631 SvSETMAGIC(mg->mg_obj);
2634 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2635 SvREFCNT_inc_simple_NN(SvRV(sv)));
2638 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2639 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2641 if (mg->mg_flags & MGf_PERSIST)
2642 NOOP; /* This sv is in use as an iterator var and will be reused,
2643 so we must leave the magic. */
2645 /* This sv could be returned by the assignment op, so clear the
2646 magic, as lvrefs are an implementation detail that must not be
2647 leaked to the user. */
2648 sv_unmagic(sv, PERL_MAGIC_lvref);
2653 S_set_dollarzero(pTHX_ SV *sv)
2654 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2661 #ifdef HAS_SETPROCTITLE
2662 /* The BSDs don't show the argv[] in ps(1) output, they
2663 * show a string from the process struct and provide
2664 * the setproctitle() routine to manipulate that. */
2665 if (PL_origalen != 1) {
2666 s = SvPV_const(sv, len);
2667 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2668 /* The leading "-" removes the "perl: " prefix,
2669 * but not the "(perl) suffix from the ps(1)
2670 * output, because that's what ps(1) shows if the
2671 * argv[] is modified. */
2672 setproctitle("-%s", s);
2673 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2674 /* This doesn't really work if you assume that
2675 * $0 = 'foobar'; will wipe out 'perl' from the $0
2676 * because in ps(1) output the result will be like
2677 * sprintf("perl: %s (perl)", s)
2678 * I guess this is a security feature:
2679 * one (a user process) cannot get rid of the original name.
2681 setproctitle("%s", s);
2684 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2685 if (PL_origalen != 1) {
2687 s = SvPV_const(sv, len);
2688 un.pst_command = (char *)s;
2689 pstat(PSTAT_SETCMD, un, len, 0, 0);
2692 if (PL_origalen > 1) {
2694 /* PL_origalen is set in perl_parse(). */
2695 s = SvPV_force(sv,len);
2696 if (len >= (STRLEN)PL_origalen-1) {
2697 /* Longer than original, will be truncated. We assume that
2698 * PL_origalen bytes are available. */
2699 Copy(s, PL_origargv[0], PL_origalen-1, char);
2702 /* Shorter than original, will be padded. */
2704 /* Special case for Mac OS X: see [perl #38868] */
2707 /* Is the space counterintuitive? Yes.
2708 * (You were expecting \0?)
2709 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2711 const int pad = ' ';
2713 Copy(s, PL_origargv[0], len, char);
2714 PL_origargv[0][len] = 0;
2715 memset(PL_origargv[0] + len + 1,
2716 pad, PL_origalen - len - 1);
2718 PL_origargv[0][PL_origalen-1] = 0;
2719 for (i = 1; i < PL_origargc; i++)
2721 #ifdef HAS_PRCTL_SET_NAME
2722 /* Set the legacy process name in addition to the POSIX name on Linux */
2723 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2724 /* diag_listed_as: SKIPME */
2725 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2733 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2744 PERL_ARGS_ASSERT_MAGIC_SET;
2748 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2750 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2752 /* Croak with a READONLY error when a numbered match var is
2753 * set without a previous pattern match. Unless it's C<local $1>
2756 if (!PL_localizing) {
2757 Perl_croak_no_modify();
2763 switch (*mg->mg_ptr) {
2764 case '\001': /* ^A */
2765 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2766 else SvOK_off(PL_bodytarget);
2767 FmLINES(PL_bodytarget) = 0;
2768 if (SvPOK(PL_bodytarget)) {
2769 char *s = SvPVX(PL_bodytarget);
2770 char *e = SvEND(PL_bodytarget);
2771 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2772 FmLINES(PL_bodytarget)++;
2776 /* mg_set() has temporarily made sv non-magical */
2778 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2779 SvTAINTED_on(PL_bodytarget);
2781 SvTAINTED_off(PL_bodytarget);
2784 case '\003': /* ^C */
2785 PL_minus_c = cBOOL(SvIV(sv));
2788 case '\004': /* ^D */
2791 const char *s = SvPV_nolen_const(sv);
2792 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2793 if (DEBUG_x_TEST || DEBUG_B_TEST)
2794 dump_all_perl(!DEBUG_B_TEST);
2797 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2800 case '\005': /* ^E */
2801 if (*(mg->mg_ptr+1) == '\0') {
2803 set_vaxc_errno(SvIV(sv));
2804 #elif defined(WIN32)
2805 SetLastError( SvIV(sv) );
2807 os2_setsyserrno(SvIV(sv));
2809 /* will anyone ever use this? */
2810 SETERRNO(SvIV(sv), 4);
2813 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2814 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2816 case '\006': /* ^F */
2817 PL_maxsysfd = SvIV(sv);
2819 case '\010': /* ^H */
2821 U32 save_hints = PL_hints;
2822 PL_hints = SvUV(sv);
2824 /* If wasn't UTF-8, and now is, notify the parser */
2825 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2826 notify_parser_that_changed_to_utf8();
2830 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2831 Safefree(PL_inplace);
2832 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2834 case '\016': /* ^N */
2835 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2836 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2838 case '\017': /* ^O */
2839 if (*(mg->mg_ptr+1) == '\0') {
2840 Safefree(PL_osname);
2843 TAINT_PROPER("assigning to $^O");
2844 PL_osname = savesvpv(sv);
2847 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2849 const char *const start = SvPV(sv, len);
2850 const char *out = (const char*)memchr(start, '\0', len);
2854 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2855 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2857 /* Opening for input is more common than opening for output, so
2858 ensure that hints for input are sooner on linked list. */
2859 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2861 : newSVpvs_flags("", SvUTF8(sv));
2862 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2865 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2867 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2871 case '\020': /* ^P */
2872 PL_perldb = SvIV(sv);
2873 if (PL_perldb && !PL_DBsingle)
2876 case '\024': /* ^T */
2878 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2880 PL_basetime = (Time_t)SvIV(sv);
2883 case '\025': /* ^UTF8CACHE */
2884 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2885 PL_utf8cache = (signed char) sv_2iv(sv);
2888 case '\027': /* ^W & $^WARNING_BITS */
2889 if (*(mg->mg_ptr+1) == '\0') {
2890 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2892 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2893 | (i ? G_WARN_ON : G_WARN_OFF) ;
2896 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2897 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2899 PL_compiling.cop_warnings = pWARN_STD;
2904 int not_none = 0, not_all = 0;
2905 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2906 for (i = 0 ; i < len ; ++i) {
2908 not_all |= ptr[i] ^ 0x55;
2911 if (!specialWARN(PL_compiling.cop_warnings))
2912 PerlMemShared_free(PL_compiling.cop_warnings);
2913 PL_compiling.cop_warnings = pWARN_NONE;
2914 } else if (len >= WARNsize && !not_all) {
2915 if (!specialWARN(PL_compiling.cop_warnings))
2916 PerlMemShared_free(PL_compiling.cop_warnings);
2917 PL_compiling.cop_warnings = pWARN_ALL;
2918 PL_dowarn |= G_WARN_ONCE ;
2922 const char *const p = SvPV_const(sv, len);
2924 PL_compiling.cop_warnings
2925 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2928 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2929 PL_dowarn |= G_WARN_ONCE ;
2936 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2937 w32_sloppystat = (bool)sv_true(sv);
2942 if (PL_localizing) {
2943 if (PL_localizing == 1)
2944 SAVESPTR(PL_last_in_gv);
2946 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2947 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2950 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2951 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2952 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2955 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2956 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2957 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2960 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2963 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2964 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2965 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2968 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2972 IO * const io = GvIO(PL_defoutgv);
2975 if ((SvIV(sv)) == 0)
2976 IoFLAGS(io) &= ~IOf_FLUSH;
2978 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2979 PerlIO *ofp = IoOFP(io);
2981 (void)PerlIO_flush(ofp);
2982 IoFLAGS(io) |= IOf_FLUSH;
2990 SV *referent = SvRV(sv);
2991 const char *reftype = sv_reftype(referent, 0);
2992 /* XXX: dodgy type check: This leaves me feeling dirty, but
2993 * the alternative is to copy pretty much the entire
2994 * sv_reftype() into this routine, or to do a full string
2995 * comparison on the return of sv_reftype() both of which
2996 * make me feel worse! NOTE, do not modify this comment
2997 * without reviewing the corresponding comment in
2998 * sv_reftype(). - Yves */
2999 if (reftype[0] == 'S' || reftype[0] == 'L') {
3000 IV val = SvIV(referent);
3002 sv_setsv(sv, PL_rs);
3003 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3004 val < 0 ? "a negative integer" : "zero");
3007 sv_setsv(sv, PL_rs);
3008 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3009 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3010 *reftype == 'A' ? "n" : "", reftype);
3013 SvREFCNT_dec(PL_rs);
3014 PL_rs = newSVsv(sv);
3018 SvREFCNT_dec(PL_ors_sv);
3020 PL_ors_sv = newSVsv(sv);
3028 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3031 #ifdef COMPLEX_STATUS
3032 if (PL_localizing == 2) {
3033 SvUPGRADE(sv, SVt_PVLV);
3034 PL_statusvalue = LvTARGOFF(sv);
3035 PL_statusvalue_vms = LvTARGLEN(sv);
3039 #ifdef VMSISH_STATUS
3041 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3044 STATUS_UNIX_EXIT_SET(SvIV(sv));
3049 # define PERL_VMS_BANG vaxc$errno
3051 # define PERL_VMS_BANG 0
3053 #if defined(WIN32) && ! defined(UNDER_CE)
3054 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3055 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3057 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3058 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3064 /* XXX $< currently silently ignores failures */
3065 const Uid_t new_uid = SvUID(sv);
3066 PL_delaymagic_uid = new_uid;
3067 if (PL_delaymagic) {
3068 PL_delaymagic |= DM_RUID;
3069 break; /* don't do magic till later */
3072 PERL_UNUSED_RESULT(setruid(new_uid));
3073 #elif defined(HAS_SETREUID)
3074 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3075 #elif defined(HAS_SETRESUID)
3076 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3078 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3080 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3081 if (new_uid != 0 && PerlProc_getuid() == 0)
3082 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3084 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3086 Perl_croak(aTHX_ "setruid() not implemented");
3093 /* XXX $> currently silently ignores failures */
3094 const Uid_t new_euid = SvUID(sv);
3095 PL_delaymagic_euid = new_euid;
3096 if (PL_delaymagic) {
3097 PL_delaymagic |= DM_EUID;
3098 break; /* don't do magic till later */
3101 PERL_UNUSED_RESULT(seteuid(new_euid));
3102 #elif defined(HAS_SETREUID)
3103 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3104 #elif defined(HAS_SETRESUID)
3105 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3107 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3108 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3110 Perl_croak(aTHX_ "seteuid() not implemented");
3117 /* XXX $( currently silently ignores failures */
3118 const Gid_t new_gid = SvGID(sv);
3119 PL_delaymagic_gid = new_gid;
3120 if (PL_delaymagic) {
3121 PL_delaymagic |= DM_RGID;
3122 break; /* don't do magic till later */
3125 PERL_UNUSED_RESULT(setrgid(new_gid));
3126 #elif defined(HAS_SETREGID)
3127 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3128 #elif defined(HAS_SETRESGID)
3129 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3131 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3132 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3134 Perl_croak(aTHX_ "setrgid() not implemented");
3141 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3142 * but you can override it if you need to.
3145 #define INVALID_GID ((Gid_t)-1)
3147 /* XXX $) currently silently ignores failures */
3149 #ifdef HAS_SETGROUPS
3151 const char *p = SvPV_const(sv, len);
3152 Groups_t *gary = NULL;
3155 #ifdef _SC_NGROUPS_MAX
3156 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3161 int maxgrp = NGROUPS;
3166 if (grok_atoUV(p, &uv, &endptr))
3167 new_egid = (Gid_t)uv;
3169 new_egid = INVALID_GID;
3172 for (i = 0; i < maxgrp; ++i) {
3181 Newx(gary, i + 1, Groups_t);
3183 Renew(gary, i + 1, Groups_t);
3184 if (grok_atoUV(p, &uv, &endptr))
3185 gary[i] = (Groups_t)uv;
3187 gary[i] = INVALID_GID;
3192 PERL_UNUSED_RESULT(setgroups(i, gary));
3195 #else /* HAS_SETGROUPS */
3196 new_egid = SvGID(sv);
3197 #endif /* HAS_SETGROUPS */
3198 PL_delaymagic_egid = new_egid;
3199 if (PL_delaymagic) {
3200 PL_delaymagic |= DM_EGID;
3201 break; /* don't do magic till later */
3204 PERL_UNUSED_RESULT(setegid(new_egid));
3205 #elif defined(HAS_SETREGID)
3206 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3207 #elif defined(HAS_SETRESGID)
3208 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3210 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3211 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3213 Perl_croak(aTHX_ "setegid() not implemented");
3219 PL_chopset = SvPV_force(sv,len);
3222 /* Store the pid in mg->mg_obj so we can tell when a fork has
3223 occurred. mg->mg_obj points to *$ by default, so clear it. */
3224 if (isGV(mg->mg_obj)) {
3225 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3226 SvREFCNT_dec(mg->mg_obj);
3227 mg->mg_flags |= MGf_REFCOUNTED;
3228 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3230 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3233 LOCK_DOLLARZERO_MUTEX;
3234 S_set_dollarzero(aTHX_ sv);
3235 UNLOCK_DOLLARZERO_MUTEX;
3242 Perl_whichsig_sv(pTHX_ SV *sigsv)
3246 PERL_ARGS_ASSERT_WHICHSIG_SV;
3247 sigpv = SvPV_const(sigsv, siglen);
3248 return whichsig_pvn(sigpv, siglen);
3252 Perl_whichsig_pv(pTHX_ const char *sig)
3254 PERL_ARGS_ASSERT_WHICHSIG_PV;
3255 return whichsig_pvn(sig, strlen(sig));
3259 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3263 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3264 PERL_UNUSED_CONTEXT;
3266 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3267 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3268 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3270 if (memEQs(sig, len, "CHLD"))
3274 if (memEQs(sig, len, "CLD"))
3281 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3282 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3284 Perl_sighandler(int sig)
3287 #ifdef PERL_GET_SIG_CONTEXT
3288 dTHXa(PERL_GET_SIG_CONTEXT);
3295 SV * const tSv = PL_Sv;
3299 XPV * const tXpv = PL_Xpv;
3300 I32 old_ss_ix = PL_savestack_ix;
3301 SV *errsv_save = NULL;
3304 if (!PL_psig_ptr[sig]) {
3305 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3310 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3311 /* Max number of items pushed there is 3*n or 4. We cannot fix
3312 infinity, so we fix 4 (in fact 5): */
3313 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3315 PL_savestack_ix += 5; /* Protect save in progress. */
3316 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3319 /* sv_2cv is too complicated, try a simpler variant first: */
3320 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3321 || SvTYPE(cv) != SVt_PVCV) {
3323 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3326 if (!cv || !CvROOT(cv)) {
3327 const HEK * const hek = gv
3331 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3333 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3334 "SIG%s handler \"%" HEKf "\" not defined.\n",
3335 PL_sig_name[sig], HEKfARG(hek));
3336 /* diag_listed_as: SIG%s handler "%s" not defined */
3337 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3338 "SIG%s handler \"__ANON__\" not defined.\n",
3343 sv = PL_psig_name[sig]
3344 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3345 : newSVpv(PL_sig_name[sig],0);
3349 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3350 /* make sure our assumption about the size of the SAVEs are correct:
3351 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3352 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3355 PUSHSTACKi(PERLSI_SIGNAL);
3358 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3360 struct sigaction oact;
3362 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3365 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3366 /* The siginfo fields signo, code, errno, pid, uid,
3367 * addr, status, and band are defined by POSIX/SUSv3. */
3368 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3369 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3370 #ifdef HAS_SIGINFO_SI_ERRNO
3371 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3373 #ifdef HAS_SIGINFO_SI_STATUS
3374 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3376 #ifdef HAS_SIGINFO_SI_UID
3379 sv_setuid(uid, sip->si_uid);
3380 (void)hv_stores(sih, "uid", uid);
3383 #ifdef HAS_SIGINFO_SI_PID
3384 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3386 #ifdef HAS_SIGINFO_SI_ADDR
3387 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3389 #ifdef HAS_SIGINFO_SI_BAND
3390 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3394 mPUSHp((char *)sip, sizeof(*sip));
3402 errsv_save = newSVsv(ERRSV);
3404 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3408 SV * const errsv = ERRSV;
3409 if (SvTRUE_NN(errsv)) {
3410 SvREFCNT_dec(errsv_save);
3412 /* Handler "died", for example to get out of a restart-able read().
3413 * Before we re-do that on its behalf re-enable the signal which was
3414 * blocked by the system when we entered.
3416 #ifdef HAS_SIGPROCMASK
3417 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3423 sigaddset(&set,sig);
3424 sigprocmask(SIG_UNBLOCK, &set, NULL);
3427 /* Not clear if this will work */
3428 (void)rsignal(sig, SIG_IGN);
3429 (void)rsignal(sig, PL_csighandlerp);
3431 #endif /* !PERL_MICRO */
3435 sv_setsv(errsv, errsv_save);
3436 SvREFCNT_dec(errsv_save);
3441 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3442 PL_savestack_ix = old_ss_ix;
3444 SvREFCNT_dec_NN(sv);
3445 PL_op = myop; /* Apparently not needed... */
3447 PL_Sv = tSv; /* Restore global temporaries. */
3454 S_restore_magic(pTHX_ const void *p)
3456 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3457 SV* const sv = mgs->mgs_sv;
3463 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3464 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3466 SvFLAGS(sv) |= mgs->mgs_flags;
3471 bumped = mgs->mgs_bumped;
3472 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3474 /* If we're still on top of the stack, pop us off. (That condition
3475 * will be satisfied if restore_magic was called explicitly, but *not*
3476 * if it's being called via leave_scope.)
3477 * The reason for doing this is that otherwise, things like sv_2cv()
3478 * may leave alloc gunk on the savestack, and some code
3479 * (e.g. sighandler) doesn't expect that...
3481 if (PL_savestack_ix == mgs->mgs_ss_ix)
3483 UV popval = SSPOPUV;
3484 assert(popval == SAVEt_DESTRUCTOR_X);
3485 PL_savestack_ix -= 2;
3487 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3488 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3491 if (SvREFCNT(sv) == 1) {
3492 /* We hold the last reference to this SV, which implies that the
3493 SV was deleted as a side effect of the routines we called.
3494 So artificially keep it alive a bit longer.
3495 We avoid turning on the TEMP flag, which can cause the SV's
3496 buffer to get stolen (and maybe other stuff). */
3501 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3505 /* clean up the mess created by Perl_sighandler().
3506 * Note that this is only called during an exit in a signal handler;
3507 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3511 S_unwind_handler_stack(pTHX_ const void *p)
3515 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3519 =for apidoc magic_sethint
3521 Triggered by a store to C<%^H>, records the key/value pair to
3522 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3523 anything that would need a deep copy. Maybe we should warn if we find a
3529 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3531 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3532 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3534 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3536 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3537 an alternative leaf in there, with PL_compiling.cop_hints being used if
3538 it's NULL. If needed for threads, the alternative could lock a mutex,
3539 or take other more complex action. */
3541 /* Something changed in %^H, so it will need to be restored on scope exit.
3542 Doing this here saves a lot of doing it manually in perl code (and
3543 forgetting to do it, and consequent subtle errors. */
3544 PL_hints |= HINT_LOCALIZE_HH;
3545 CopHINTHASH_set(&PL_compiling,
3546 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3551 =for apidoc magic_clearhint
3553 Triggered by a delete from C<%^H>, records the key to
3554 C<PL_compiling.cop_hints_hash>.
3559 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3561 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3562 PERL_UNUSED_ARG(sv);
3564 PL_hints |= HINT_LOCALIZE_HH;
3565 CopHINTHASH_set(&PL_compiling,
3566 mg->mg_len == HEf_SVKEY
3567 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3568 MUTABLE_SV(mg->mg_ptr), 0, 0)
3569 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3570 mg->mg_ptr, mg->mg_len, 0, 0));
3575 =for apidoc magic_clearhints
3577 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3582 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3584 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3585 PERL_UNUSED_ARG(sv);
3586 PERL_UNUSED_ARG(mg);
3587 cophh_free(CopHINTHASH_get(&PL_compiling));
3588 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3593 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3594 const char *name, I32 namlen)
3598 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3599 PERL_UNUSED_ARG(sv);
3600 PERL_UNUSED_ARG(name);
3601 PERL_UNUSED_ARG(namlen);
3603 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3604 nmg = mg_find(nsv, mg->mg_type);
3606 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3607 nmg->mg_ptr = mg->mg_ptr;
3608 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3609 nmg->mg_flags |= MGf_REFCOUNTED;
3614 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3615 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3617 #if DBVARMG_SINGLE != 0
3618 assert(mg->mg_private >= DBVARMG_SINGLE);
3620 assert(mg->mg_private < DBVARMG_COUNT);
3622 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3628 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3629 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3631 #if DBVARMG_SINGLE != 0
3632 assert(mg->mg_private >= DBVARMG_SINGLE);
3634 assert(mg->mg_private < DBVARMG_COUNT);
3635 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3641 * ex: set ts=8 sts=4 sw=4 et: