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
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #ifdef HAS_PRCTL_SET_NAME
61 # include <sys/prctl.h>
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
67 Signal_t Perl_csighandler(int sig);
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
79 * Pre-magic setup and post-magic takedown.
80 * 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)
99 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
101 assert(SvMAGICAL(sv));
103 /* we shouldn't really be called here with RC==0, but it can sometimes
104 * happen via mg_clear() (which also shouldn't be called when RC==0,
105 * but it can happen). Handle this case gracefully(ish) by not RC++
106 * and thus avoiding the resultant double free */
107 if (SvREFCNT(sv) > 0) {
108 /* guard against sv getting freed midway through the mg clearing,
109 * by holding a private reference for the duration. */
110 SvREFCNT_inc_simple_void_NN(sv);
114 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
116 mgs = SSPTR(mgs_ix, MGS*);
118 mgs->mgs_magical = SvMAGICAL(sv);
119 mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv);
120 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
121 mgs->mgs_bumped = bumped;
123 SvFLAGS(sv) &= ~flags;
124 /* Turning READONLY off for a copy-on-write scalar (including shared
125 hash keys) is a bad idea. */
126 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
129 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
132 =for apidoc mg_magical
134 Turns on the magical status of an SV. See C<sv_magic>.
140 Perl_mg_magical(pTHX_ SV *sv)
143 PERL_ARGS_ASSERT_MG_MAGICAL;
147 if ((mg = SvMAGIC(sv))) {
149 const MGVTBL* const vtbl = mg->mg_virtual;
151 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
158 } while ((mg = mg->mg_moremagic));
159 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
167 Do magic before a value is retrieved from the SV. The type of SV must
168 be >= SVt_PVMG. See C<sv_magic>.
174 Perl_mg_get(pTHX_ SV *sv)
177 const I32 mgs_ix = SSNEW(sizeof(MGS));
180 MAGIC *newmg, *head, *cur, *mg;
182 PERL_ARGS_ASSERT_MG_GET;
184 if (PL_localizing == 1 && sv == DEFSV) return 0;
186 /* We must call svt_get(sv, mg) for each valid entry in the linked
187 list of magic. svt_get() may delete the current entry, add new
188 magic to the head of the list, or upgrade the SV. AMS 20010810 */
190 newmg = cur = head = mg = SvMAGIC(sv);
192 const MGVTBL * const vtbl = mg->mg_virtual;
193 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
195 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
197 /* taint's mg get is so dumb it doesn't need flag saving */
198 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
199 save_magic(mgs_ix, sv);
203 vtbl->svt_get(aTHX_ sv, mg);
205 /* guard against magic having been deleted - eg FETCH calling
208 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
212 /* recalculate flags if this entry was deleted. */
213 if (mg->mg_flags & MGf_GSKIP)
214 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
216 else if (vtbl == &PL_vtbl_utf8) {
217 /* get-magic can reallocate the PV */
218 magic_setutf8(sv, mg);
224 /* Have we finished with the new entries we saw? Start again
225 where we left off (unless there are more new entries). */
233 /* Were any new entries added? */
234 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
238 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
243 restore_magic(INT2PTR(void *, (IV)mgs_ix));
251 Do magic after a value is assigned to the SV. See C<sv_magic>.
257 Perl_mg_set(pTHX_ SV *sv)
260 const I32 mgs_ix = SSNEW(sizeof(MGS));
264 PERL_ARGS_ASSERT_MG_SET;
266 if (PL_localizing == 2 && sv == DEFSV) return 0;
268 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
270 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
271 const MGVTBL* vtbl = mg->mg_virtual;
272 nextmg = mg->mg_moremagic; /* it may delete itself */
273 if (mg->mg_flags & MGf_GSKIP) {
274 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
275 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
277 if (PL_localizing == 2
278 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
280 if (vtbl && vtbl->svt_set)
281 vtbl->svt_set(aTHX_ sv, mg);
284 restore_magic(INT2PTR(void*, (IV)mgs_ix));
289 =for apidoc mg_length
291 Reports on the SV's length in bytes, calling length magic if available,
292 but does not set the UTF8 flag on the sv. It will fall back to 'get'
293 magic if there is no 'length' magic, but with no indication as to
294 whether it called 'get' magic. It assumes the sv is a PVMG or
295 higher. Use sv_len() instead.
301 Perl_mg_length(pTHX_ SV *sv)
307 PERL_ARGS_ASSERT_MG_LENGTH;
309 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
310 const MGVTBL * const vtbl = mg->mg_virtual;
311 if (vtbl && vtbl->svt_len) {
312 const I32 mgs_ix = SSNEW(sizeof(MGS));
313 save_magic(mgs_ix, sv);
314 /* omit MGf_GSKIP -- not changed here */
315 len = vtbl->svt_len(aTHX_ sv, mg);
316 restore_magic(INT2PTR(void*, (IV)mgs_ix));
321 (void)SvPV_const(sv, len);
326 Perl_mg_size(pTHX_ SV *sv)
330 PERL_ARGS_ASSERT_MG_SIZE;
332 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
333 const MGVTBL* const vtbl = mg->mg_virtual;
334 if (vtbl && vtbl->svt_len) {
335 const I32 mgs_ix = SSNEW(sizeof(MGS));
337 save_magic(mgs_ix, sv);
338 /* omit MGf_GSKIP -- not changed here */
339 len = vtbl->svt_len(aTHX_ sv, mg);
340 restore_magic(INT2PTR(void*, (IV)mgs_ix));
347 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
351 Perl_croak(aTHX_ "Size magic not implemented");
360 Clear something magical that the SV represents. See C<sv_magic>.
366 Perl_mg_clear(pTHX_ SV *sv)
368 const I32 mgs_ix = SSNEW(sizeof(MGS));
372 PERL_ARGS_ASSERT_MG_CLEAR;
374 save_magic(mgs_ix, sv);
376 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
377 const MGVTBL* const vtbl = mg->mg_virtual;
378 /* omit GSKIP -- never set here */
380 nextmg = mg->mg_moremagic; /* it may delete itself */
382 if (vtbl && vtbl->svt_clear)
383 vtbl->svt_clear(aTHX_ sv, mg);
386 restore_magic(INT2PTR(void*, (IV)mgs_ix));
391 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
400 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
401 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
413 Finds the magic pointer for type matching the SV. See C<sv_magic>.
419 Perl_mg_find(pTHX_ const SV *sv, int type)
421 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
425 =for apidoc mg_findext
427 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
434 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
436 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
440 Perl_mg_find_mglob(pTHX_ SV *sv)
442 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
443 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
444 /* This sv is only a delegate. //g magic must be attached to
449 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
450 return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
457 Copies the magic from one SV to another. See C<sv_magic>.
463 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
468 PERL_ARGS_ASSERT_MG_COPY;
470 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
473 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
476 const char type = mg->mg_type;
477 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
479 (type == PERL_MAGIC_tied)
481 : (type == PERL_MAGIC_regdata && mg->mg_obj)
484 toLOWER(type), key, klen);
493 =for apidoc mg_localize
495 Copy some of the magic from an existing SV to new localized version of that
496 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
499 If setmagic is false then no set magic will be called on the new (empty) SV.
500 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
501 and that will handle the magic.
507 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
512 PERL_ARGS_ASSERT_MG_LOCALIZE;
517 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
518 const MGVTBL* const vtbl = mg->mg_virtual;
519 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
522 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
523 (void)vtbl->svt_local(aTHX_ nsv, mg);
525 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
526 mg->mg_ptr, mg->mg_len);
528 /* container types should remain read-only across localization */
529 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
532 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
533 SvFLAGS(nsv) |= SvMAGICAL(sv);
542 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
544 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
546 const MGVTBL* const vtbl = mg->mg_virtual;
547 if (vtbl && vtbl->svt_free)
548 vtbl->svt_free(aTHX_ sv, mg);
549 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
550 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
551 Safefree(mg->mg_ptr);
552 else if (mg->mg_len == HEf_SVKEY)
553 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
555 if (mg->mg_flags & MGf_REFCOUNTED)
556 SvREFCNT_dec(mg->mg_obj);
563 Free any magic storage used by the SV. See C<sv_magic>.
569 Perl_mg_free(pTHX_ SV *sv)
574 PERL_ARGS_ASSERT_MG_FREE;
576 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
577 moremagic = mg->mg_moremagic;
578 mg_free_struct(sv, mg);
579 SvMAGIC_set(sv, moremagic);
581 SvMAGIC_set(sv, NULL);
587 =for apidoc Am|void|mg_free_type|SV *sv|int how
589 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
595 Perl_mg_free_type(pTHX_ SV *sv, int how)
597 MAGIC *mg, *prevmg, *moremg;
598 PERL_ARGS_ASSERT_MG_FREE_TYPE;
599 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
601 moremg = mg->mg_moremagic;
602 if (mg->mg_type == how) {
603 /* temporarily move to the head of the magic chain, in case
604 custom free code relies on this historical aspect of mg_free */
606 prevmg->mg_moremagic = moremg;
607 mg->mg_moremagic = SvMAGIC(sv);
610 newhead = mg->mg_moremagic;
611 mg_free_struct(sv, mg);
612 SvMAGIC_set(sv, newhead);
622 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
627 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
630 const REGEXP * const rx = PM_GETRE(PL_curpm);
632 if (mg->mg_obj) { /* @+ */
633 /* return the number possible */
634 return RX_NPARENS(rx);
636 I32 paren = RX_LASTPAREN(rx);
638 /* return the last filled */
640 && (RX_OFFS(rx)[paren].start == -1
641 || RX_OFFS(rx)[paren].end == -1) )
654 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
658 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
661 const REGEXP * const rx = PM_GETRE(PL_curpm);
663 const I32 paren = mg->mg_len;
668 if (paren <= (I32)RX_NPARENS(rx) &&
669 (s = RX_OFFS(rx)[paren].start) != -1 &&
670 (t = RX_OFFS(rx)[paren].end) != -1)
673 if (mg->mg_obj) /* @+ */
678 if (i > 0 && RX_MATCH_UTF8(rx)) {
679 const char * const b = RX_SUBBEG(rx);
681 i = RX_SUBCOFFSET(rx) +
683 (U8*)(b-RX_SUBOFFSET(rx)+i));
696 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
698 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
701 Perl_croak_no_modify();
702 NORETURN_FUNCTION_END;
705 #define SvRTRIM(sv) STMT_START { \
707 STRLEN len = SvCUR(sv); \
708 char * const p = SvPVX(sv); \
709 while (len > 0 && isSPACE(p[len-1])) \
711 SvCUR_set(sv, len); \
717 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
719 PERL_ARGS_ASSERT_EMULATE_COP_IO;
721 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
722 sv_setsv(sv, &PL_sv_undef);
726 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
727 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
732 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
733 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
746 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
750 const char *s = NULL;
752 const char * const remaining = mg->mg_ptr + 1;
753 const char nextchar = *remaining;
755 PERL_ARGS_ASSERT_MAGIC_GET;
757 switch (*mg->mg_ptr) {
758 case '\001': /* ^A */
759 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
760 else sv_setsv(sv, &PL_sv_undef);
761 if (SvTAINTED(PL_bodytarget))
764 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
765 if (nextchar == '\0') {
766 sv_setiv(sv, (IV)PL_minus_c);
768 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
769 sv_setiv(sv, (IV)STATUS_NATIVE);
773 case '\004': /* ^D */
774 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
776 case '\005': /* ^E */
777 if (nextchar == '\0') {
781 $DESCRIPTOR(msgdsc,msg);
782 sv_setnv(sv,(NV) vaxc$errno);
783 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
784 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
789 if (!(_emx_env & 0x200)) { /* Under DOS */
790 sv_setnv(sv, (NV)errno);
791 sv_setpv(sv, errno ? Strerror(errno) : "");
793 if (errno != errno_isOS2) {
794 const int tmp = _syserrno();
795 if (tmp) /* 2nd call to _syserrno() makes it 0 */
798 sv_setnv(sv, (NV)Perl_rc);
799 sv_setpv(sv, os2error(Perl_rc));
803 const DWORD dwErr = GetLastError();
804 sv_setnv(sv, (NV)dwErr);
806 PerlProc_GetOSError(sv, dwErr);
815 sv_setnv(sv, (NV)errno);
816 sv_setpv(sv, errno ? Strerror(errno) : "");
821 SvNOK_on(sv); /* what a wonderful hack! */
823 else if (strEQ(remaining, "NCODING"))
824 sv_setsv(sv, PL_encoding);
826 case '\006': /* ^F */
827 sv_setiv(sv, (IV)PL_maxsysfd);
829 case '\007': /* ^GLOBAL_PHASE */
830 if (strEQ(remaining, "LOBAL_PHASE")) {
831 sv_setpvn(sv, PL_phase_names[PL_phase],
832 strlen(PL_phase_names[PL_phase]));
835 case '\010': /* ^H */
836 sv_setiv(sv, (IV)PL_hints);
838 case '\011': /* ^I */ /* NOT \t in EBCDIC */
839 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
841 case '\014': /* ^LAST_FH */
842 if (strEQ(remaining, "AST_FH")) {
844 assert(isGV_with_GP(PL_last_in_gv));
845 SV_CHECK_THINKFIRST_COW_DROP(sv);
846 prepare_SV_for_RV(sv);
848 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
852 else sv_setsv_nomg(sv, NULL);
855 case '\017': /* ^O & ^OPEN */
856 if (nextchar == '\0') {
857 sv_setpv(sv, PL_osname);
860 else if (strEQ(remaining, "PEN")) {
861 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
865 if (nextchar == '\0') { /* ^P */
866 sv_setiv(sv, (IV)PL_perldb);
867 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
869 paren = RX_BUFF_IDX_CARET_PREMATCH;
870 goto do_numbuf_fetch;
871 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
872 paren = RX_BUFF_IDX_CARET_POSTMATCH;
873 goto do_numbuf_fetch;
876 case '\023': /* ^S */
877 if (nextchar == '\0') {
878 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
881 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
886 case '\024': /* ^T */
887 if (nextchar == '\0') {
889 sv_setnv(sv, PL_basetime);
891 sv_setiv(sv, (IV)PL_basetime);
894 else if (strEQ(remaining, "AINT"))
895 sv_setiv(sv, TAINTING_get
896 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
899 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
900 if (strEQ(remaining, "NICODE"))
901 sv_setuv(sv, (UV) PL_unicode);
902 else if (strEQ(remaining, "TF8LOCALE"))
903 sv_setuv(sv, (UV) PL_utf8locale);
904 else if (strEQ(remaining, "TF8CACHE"))
905 sv_setiv(sv, (IV) PL_utf8cache);
907 case '\027': /* ^W & $^WARNING_BITS */
908 if (nextchar == '\0')
909 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
910 else if (strEQ(remaining, "ARNING_BITS")) {
911 if (PL_compiling.cop_warnings == pWARN_NONE) {
912 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
914 else if (PL_compiling.cop_warnings == pWARN_STD) {
915 sv_setsv(sv, &PL_sv_undef);
918 else if (PL_compiling.cop_warnings == pWARN_ALL) {
919 /* Get the bit mask for $warnings::Bits{all}, because
920 * it could have been extended by warnings::register */
921 HV * const bits = get_hv("warnings::Bits", 0);
922 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
924 sv_copypv(sv, *bits_all);
926 sv_setpvn(sv, WARN_ALLstring, WARNsize);
929 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
930 *PL_compiling.cop_warnings);
934 case '\015': /* $^MATCH */
935 if (strEQ(remaining, "ATCH")) {
936 paren = RX_BUFF_IDX_CARET_FULLMATCH;
937 goto do_numbuf_fetch;
940 case '1': case '2': case '3': case '4':
941 case '5': case '6': case '7': case '8': case '9': case '&':
943 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
944 * XXX Does the new way break anything?
946 paren = atoi(mg->mg_ptr); /* $& is in [0] */
948 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
949 CALLREG_NUMBUF_FETCH(rx,paren,sv);
952 sv_setsv(sv,&PL_sv_undef);
955 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
956 paren = RX_LASTPAREN(rx);
958 goto do_numbuf_fetch;
960 sv_setsv(sv,&PL_sv_undef);
962 case '\016': /* ^N */
963 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
964 paren = RX_LASTCLOSEPAREN(rx);
966 goto do_numbuf_fetch;
968 sv_setsv(sv,&PL_sv_undef);
971 paren = RX_BUFF_IDX_PREMATCH;
972 goto do_numbuf_fetch;
974 paren = RX_BUFF_IDX_POSTMATCH;
975 goto do_numbuf_fetch;
977 if (GvIO(PL_last_in_gv)) {
978 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
983 sv_setiv(sv, (IV)STATUS_CURRENT);
984 #ifdef COMPLEX_STATUS
985 SvUPGRADE(sv, SVt_PVLV);
986 LvTARGOFF(sv) = PL_statusvalue;
987 LvTARGLEN(sv) = PL_statusvalue_vms;
992 if (GvIOp(PL_defoutgv))
993 s = IoTOP_NAME(GvIOp(PL_defoutgv));
997 sv_setpv(sv,GvENAME(PL_defoutgv));
998 sv_catpvs(sv,"_TOP");
1002 if (GvIOp(PL_defoutgv))
1003 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1005 s = GvENAME(PL_defoutgv);
1009 if (GvIO(PL_defoutgv))
1010 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1013 if (GvIO(PL_defoutgv))
1014 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1017 if (GvIO(PL_defoutgv))
1018 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1028 if (GvIO(PL_defoutgv))
1029 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1033 sv_copypv(sv, PL_ors_sv);
1035 sv_setsv(sv, &PL_sv_undef);
1039 IV const pid = (IV)PerlProc_getpid();
1040 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1041 /* never set manually, or at least not since last fork */
1043 /* never unsafe, even if reading in a tainted expression */
1046 /* else a value has been assigned manually, so do nothing */
1054 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1056 sv_setnv(sv, (NV)errno);
1059 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1060 sv_setpv(sv, os2error(Perl_rc));
1068 /* Strerror can return NULL on some platforms, which will result in
1069 * 'sv' not being considered SvOK. The SvNOK_on() below will cause
1070 * just the number part to be valid */
1071 sv_setpv(sv, Strerror(errno));
1073 /* In some locales the error string may come back as UTF-8, in
1074 * which case we should turn on that flag. This didn't use to
1075 * happen, and to avoid any possible backward compatibility issues,
1076 * we don't turn on the flag unless we have to. So the flag stays
1077 * off for an entirely ASCII string. We assume that if the string
1078 * looks like UTF-8, it really is UTF-8: "text in any other
1079 * encoding that uses bytes with the high bit set is extremely
1080 * unlikely to pass a UTF-8 validity test"
1081 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
1082 * potential that we will get it wrong however, especially on short
1083 * error message text. (If it turns out to be necessary, we could
1084 * also keep track if the current LC_MESSAGES locale is UTF-8) */
1085 if (SvOK(sv) /* It could be that Strerror returned invalid */
1086 && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
1087 && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
1096 SvNOK_on(sv); /* what a wonderful hack! */
1099 sv_setuid(sv, PerlProc_getuid());
1102 sv_setuid(sv, PerlProc_geteuid());
1105 sv_setgid(sv, PerlProc_getgid());
1108 sv_setgid(sv, PerlProc_getegid());
1110 #ifdef HAS_GETGROUPS
1112 Groups_t *gary = NULL;
1113 I32 i, num_groups = getgroups(0, gary);
1114 Newx(gary, num_groups, Groups_t);
1115 num_groups = getgroups(num_groups, gary);
1116 for (i = 0; i < num_groups; i++)
1117 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1120 (void)SvIOK_on(sv); /* what a wonderful hack! */
1130 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1132 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1134 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1136 if (uf && uf->uf_val)
1137 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1142 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1145 STRLEN len = 0, klen;
1146 const char * const key = MgPV_const(mg,klen);
1149 PERL_ARGS_ASSERT_MAGIC_SETENV;
1153 /* defined environment variables are byte strings; unfortunately
1154 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1155 (void)SvPV_force_nomg_nolen(sv);
1156 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1158 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1164 my_setenv(key, s); /* does the deed */
1166 #ifdef DYNAMIC_ENV_FETCH
1167 /* We just undefd an environment var. Is a replacement */
1168 /* waiting in the wings? */
1170 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1172 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1176 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1177 /* And you'll never guess what the dog had */
1178 /* in its mouth... */
1180 MgTAINTEDDIR_off(mg);
1182 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1183 char pathbuf[256], eltbuf[256], *cp, *elt;
1186 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1188 do { /* DCL$PATH may be a search list */
1189 while (1) { /* as may dev portion of any element */
1190 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1191 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1192 cando_by_name(S_IWUSR,0,elt) ) {
1193 MgTAINTEDDIR_on(mg);
1197 if ((cp = strchr(elt, ':')) != NULL)
1199 if (my_trnlnm(elt, eltbuf, j++))
1205 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1208 if (s && klen == 4 && strEQ(key,"PATH")) {
1209 const char * const strend = s + len;
1211 while (s < strend) {
1215 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1216 const char path_sep = '|';
1218 const char path_sep = ':';
1220 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1221 s, strend, path_sep, &i);
1223 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1225 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1227 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1229 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1230 MgTAINTEDDIR_on(mg);
1236 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1242 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1244 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1245 PERL_UNUSED_ARG(sv);
1246 my_setenv(MgPV_nolen_const(mg),NULL);
1251 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1254 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1255 PERL_UNUSED_ARG(mg);
1257 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1259 if (PL_localizing) {
1262 hv_iterinit(MUTABLE_HV(sv));
1263 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1265 my_setenv(hv_iterkey(entry, &keylen),
1266 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1274 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1277 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1278 PERL_UNUSED_ARG(sv);
1279 PERL_UNUSED_ARG(mg);
1281 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1289 #ifdef HAS_SIGPROCMASK
1291 restore_sigmask(pTHX_ SV *save_sv)
1293 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1294 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1298 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1301 /* Are we fetching a signal entry? */
1302 int i = (I16)mg->mg_private;
1304 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1308 const char * sig = MgPV_const(mg, siglen);
1309 mg->mg_private = i = whichsig_pvn(sig, siglen);
1314 sv_setsv(sv,PL_psig_ptr[i]);
1316 Sighandler_t sigstate = rsignal_state(i);
1317 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1318 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1321 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1322 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1325 /* cache state so we don't fetch it again */
1326 if(sigstate == (Sighandler_t) SIG_IGN)
1327 sv_setpvs(sv,"IGNORE");
1329 sv_setsv(sv,&PL_sv_undef);
1330 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1337 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1339 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1341 magic_setsig(NULL, mg);
1342 return sv_unmagic(sv, mg->mg_type);
1346 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1347 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1349 Perl_csighandler(int sig)
1352 #ifdef PERL_GET_SIG_CONTEXT
1353 dTHXa(PERL_GET_SIG_CONTEXT);
1357 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1358 (void) rsignal(sig, PL_csighandlerp);
1359 if (PL_sig_ignoring[sig]) return;
1361 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1362 if (PL_sig_defaulting[sig])
1363 #ifdef KILL_BY_SIGPRC
1364 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1379 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1380 /* Call the perl level handler now--
1381 * with risk we may be in malloc() or being destructed etc. */
1382 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1383 (*PL_sighandlerp)(sig, NULL, NULL);
1385 (*PL_sighandlerp)(sig);
1388 if (!PL_psig_pend) return;
1389 /* Set a flag to say this signal is pending, that is awaiting delivery after
1390 * the current Perl opcode completes */
1391 PL_psig_pend[sig]++;
1393 #ifndef SIG_PENDING_DIE_COUNT
1394 # define SIG_PENDING_DIE_COUNT 120
1396 /* Add one to say _a_ signal is pending */
1397 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1398 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1399 (unsigned long)SIG_PENDING_DIE_COUNT);
1403 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1405 Perl_csighandler_init(void)
1408 if (PL_sig_handlers_initted) return;
1410 for (sig = 1; sig < SIG_SIZE; sig++) {
1411 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1413 PL_sig_defaulting[sig] = 1;
1414 (void) rsignal(sig, PL_csighandlerp);
1416 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1417 PL_sig_ignoring[sig] = 0;
1420 PL_sig_handlers_initted = 1;
1424 #if defined HAS_SIGPROCMASK
1426 unblock_sigmask(pTHX_ void* newset)
1428 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1433 Perl_despatch_signals(pTHX)
1438 for (sig = 1; sig < SIG_SIZE; sig++) {
1439 if (PL_psig_pend[sig]) {
1441 #ifdef HAS_SIGPROCMASK
1442 /* From sigaction(2) (FreeBSD man page):
1443 * | Signal routines normally execute with the signal that
1444 * | caused their invocation blocked, but other signals may
1446 * Emulation of this behavior (from within Perl) is enabled
1450 sigset_t newset, oldset;
1452 sigemptyset(&newset);
1453 sigaddset(&newset, sig);
1454 sigprocmask(SIG_BLOCK, &newset, &oldset);
1455 was_blocked = sigismember(&oldset, sig);
1457 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1459 SAVEFREESV(save_sv);
1460 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1463 PL_psig_pend[sig] = 0;
1464 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1465 (*PL_sighandlerp)(sig, NULL, NULL);
1467 (*PL_sighandlerp)(sig);
1469 #ifdef HAS_SIGPROCMASK
1478 /* sv of NULL signifies that we're acting as magic_clearsig. */
1480 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1485 /* Need to be careful with SvREFCNT_dec(), because that can have side
1486 * effects (due to closures). We must make sure that the new disposition
1487 * is in place before it is called.
1491 #ifdef HAS_SIGPROCMASK
1495 const char *s = MgPV_const(mg,len);
1497 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1500 if (memEQs(s, len, "__DIE__"))
1502 else if (memEQs(s, len, "__WARN__")
1503 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1504 /* Merge the existing behaviours, which are as follows:
1505 magic_setsig, we always set svp to &PL_warnhook
1506 (hence we always change the warnings handler)
1507 For magic_clearsig, we don't change the warnings handler if it's
1508 set to the &PL_warnhook. */
1511 SV *tmp = sv_newmortal();
1512 Perl_croak(aTHX_ "No such hook: %s",
1513 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1517 if (*svp != PERL_WARNHOOK_FATAL)
1523 i = (I16)mg->mg_private;
1525 i = whichsig_pvn(s, len); /* ...no, a brick */
1526 mg->mg_private = (U16)i;
1530 SV *tmp = sv_newmortal();
1531 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1532 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1536 #ifdef HAS_SIGPROCMASK
1537 /* Avoid having the signal arrive at a bad time, if possible. */
1540 sigprocmask(SIG_BLOCK, &set, &save);
1542 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1543 SAVEFREESV(save_sv);
1544 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1547 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1548 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1550 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1551 PL_sig_ignoring[i] = 0;
1553 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1554 PL_sig_defaulting[i] = 0;
1556 to_dec = PL_psig_ptr[i];
1558 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1559 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1561 /* Signals don't change name during the program's execution, so once
1562 they're cached in the appropriate slot of PL_psig_name, they can
1565 Ideally we'd find some way of making SVs at (C) compile time, or
1566 at least, doing most of the work. */
1567 if (!PL_psig_name[i]) {
1568 PL_psig_name[i] = newSVpvn(s, len);
1569 SvREADONLY_on(PL_psig_name[i]);
1572 SvREFCNT_dec(PL_psig_name[i]);
1573 PL_psig_name[i] = NULL;
1574 PL_psig_ptr[i] = NULL;
1577 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1579 (void)rsignal(i, PL_csighandlerp);
1582 *svp = SvREFCNT_inc_simple_NN(sv);
1584 if (sv && SvOK(sv)) {
1585 s = SvPV_force(sv, len);
1589 if (sv && memEQs(s, len,"IGNORE")) {
1591 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1592 PL_sig_ignoring[i] = 1;
1593 (void)rsignal(i, PL_csighandlerp);
1595 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1599 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1601 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1602 PL_sig_defaulting[i] = 1;
1603 (void)rsignal(i, PL_csighandlerp);
1605 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1611 * We should warn if HINT_STRICT_REFS, but without
1612 * access to a known hint bit in a known OP, we can't
1613 * tell whether HINT_STRICT_REFS is in force or not.
1615 if (!strchr(s,':') && !strchr(s,'\''))
1616 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1619 (void)rsignal(i, PL_csighandlerp);
1621 *svp = SvREFCNT_inc_simple_NN(sv);
1625 #ifdef HAS_SIGPROCMASK
1629 SvREFCNT_dec(to_dec);
1632 #endif /* !PERL_MICRO */
1635 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1638 PERL_ARGS_ASSERT_MAGIC_SETISA;
1639 PERL_UNUSED_ARG(sv);
1641 /* Skip _isaelem because _isa will handle it shortly */
1642 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1645 return magic_clearisa(NULL, mg);
1648 /* sv of NULL signifies that we're acting as magic_setisa. */
1650 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1655 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1657 /* Bail out if destruction is going on */
1658 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1661 av_clear(MUTABLE_AV(sv));
1663 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1664 /* This occurs with setisa_elem magic, which calls this
1666 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1668 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1669 SV **svp = AvARRAY((AV *)mg->mg_obj);
1670 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1672 stash = GvSTASH((GV *)*svp++);
1673 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1680 (const GV *)mg->mg_obj
1683 /* The stash may have been detached from the symbol table, so check its
1684 name before doing anything. */
1685 if (stash && HvENAME_get(stash))
1686 mro_isa_changed_in(stash);
1692 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1694 HV * const hv = MUTABLE_HV(LvTARG(sv));
1697 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1698 PERL_UNUSED_ARG(mg);
1701 (void) hv_iterinit(hv);
1702 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1705 while (hv_iternext(hv))
1710 sv_setiv(sv, (IV)i);
1715 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1717 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1718 PERL_UNUSED_ARG(mg);
1720 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1726 =for apidoc magic_methcall
1728 Invoke a magic method (like FETCH).
1730 C<sv> and C<mg> are the tied thingy and the tie magic.
1732 C<meth> is the name of the method to call.
1734 C<argc> is the number of args (in addition to $self) to pass to the method.
1736 The C<flags> can be:
1738 G_DISCARD invoke method with G_DISCARD flag and don't
1740 G_UNDEF_FILL fill the stack with argc pointers to
1743 The arguments themselves are any values following the C<flags> argument.
1745 Returns the SV (if any) returned by the method, or NULL on failure.
1752 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1759 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1763 if (flags & G_WRITING_TO_STDERR) {
1767 SAVESPTR(PL_stderrgv);
1771 PUSHSTACKi(PERLSI_MAGIC);
1775 PUSHs(SvTIED_obj(sv, mg));
1776 if (flags & G_UNDEF_FILL) {
1778 PUSHs(&PL_sv_undef);
1780 } else if (argc > 0) {
1782 va_start(args, argc);
1785 SV *const sv = va_arg(args, SV *);
1792 if (flags & G_DISCARD) {
1793 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1796 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1797 ret = *PL_stack_sp--;
1800 if (flags & G_WRITING_TO_STDERR)
1806 /* wrapper for magic_methcall that creates the first arg */
1809 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1815 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1818 if (mg->mg_len >= 0) {
1819 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1821 else if (mg->mg_len == HEf_SVKEY)
1822 arg1 = MUTABLE_SV(mg->mg_ptr);
1824 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1825 arg1 = newSViv((IV)(mg->mg_len));
1829 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1831 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1835 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1840 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1842 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1849 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1853 if (mg->mg_type == PERL_MAGIC_tiedelem)
1854 mg->mg_flags |= MGf_GSKIP;
1855 magic_methpack(sv,mg,SV_CONST(FETCH));
1860 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1866 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1868 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1869 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1870 * public flags indicate its value based on copying from $val. Doing
1871 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1872 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1873 * wrong if $val happened to be tainted, as sv hasn't got magic
1874 * enabled, even though taint magic is in the chain. In which case,
1875 * fake up a temporary tainted value (this is easier than temporarily
1876 * re-enabling magic on sv). */
1878 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1879 && (tmg->mg_len & 1))
1881 val = sv_mortalcopy(sv);
1887 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
1892 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1894 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1896 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1897 return magic_methpack(sv,mg,SV_CONST(DELETE));
1902 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1908 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1910 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
1912 retval = SvIV(retsv)-1;
1914 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1916 return (U32) retval;
1920 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1924 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1926 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
1931 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1936 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1938 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1939 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
1946 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1948 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1950 return magic_methpack(sv,mg,SV_CONST(EXISTS));
1954 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1958 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1959 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1961 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1963 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1965 if (HvEITER_get(hv))
1966 /* we are in an iteration so the hash cannot be empty */
1968 /* no xhv_eiter so now use FIRSTKEY */
1969 key = sv_newmortal();
1970 magic_nextpack(MUTABLE_SV(hv), mg, key);
1971 HvEITER_set(hv, NULL); /* need to reset iterator */
1972 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1975 /* there is a SCALAR method that we can call */
1976 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
1978 retval = &PL_sv_undef;
1983 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1986 GV * const gv = PL_DBline;
1987 const I32 i = SvTRUE(sv);
1988 SV ** const svp = av_fetch(GvAV(gv),
1989 atoi(MgPV_nolen_const(mg)), FALSE);
1991 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1993 if (svp && SvIOKp(*svp)) {
1994 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1996 #ifdef PERL_DEBUG_READONLY_OPS
1997 Slab_to_rw(OpSLAB(o));
1999 /* set or clear breakpoint in the relevant control op */
2001 o->op_flags |= OPf_SPECIAL;
2003 o->op_flags &= ~OPf_SPECIAL;
2004 #ifdef PERL_DEBUG_READONLY_OPS
2005 Slab_to_ro(OpSLAB(o));
2013 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2016 AV * const obj = MUTABLE_AV(mg->mg_obj);
2018 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2021 sv_setiv(sv, AvFILL(obj));
2029 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2032 AV * const obj = MUTABLE_AV(mg->mg_obj);
2034 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2037 av_fill(obj, SvIV(sv));
2039 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2040 "Attempt to set length of freed array");
2046 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2050 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2051 PERL_UNUSED_ARG(sv);
2053 /* Reset the iterator when the array is cleared */
2054 #if IVSIZE == I32SIZE
2055 *((IV *) &(mg->mg_len)) = 0;
2058 *((IV *) mg->mg_ptr) = 0;
2065 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2069 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2070 PERL_UNUSED_ARG(sv);
2072 /* during global destruction, mg_obj may already have been freed */
2073 if (PL_in_clean_all)
2076 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2079 /* arylen scalar holds a pointer back to the array, but doesn't own a
2080 reference. Hence the we (the array) are about to go away with it
2081 still pointing at us. Clear its pointer, else it would be pointing
2082 at free memory. See the comment in sv_magic about reference loops,
2083 and why it can't own a reference to us. */
2090 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2093 SV* const lsv = LvTARG(sv);
2094 MAGIC * const found = mg_find_mglob(lsv);
2096 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2097 PERL_UNUSED_ARG(mg);
2099 if (found && found->mg_len >= 0) {
2100 I32 i = found->mg_len;
2102 sv_pos_b2u(lsv, &i);
2111 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2114 SV* const lsv = LvTARG(sv);
2121 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2122 PERL_UNUSED_ARG(mg);
2124 found = mg_find_mglob(lsv);
2128 found = sv_magicext_mglob(lsv);
2130 else if (!SvOK(sv)) {
2134 s = SvPV_const(lsv, len);
2139 ulen = sv_or_pv_len_utf8(lsv, s, len);
2149 else if (pos > (SSize_t)len)
2153 pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
2156 found->mg_len = pos;
2157 found->mg_flags &= ~MGf_MINMATCH;
2163 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2166 SV * const lsv = LvTARG(sv);
2167 const char * const tmps = SvPV_const(lsv,len);
2168 STRLEN offs = LvTARGOFF(sv);
2169 STRLEN rem = LvTARGLEN(sv);
2170 const bool negoff = LvFLAGS(sv) & 1;
2171 const bool negrem = LvFLAGS(sv) & 2;
2173 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2174 PERL_UNUSED_ARG(mg);
2176 if (!translate_substr_offsets(
2177 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2178 negoff ? -(IV)offs : (IV)offs, !negoff,
2179 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2181 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2182 sv_setsv_nomg(sv, &PL_sv_undef);
2187 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2188 sv_setpvn(sv, tmps + offs, rem);
2195 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2198 STRLEN len, lsv_len, oldtarglen, newtarglen;
2199 const char * const tmps = SvPV_const(sv, len);
2200 SV * const lsv = LvTARG(sv);
2201 STRLEN lvoff = LvTARGOFF(sv);
2202 STRLEN lvlen = LvTARGLEN(sv);
2203 const bool negoff = LvFLAGS(sv) & 1;
2204 const bool neglen = LvFLAGS(sv) & 2;
2206 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2207 PERL_UNUSED_ARG(mg);
2211 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2212 "Attempt to use reference as lvalue in substr"
2214 SvPV_force_nomg(lsv,lsv_len);
2215 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2216 if (!translate_substr_offsets(
2218 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2219 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2221 Perl_croak(aTHX_ "substr outside of string");
2224 sv_utf8_upgrade_nomg(lsv);
2225 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2226 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2227 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2230 else if (SvUTF8(lsv)) {
2232 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2234 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2235 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2239 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2242 if (!neglen) LvTARGLEN(sv) = newtarglen;
2243 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2249 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2253 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2254 PERL_UNUSED_ARG(sv);
2255 #ifdef NO_TAINT_SUPPORT
2256 PERL_UNUSED_ARG(mg);
2259 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2264 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2268 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2269 PERL_UNUSED_ARG(sv);
2271 /* update taint status */
2280 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2282 SV * const lsv = LvTARG(sv);
2284 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2285 PERL_UNUSED_ARG(mg);
2288 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2296 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2298 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2299 PERL_UNUSED_ARG(mg);
2300 do_vecset(sv); /* XXX slurp this routine */
2305 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2309 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2310 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2312 if (LvTARGLEN(sv)) {
2314 SV * const ahv = LvTARG(sv);
2315 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2320 AV *const av = MUTABLE_AV(LvTARG(sv));
2321 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2322 targ = AvARRAY(av)[LvTARGOFF(sv)];
2324 if (targ && (targ != &PL_sv_undef)) {
2325 /* somebody else defined it for us */
2326 SvREFCNT_dec(LvTARG(sv));
2327 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2329 SvREFCNT_dec(mg->mg_obj);
2331 mg->mg_flags &= ~MGf_REFCOUNTED;
2340 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2342 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2344 sv_setsv(sv, defelem_target(sv, mg));
2349 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2351 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2352 PERL_UNUSED_ARG(mg);
2356 sv_setsv(LvTARG(sv), sv);
2357 SvSETMAGIC(LvTARG(sv));
2363 Perl_vivify_defelem(pTHX_ SV *sv)
2369 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2371 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2374 SV * const ahv = LvTARG(sv);
2375 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2378 if (!value || value == &PL_sv_undef)
2379 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2382 AV *const av = MUTABLE_AV(LvTARG(sv));
2383 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2384 LvTARG(sv) = NULL; /* array can't be extended */
2386 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2387 if (!svp || (value = *svp) == &PL_sv_undef)
2388 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2391 SvREFCNT_inc_simple_void(value);
2392 SvREFCNT_dec(LvTARG(sv));
2395 SvREFCNT_dec(mg->mg_obj);
2397 mg->mg_flags &= ~MGf_REFCOUNTED;
2401 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2403 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2404 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2409 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2411 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2412 PERL_UNUSED_CONTEXT;
2413 PERL_UNUSED_ARG(sv);
2419 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2421 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2423 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2425 if (uf && uf->uf_set)
2426 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2431 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2433 const char type = mg->mg_type;
2435 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2437 if (type == PERL_MAGIC_qr) {
2438 } else if (type == PERL_MAGIC_bm) {
2442 assert(type == PERL_MAGIC_fm);
2444 return sv_unmagic(sv, type);
2447 #ifdef USE_LOCALE_COLLATE
2449 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2451 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2454 * RenE<eacute> Descartes said "I think not."
2455 * and vanished with a faint plop.
2457 PERL_UNUSED_CONTEXT;
2458 PERL_UNUSED_ARG(sv);
2460 Safefree(mg->mg_ptr);
2466 #endif /* USE_LOCALE_COLLATE */
2468 /* Just clear the UTF-8 cache data. */
2470 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2472 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2473 PERL_UNUSED_CONTEXT;
2474 PERL_UNUSED_ARG(sv);
2475 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2477 mg->mg_len = -1; /* The mg_len holds the len cache. */
2482 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2488 const char * const remaining = mg->mg_ptr + 1;
2493 PERL_ARGS_ASSERT_MAGIC_SET;
2495 switch (*mg->mg_ptr) {
2496 case '\015': /* $^MATCH */
2497 if (strEQ(remaining, "ATCH"))
2499 case '`': /* ${^PREMATCH} caught below */
2501 paren = RX_BUFF_IDX_PREMATCH;
2503 case '\'': /* ${^POSTMATCH} caught below */
2505 paren = RX_BUFF_IDX_POSTMATCH;
2509 paren = RX_BUFF_IDX_FULLMATCH;
2511 case '1': case '2': case '3': case '4':
2512 case '5': case '6': case '7': case '8': case '9':
2513 paren = atoi(mg->mg_ptr);
2515 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2517 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2519 /* Croak with a READONLY error when a numbered match var is
2520 * set without a previous pattern match. Unless it's C<local $1>
2523 if (!PL_localizing) {
2524 Perl_croak_no_modify();
2528 case '\001': /* ^A */
2529 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2530 else SvOK_off(PL_bodytarget);
2531 FmLINES(PL_bodytarget) = 0;
2532 if (SvPOK(PL_bodytarget)) {
2533 char *s = SvPVX(PL_bodytarget);
2534 while ( ((s = strchr(s, '\n'))) ) {
2535 FmLINES(PL_bodytarget)++;
2539 /* mg_set() has temporarily made sv non-magical */
2541 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2542 SvTAINTED_on(PL_bodytarget);
2544 SvTAINTED_off(PL_bodytarget);
2547 case '\003': /* ^C */
2548 PL_minus_c = cBOOL(SvIV(sv));
2551 case '\004': /* ^D */
2553 s = SvPV_nolen_const(sv);
2554 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2555 if (DEBUG_x_TEST || DEBUG_B_TEST)
2556 dump_all_perl(!DEBUG_B_TEST);
2558 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2561 case '\005': /* ^E */
2562 if (*(mg->mg_ptr+1) == '\0') {
2564 set_vaxc_errno(SvIV(sv));
2567 SetLastError( SvIV(sv) );
2570 os2_setsyserrno(SvIV(sv));
2572 /* will anyone ever use this? */
2573 SETERRNO(SvIV(sv), 4);
2578 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2579 SvREFCNT_dec(PL_encoding);
2580 if (SvOK(sv) || SvGMAGICAL(sv)) {
2581 PL_encoding = newSVsv(sv);
2588 case '\006': /* ^F */
2589 PL_maxsysfd = SvIV(sv);
2591 case '\010': /* ^H */
2592 PL_hints = SvIV(sv);
2594 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2595 Safefree(PL_inplace);
2596 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2598 case '\016': /* ^N */
2599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2600 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2602 case '\017': /* ^O */
2603 if (*(mg->mg_ptr+1) == '\0') {
2604 Safefree(PL_osname);
2607 TAINT_PROPER("assigning to $^O");
2608 PL_osname = savesvpv(sv);
2611 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2613 const char *const start = SvPV(sv, len);
2614 const char *out = (const char*)memchr(start, '\0', len);
2618 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2619 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2621 /* Opening for input is more common than opening for output, so
2622 ensure that hints for input are sooner on linked list. */
2623 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2625 : newSVpvs_flags("", SvUTF8(sv));
2626 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2629 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2631 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2635 case '\020': /* ^P */
2636 if (*remaining == '\0') { /* ^P */
2637 PL_perldb = SvIV(sv);
2638 if (PL_perldb && !PL_DBsingle)
2641 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2643 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2647 case '\024': /* ^T */
2649 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2651 PL_basetime = (Time_t)SvIV(sv);
2654 case '\025': /* ^UTF8CACHE */
2655 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2656 PL_utf8cache = (signed char) sv_2iv(sv);
2659 case '\027': /* ^W & $^WARNING_BITS */
2660 if (*(mg->mg_ptr+1) == '\0') {
2661 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2663 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2664 | (i ? G_WARN_ON : G_WARN_OFF) ;
2667 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2668 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2670 PL_compiling.cop_warnings = pWARN_STD;
2675 int accumulate = 0 ;
2676 int any_fatals = 0 ;
2677 const char * const ptr = SvPV_const(sv, len) ;
2678 for (i = 0 ; i < len ; ++i) {
2679 accumulate |= ptr[i] ;
2680 any_fatals |= (ptr[i] & 0xAA) ;
2683 if (!specialWARN(PL_compiling.cop_warnings))
2684 PerlMemShared_free(PL_compiling.cop_warnings);
2685 PL_compiling.cop_warnings = pWARN_NONE;
2687 /* Yuck. I can't see how to abstract this: */
2689 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2693 if (!specialWARN(PL_compiling.cop_warnings))
2694 PerlMemShared_free(PL_compiling.cop_warnings);
2695 PL_compiling.cop_warnings = pWARN_ALL;
2696 PL_dowarn |= G_WARN_ONCE ;
2700 const char *const p = SvPV_const(sv, len);
2702 PL_compiling.cop_warnings
2703 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2706 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2707 PL_dowarn |= G_WARN_ONCE ;
2715 if (PL_localizing) {
2716 if (PL_localizing == 1)
2717 SAVESPTR(PL_last_in_gv);
2719 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2720 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2723 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2724 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2725 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2728 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2729 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2730 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2733 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2736 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2737 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2738 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2741 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2745 IO * const io = GvIO(PL_defoutgv);
2748 if ((SvIV(sv)) == 0)
2749 IoFLAGS(io) &= ~IOf_FLUSH;
2751 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2752 PerlIO *ofp = IoOFP(io);
2754 (void)PerlIO_flush(ofp);
2755 IoFLAGS(io) |= IOf_FLUSH;
2761 SvREFCNT_dec(PL_rs);
2762 PL_rs = newSVsv(sv);
2765 SvREFCNT_dec(PL_ors_sv);
2767 PL_ors_sv = newSVsv(sv);
2775 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2778 #ifdef COMPLEX_STATUS
2779 if (PL_localizing == 2) {
2780 SvUPGRADE(sv, SVt_PVLV);
2781 PL_statusvalue = LvTARGOFF(sv);
2782 PL_statusvalue_vms = LvTARGLEN(sv);
2786 #ifdef VMSISH_STATUS
2788 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2791 STATUS_UNIX_EXIT_SET(SvIV(sv));
2796 # define PERL_VMS_BANG vaxc$errno
2798 # define PERL_VMS_BANG 0
2800 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2801 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2806 const Uid_t new_uid = SvUID(sv);
2807 PL_delaymagic_uid = new_uid;
2808 if (PL_delaymagic) {
2809 PL_delaymagic |= DM_RUID;
2810 break; /* don't do magic till later */
2813 (void)setruid(new_uid);
2816 (void)setreuid(new_uid, (Uid_t)-1);
2818 #ifdef HAS_SETRESUID
2819 (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2821 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2823 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2824 if (new_uid != 0 && PerlProc_getuid() == 0)
2825 (void)PerlProc_setuid(0);
2827 (void)PerlProc_setuid(new_uid);
2829 Perl_croak(aTHX_ "setruid() not implemented");
2838 const Uid_t new_euid = SvUID(sv);
2839 PL_delaymagic_euid = new_euid;
2840 if (PL_delaymagic) {
2841 PL_delaymagic |= DM_EUID;
2842 break; /* don't do magic till later */
2845 (void)seteuid(new_euid);
2848 (void)setreuid((Uid_t)-1, new_euid);
2850 #ifdef HAS_SETRESUID
2851 (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2853 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2854 PerlProc_setuid(new_euid);
2856 Perl_croak(aTHX_ "seteuid() not implemented");
2865 const Gid_t new_gid = SvGID(sv);
2866 PL_delaymagic_gid = new_gid;
2867 if (PL_delaymagic) {
2868 PL_delaymagic |= DM_RGID;
2869 break; /* don't do magic till later */
2872 (void)setrgid(new_gid);
2875 (void)setregid(new_gid, (Gid_t)-1);
2877 #ifdef HAS_SETRESGID
2878 (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2880 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2881 (void)PerlProc_setgid(new_gid);
2883 Perl_croak(aTHX_ "setrgid() not implemented");
2893 #ifdef HAS_SETGROUPS
2895 const char *p = SvPV_const(sv, len);
2896 Groups_t *gary = NULL;
2897 #ifdef _SC_NGROUPS_MAX
2898 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2903 int maxgrp = NGROUPS;
2908 new_egid = (Gid_t)Atol(p);
2909 for (i = 0; i < maxgrp; ++i) {
2910 while (*p && !isSPACE(*p))
2917 Newx(gary, i + 1, Groups_t);
2919 Renew(gary, i + 1, Groups_t);
2920 gary[i] = (Groups_t)Atol(p);
2923 (void)setgroups(i, gary);
2926 #else /* HAS_SETGROUPS */
2927 new_egid = SvGID(sv);
2928 #endif /* HAS_SETGROUPS */
2929 PL_delaymagic_egid = new_egid;
2930 if (PL_delaymagic) {
2931 PL_delaymagic |= DM_EGID;
2932 break; /* don't do magic till later */
2935 (void)setegid(new_egid);
2938 (void)setregid((Gid_t)-1, new_egid);
2940 #ifdef HAS_SETRESGID
2941 (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2943 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2944 (void)PerlProc_setgid(new_egid);
2946 Perl_croak(aTHX_ "setegid() not implemented");
2954 PL_chopset = SvPV_force(sv,len);
2957 /* Store the pid in mg->mg_obj so we can tell when a fork has
2958 occurred. mg->mg_obj points to *$ by default, so clear it. */
2959 if (isGV(mg->mg_obj)) {
2960 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2961 SvREFCNT_dec(mg->mg_obj);
2962 mg->mg_flags |= MGf_REFCOUNTED;
2963 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2965 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2968 LOCK_DOLLARZERO_MUTEX;
2969 #ifdef HAS_SETPROCTITLE
2970 /* The BSDs don't show the argv[] in ps(1) output, they
2971 * show a string from the process struct and provide
2972 * the setproctitle() routine to manipulate that. */
2973 if (PL_origalen != 1) {
2974 s = SvPV_const(sv, len);
2975 # if __FreeBSD_version > 410001
2976 /* The leading "-" removes the "perl: " prefix,
2977 * but not the "(perl) suffix from the ps(1)
2978 * output, because that's what ps(1) shows if the
2979 * argv[] is modified. */
2980 setproctitle("-%s", s);
2981 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2982 /* This doesn't really work if you assume that
2983 * $0 = 'foobar'; will wipe out 'perl' from the $0
2984 * because in ps(1) output the result will be like
2985 * sprintf("perl: %s (perl)", s)
2986 * I guess this is a security feature:
2987 * one (a user process) cannot get rid of the original name.
2989 setproctitle("%s", s);
2992 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2993 if (PL_origalen != 1) {
2995 s = SvPV_const(sv, len);
2996 un.pst_command = (char *)s;
2997 pstat(PSTAT_SETCMD, un, len, 0, 0);
3000 if (PL_origalen > 1) {
3001 /* PL_origalen is set in perl_parse(). */
3002 s = SvPV_force(sv,len);
3003 if (len >= (STRLEN)PL_origalen-1) {
3004 /* Longer than original, will be truncated. We assume that
3005 * PL_origalen bytes are available. */
3006 Copy(s, PL_origargv[0], PL_origalen-1, char);
3009 /* Shorter than original, will be padded. */
3011 /* Special case for Mac OS X: see [perl #38868] */
3014 /* Is the space counterintuitive? Yes.
3015 * (You were expecting \0?)
3016 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3018 const int pad = ' ';
3020 Copy(s, PL_origargv[0], len, char);
3021 PL_origargv[0][len] = 0;
3022 memset(PL_origargv[0] + len + 1,
3023 pad, PL_origalen - len - 1);
3025 PL_origargv[0][PL_origalen-1] = 0;
3026 for (i = 1; i < PL_origargc; i++)
3028 #ifdef HAS_PRCTL_SET_NAME
3029 /* Set the legacy process name in addition to the POSIX name on Linux */
3030 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3031 /* diag_listed_as: SKIPME */
3032 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3037 UNLOCK_DOLLARZERO_MUTEX;
3044 Perl_whichsig_sv(pTHX_ SV *sigsv)
3048 PERL_ARGS_ASSERT_WHICHSIG_SV;
3049 PERL_UNUSED_CONTEXT;
3050 sigpv = SvPV_const(sigsv, siglen);
3051 return whichsig_pvn(sigpv, siglen);
3055 Perl_whichsig_pv(pTHX_ const char *sig)
3057 PERL_ARGS_ASSERT_WHICHSIG_PV;
3058 PERL_UNUSED_CONTEXT;
3059 return whichsig_pvn(sig, strlen(sig));
3063 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3067 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3068 PERL_UNUSED_CONTEXT;
3070 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3071 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3072 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3074 if (memEQs(sig, len, "CHLD"))
3078 if (memEQs(sig, len, "CLD"))
3085 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3086 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3088 Perl_sighandler(int sig)
3091 #ifdef PERL_GET_SIG_CONTEXT
3092 dTHXa(PERL_GET_SIG_CONTEXT);
3099 SV * const tSv = PL_Sv;
3103 XPV * const tXpv = PL_Xpv;
3104 I32 old_ss_ix = PL_savestack_ix;
3105 SV *errsv_save = NULL;
3108 if (!PL_psig_ptr[sig]) {
3109 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3114 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3115 /* Max number of items pushed there is 3*n or 4. We cannot fix
3116 infinity, so we fix 4 (in fact 5): */
3117 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3119 PL_savestack_ix += 5; /* Protect save in progress. */
3120 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3123 /* sv_2cv is too complicated, try a simpler variant first: */
3124 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3125 || SvTYPE(cv) != SVt_PVCV) {
3127 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3130 if (!cv || !CvROOT(cv)) {
3131 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3132 PL_sig_name[sig], (gv ? GvENAME(gv)
3139 sv = PL_psig_name[sig]
3140 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3141 : newSVpv(PL_sig_name[sig],0);
3145 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3146 /* make sure our assumption about the size of the SAVEs are correct:
3147 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3148 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3151 PUSHSTACKi(PERLSI_SIGNAL);
3154 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3156 struct sigaction oact;
3158 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3161 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3162 /* The siginfo fields signo, code, errno, pid, uid,
3163 * addr, status, and band are defined by POSIX/SUSv3. */
3164 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3165 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3166 #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
3167 hv_stores(sih, "errno", newSViv(sip->si_errno));
3168 hv_stores(sih, "status", newSViv(sip->si_status));
3169 hv_stores(sih, "uid", newSViv(sip->si_uid));
3170 hv_stores(sih, "pid", newSViv(sip->si_pid));
3171 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3172 hv_stores(sih, "band", newSViv(sip->si_band));
3176 mPUSHp((char *)sip, sizeof(*sip));
3184 errsv_save = newSVsv(ERRSV);
3186 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3190 SV * const errsv = ERRSV;
3191 if (SvTRUE_NN(errsv)) {
3192 SvREFCNT_dec(errsv_save);
3194 /* Handler "died", for example to get out of a restart-able read().
3195 * Before we re-do that on its behalf re-enable the signal which was
3196 * blocked by the system when we entered.
3198 #ifdef HAS_SIGPROCMASK
3199 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3205 sigaddset(&set,sig);
3206 sigprocmask(SIG_UNBLOCK, &set, NULL);
3209 /* Not clear if this will work */
3210 (void)rsignal(sig, SIG_IGN);
3211 (void)rsignal(sig, PL_csighandlerp);
3213 #endif /* !PERL_MICRO */
3217 sv_setsv(errsv, errsv_save);
3218 SvREFCNT_dec(errsv_save);
3223 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3224 PL_savestack_ix = old_ss_ix;
3226 SvREFCNT_dec_NN(sv);
3227 PL_op = myop; /* Apparently not needed... */
3229 PL_Sv = tSv; /* Restore global temporaries. */
3236 S_restore_magic(pTHX_ const void *p)
3239 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3240 SV* const sv = mgs->mgs_sv;
3246 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3247 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3248 #ifdef PERL_OLD_COPY_ON_WRITE
3249 /* While magic was saved (and off) sv_setsv may well have seen
3250 this SV as a prime candidate for COW. */
3252 sv_force_normal_flags(sv, 0);
3254 if (mgs->mgs_readonly)
3256 if (mgs->mgs_magical)
3257 SvFLAGS(sv) |= mgs->mgs_magical;
3262 bumped = mgs->mgs_bumped;
3263 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3265 /* If we're still on top of the stack, pop us off. (That condition
3266 * will be satisfied if restore_magic was called explicitly, but *not*
3267 * if it's being called via leave_scope.)
3268 * The reason for doing this is that otherwise, things like sv_2cv()
3269 * may leave alloc gunk on the savestack, and some code
3270 * (e.g. sighandler) doesn't expect that...
3272 if (PL_savestack_ix == mgs->mgs_ss_ix)
3274 UV popval = SSPOPUV;
3275 assert(popval == SAVEt_DESTRUCTOR_X);
3276 PL_savestack_ix -= 2;
3278 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3279 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3282 if (SvREFCNT(sv) == 1) {
3283 /* We hold the last reference to this SV, which implies that the
3284 SV was deleted as a side effect of the routines we called.
3285 So artificially keep it alive a bit longer.
3286 We avoid turning on the TEMP flag, which can cause the SV's
3287 buffer to get stolen (and maybe other stuff). */
3292 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3296 /* clean up the mess created by Perl_sighandler().
3297 * Note that this is only called during an exit in a signal handler;
3298 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3302 S_unwind_handler_stack(pTHX_ const void *p)
3307 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3311 =for apidoc magic_sethint
3313 Triggered by a store to %^H, records the key/value pair to
3314 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3315 anything that would need a deep copy. Maybe we should warn if we find a
3321 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3324 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3325 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3327 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3329 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3330 an alternative leaf in there, with PL_compiling.cop_hints being used if
3331 it's NULL. If needed for threads, the alternative could lock a mutex,
3332 or take other more complex action. */
3334 /* Something changed in %^H, so it will need to be restored on scope exit.
3335 Doing this here saves a lot of doing it manually in perl code (and
3336 forgetting to do it, and consequent subtle errors. */
3337 PL_hints |= HINT_LOCALIZE_HH;
3338 CopHINTHASH_set(&PL_compiling,
3339 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3344 =for apidoc magic_clearhint
3346 Triggered by a delete from %^H, records the key to
3347 C<PL_compiling.cop_hints_hash>.
3352 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3356 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3357 PERL_UNUSED_ARG(sv);
3359 PL_hints |= HINT_LOCALIZE_HH;
3360 CopHINTHASH_set(&PL_compiling,
3361 mg->mg_len == HEf_SVKEY
3362 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3363 MUTABLE_SV(mg->mg_ptr), 0, 0)
3364 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3365 mg->mg_ptr, mg->mg_len, 0, 0));
3370 =for apidoc magic_clearhints
3372 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3377 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3379 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3380 PERL_UNUSED_ARG(sv);
3381 PERL_UNUSED_ARG(mg);
3382 cophh_free(CopHINTHASH_get(&PL_compiling));
3383 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3388 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3389 const char *name, I32 namlen)
3393 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3394 PERL_UNUSED_ARG(sv);
3395 PERL_UNUSED_ARG(name);
3396 PERL_UNUSED_ARG(namlen);
3398 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3399 nmg = mg_find(nsv, mg->mg_type);
3400 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3401 nmg->mg_ptr = mg->mg_ptr;
3402 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3403 nmg->mg_flags |= MGf_REFCOUNTED;
3409 * c-indentation-style: bsd
3411 * indent-tabs-mode: nil
3414 * ex: set ts=8 sts=4 sw=4 et: