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) != 0;
120 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
121 mgs->mgs_bumped = bumped;
123 SvFLAGS(sv) &= ~flags;
127 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
130 =for apidoc mg_magical
132 Turns on the magical status of an SV. See C<sv_magic>.
138 Perl_mg_magical(pTHX_ SV *sv)
141 PERL_ARGS_ASSERT_MG_MAGICAL;
145 if ((mg = SvMAGIC(sv))) {
147 const MGVTBL* const vtbl = mg->mg_virtual;
149 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
156 } while ((mg = mg->mg_moremagic));
157 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
165 Do magic before a value is retrieved from the SV. The type of SV must
166 be >= SVt_PVMG. See C<sv_magic>.
172 Perl_mg_get(pTHX_ SV *sv)
175 const I32 mgs_ix = SSNEW(sizeof(MGS));
178 MAGIC *newmg, *head, *cur, *mg;
180 PERL_ARGS_ASSERT_MG_GET;
182 if (PL_localizing == 1 && sv == DEFSV) return 0;
184 /* We must call svt_get(sv, mg) for each valid entry in the linked
185 list of magic. svt_get() may delete the current entry, add new
186 magic to the head of the list, or upgrade the SV. AMS 20010810 */
188 newmg = cur = head = mg = SvMAGIC(sv);
190 const MGVTBL * const vtbl = mg->mg_virtual;
191 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
193 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
195 /* taint's mg get is so dumb it doesn't need flag saving */
196 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
197 save_magic(mgs_ix, sv);
201 vtbl->svt_get(aTHX_ sv, mg);
203 /* guard against magic having been deleted - eg FETCH calling
206 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
210 /* recalculate flags if this entry was deleted. */
211 if (mg->mg_flags & MGf_GSKIP)
212 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
214 else if (vtbl == &PL_vtbl_utf8) {
215 /* get-magic can reallocate the PV */
216 magic_setutf8(sv, mg);
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
231 /* Were any new entries added? */
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
241 restore_magic(INT2PTR(void *, (IV)mgs_ix));
249 Do magic after a value is assigned to the SV. See C<sv_magic>.
255 Perl_mg_set(pTHX_ SV *sv)
258 const I32 mgs_ix = SSNEW(sizeof(MGS));
262 PERL_ARGS_ASSERT_MG_SET;
264 if (PL_localizing == 2 && sv == DEFSV) return 0;
266 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
268 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
269 const MGVTBL* vtbl = mg->mg_virtual;
270 nextmg = mg->mg_moremagic; /* it may delete itself */
271 if (mg->mg_flags & MGf_GSKIP) {
272 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
273 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
275 if (PL_localizing == 2
276 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
278 if (vtbl && vtbl->svt_set)
279 vtbl->svt_set(aTHX_ sv, mg);
282 restore_magic(INT2PTR(void*, (IV)mgs_ix));
287 =for apidoc mg_length
289 Reports on the SV's length in bytes, calling length magic if available,
290 but does not set the UTF8 flag on the sv. It will fall back to 'get'
291 magic if there is no 'length' magic, but with no indication as to
292 whether it called 'get' magic. It assumes the sv is a PVMG or
293 higher. Use sv_len() instead.
299 Perl_mg_length(pTHX_ SV *sv)
305 PERL_ARGS_ASSERT_MG_LENGTH;
307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
308 const MGVTBL * const vtbl = mg->mg_virtual;
309 if (vtbl && vtbl->svt_len) {
310 const I32 mgs_ix = SSNEW(sizeof(MGS));
311 save_magic(mgs_ix, sv);
312 /* omit MGf_GSKIP -- not changed here */
313 len = vtbl->svt_len(aTHX_ sv, mg);
314 restore_magic(INT2PTR(void*, (IV)mgs_ix));
319 (void)SvPV_const(sv, len);
324 Perl_mg_size(pTHX_ SV *sv)
328 PERL_ARGS_ASSERT_MG_SIZE;
330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
331 const MGVTBL* const vtbl = mg->mg_virtual;
332 if (vtbl && vtbl->svt_len) {
333 const I32 mgs_ix = SSNEW(sizeof(MGS));
335 save_magic(mgs_ix, sv);
336 /* omit MGf_GSKIP -- not changed here */
337 len = vtbl->svt_len(aTHX_ sv, mg);
338 restore_magic(INT2PTR(void*, (IV)mgs_ix));
345 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
349 Perl_croak(aTHX_ "Size magic not implemented");
358 Clear something magical that the SV represents. See C<sv_magic>.
364 Perl_mg_clear(pTHX_ SV *sv)
366 const I32 mgs_ix = SSNEW(sizeof(MGS));
370 PERL_ARGS_ASSERT_MG_CLEAR;
372 save_magic(mgs_ix, sv);
374 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
375 const MGVTBL* const vtbl = mg->mg_virtual;
376 /* omit GSKIP -- never set here */
378 nextmg = mg->mg_moremagic; /* it may delete itself */
380 if (vtbl && vtbl->svt_clear)
381 vtbl->svt_clear(aTHX_ sv, mg);
384 restore_magic(INT2PTR(void*, (IV)mgs_ix));
389 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
398 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
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 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 (RX_MATCH_UTF8(rx)) {
679 const char * const b = RX_SUBBEG(rx);
681 i = RX_SUBCOFFSET(rx) +
683 (U8*)(b-RX_SUBOFFSET(rx)+i));
698 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
700 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
703 Perl_croak_no_modify();
704 NORETURN_FUNCTION_END;
707 #define SvRTRIM(sv) STMT_START { \
709 STRLEN len = SvCUR(sv); \
710 char * const p = SvPVX(sv); \
711 while (len > 0 && isSPACE(p[len-1])) \
713 SvCUR_set(sv, len); \
719 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
721 PERL_ARGS_ASSERT_EMULATE_COP_IO;
723 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
724 sv_setsv(sv, &PL_sv_undef);
728 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
729 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
734 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
735 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
748 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
752 const char *s = NULL;
754 const char * const remaining = mg->mg_ptr + 1;
757 PERL_ARGS_ASSERT_MAGIC_GET;
761 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
763 CALLREG_NUMBUF_FETCH(rx,paren,sv);
765 sv_setsv(sv,&PL_sv_undef);
770 nextchar = *remaining;
771 switch (*mg->mg_ptr) {
772 case '\001': /* ^A */
773 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
774 else sv_setsv(sv, &PL_sv_undef);
775 if (SvTAINTED(PL_bodytarget))
778 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
779 if (nextchar == '\0') {
780 sv_setiv(sv, (IV)PL_minus_c);
782 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
783 sv_setiv(sv, (IV)STATUS_NATIVE);
787 case '\004': /* ^D */
788 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
790 case '\005': /* ^E */
791 if (nextchar == '\0') {
795 $DESCRIPTOR(msgdsc,msg);
796 sv_setnv(sv,(NV) vaxc$errno);
797 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
798 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
803 if (!(_emx_env & 0x200)) { /* Under DOS */
804 sv_setnv(sv, (NV)errno);
805 sv_setpv(sv, errno ? Strerror(errno) : "");
807 if (errno != errno_isOS2) {
808 const int tmp = _syserrno();
809 if (tmp) /* 2nd call to _syserrno() makes it 0 */
812 sv_setnv(sv, (NV)Perl_rc);
813 sv_setpv(sv, os2error(Perl_rc));
817 const DWORD dwErr = GetLastError();
818 sv_setnv(sv, (NV)dwErr);
820 PerlProc_GetOSError(sv, dwErr);
829 sv_setnv(sv, (NV)errno);
830 sv_setpv(sv, errno ? Strerror(errno) : "");
835 SvNOK_on(sv); /* what a wonderful hack! */
837 else if (strEQ(remaining, "NCODING"))
838 sv_setsv(sv, PL_encoding);
840 case '\006': /* ^F */
841 sv_setiv(sv, (IV)PL_maxsysfd);
843 case '\007': /* ^GLOBAL_PHASE */
844 if (strEQ(remaining, "LOBAL_PHASE")) {
845 sv_setpvn(sv, PL_phase_names[PL_phase],
846 strlen(PL_phase_names[PL_phase]));
849 case '\010': /* ^H */
850 sv_setiv(sv, (IV)PL_hints);
852 case '\011': /* ^I */ /* NOT \t in EBCDIC */
853 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
855 case '\014': /* ^LAST_FH */
856 if (strEQ(remaining, "AST_FH")) {
858 assert(isGV_with_GP(PL_last_in_gv));
859 SV_CHECK_THINKFIRST_COW_DROP(sv);
860 prepare_SV_for_RV(sv);
862 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
866 else sv_setsv_nomg(sv, NULL);
869 case '\017': /* ^O & ^OPEN */
870 if (nextchar == '\0') {
871 sv_setpv(sv, PL_osname);
874 else if (strEQ(remaining, "PEN")) {
875 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
879 sv_setiv(sv, (IV)PL_perldb);
881 case '\023': /* ^S */
883 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
886 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
891 case '\024': /* ^T */
892 if (nextchar == '\0') {
894 sv_setnv(sv, PL_basetime);
896 sv_setiv(sv, (IV)PL_basetime);
899 else if (strEQ(remaining, "AINT"))
900 sv_setiv(sv, TAINTING_get
901 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
904 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
905 if (strEQ(remaining, "NICODE"))
906 sv_setuv(sv, (UV) PL_unicode);
907 else if (strEQ(remaining, "TF8LOCALE"))
908 sv_setuv(sv, (UV) PL_utf8locale);
909 else if (strEQ(remaining, "TF8CACHE"))
910 sv_setiv(sv, (IV) PL_utf8cache);
912 case '\027': /* ^W & $^WARNING_BITS */
913 if (nextchar == '\0')
914 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
915 else if (strEQ(remaining, "ARNING_BITS")) {
916 if (PL_compiling.cop_warnings == pWARN_NONE) {
917 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
919 else if (PL_compiling.cop_warnings == pWARN_STD) {
920 sv_setsv(sv, &PL_sv_undef);
923 else if (PL_compiling.cop_warnings == pWARN_ALL) {
924 /* Get the bit mask for $warnings::Bits{all}, because
925 * it could have been extended by warnings::register */
926 HV * const bits = get_hv("warnings::Bits", 0);
927 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
929 sv_copypv(sv, *bits_all);
931 sv_setpvn(sv, WARN_ALLstring, WARNsize);
934 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
935 *PL_compiling.cop_warnings);
940 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
941 paren = RX_LASTPAREN(rx);
943 goto do_numbuf_fetch;
945 sv_setsv(sv,&PL_sv_undef);
947 case '\016': /* ^N */
948 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
949 paren = RX_LASTCLOSEPAREN(rx);
951 goto do_numbuf_fetch;
953 sv_setsv(sv,&PL_sv_undef);
956 if (GvIO(PL_last_in_gv)) {
957 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
962 sv_setiv(sv, (IV)STATUS_CURRENT);
963 #ifdef COMPLEX_STATUS
964 SvUPGRADE(sv, SVt_PVLV);
965 LvTARGOFF(sv) = PL_statusvalue;
966 LvTARGLEN(sv) = PL_statusvalue_vms;
971 if (GvIOp(PL_defoutgv))
972 s = IoTOP_NAME(GvIOp(PL_defoutgv));
976 sv_setpv(sv,GvENAME(PL_defoutgv));
977 sv_catpvs(sv,"_TOP");
981 if (GvIOp(PL_defoutgv))
982 s = IoFMT_NAME(GvIOp(PL_defoutgv));
984 s = GvENAME(PL_defoutgv);
988 if (GvIO(PL_defoutgv))
989 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
992 if (GvIO(PL_defoutgv))
993 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
996 if (GvIO(PL_defoutgv))
997 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1007 if (GvIO(PL_defoutgv))
1008 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1012 sv_copypv(sv, PL_ors_sv);
1014 sv_setsv(sv, &PL_sv_undef);
1018 IV const pid = (IV)PerlProc_getpid();
1019 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1020 /* never set manually, or at least not since last fork */
1022 /* never unsafe, even if reading in a tainted expression */
1025 /* else a value has been assigned manually, so do nothing */
1033 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1035 sv_setnv(sv, (NV)errno);
1038 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1039 sv_setpv(sv, os2error(Perl_rc));
1047 /* Strerror can return NULL on some platforms, which will result in
1048 * 'sv' not being considered SvOK. The SvNOK_on() below will cause
1049 * just the number part to be valid */
1050 sv_setpv(sv, Strerror(errno));
1052 /* In some locales the error string may come back as UTF-8, in
1053 * which case we should turn on that flag. This didn't use to
1054 * happen, and to avoid any possible backward compatibility issues,
1055 * we don't turn on the flag unless we have to. So the flag stays
1056 * off for an entirely ASCII string. We assume that if the string
1057 * looks like UTF-8, it really is UTF-8: "text in any other
1058 * encoding that uses bytes with the high bit set is extremely
1059 * unlikely to pass a UTF-8 validity test"
1060 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
1061 * potential that we will get it wrong however, especially on short
1062 * error message text. (If it turns out to be necessary, we could
1063 * also keep track if the current LC_MESSAGES locale is UTF-8) */
1064 if (SvOK(sv) /* It could be that Strerror returned invalid */
1065 && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
1066 && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
1075 SvNOK_on(sv); /* what a wonderful hack! */
1078 sv_setuid(sv, PerlProc_getuid());
1081 sv_setuid(sv, PerlProc_geteuid());
1084 sv_setgid(sv, PerlProc_getgid());
1087 sv_setgid(sv, PerlProc_getegid());
1089 #ifdef HAS_GETGROUPS
1091 Groups_t *gary = NULL;
1092 I32 i, num_groups = getgroups(0, gary);
1093 Newx(gary, num_groups, Groups_t);
1094 num_groups = getgroups(num_groups, gary);
1095 for (i = 0; i < num_groups; i++)
1096 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1099 (void)SvIOK_on(sv); /* what a wonderful hack! */
1109 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1111 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1113 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1115 if (uf && uf->uf_val)
1116 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1121 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1124 STRLEN len = 0, klen;
1125 const char * const key = MgPV_const(mg,klen);
1128 PERL_ARGS_ASSERT_MAGIC_SETENV;
1132 /* defined environment variables are byte strings; unfortunately
1133 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1134 (void)SvPV_force_nomg_nolen(sv);
1135 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1137 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1143 my_setenv(key, s); /* does the deed */
1145 #ifdef DYNAMIC_ENV_FETCH
1146 /* We just undefd an environment var. Is a replacement */
1147 /* waiting in the wings? */
1149 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1151 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1155 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1156 /* And you'll never guess what the dog had */
1157 /* in its mouth... */
1159 MgTAINTEDDIR_off(mg);
1161 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1162 char pathbuf[256], eltbuf[256], *cp, *elt;
1165 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1167 do { /* DCL$PATH may be a search list */
1168 while (1) { /* as may dev portion of any element */
1169 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1170 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1171 cando_by_name(S_IWUSR,0,elt) ) {
1172 MgTAINTEDDIR_on(mg);
1176 if ((cp = strchr(elt, ':')) != NULL)
1178 if (my_trnlnm(elt, eltbuf, j++))
1184 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1187 if (s && klen == 4 && strEQ(key,"PATH")) {
1188 const char * const strend = s + len;
1190 while (s < strend) {
1194 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1195 const char path_sep = '|';
1197 const char path_sep = ':';
1199 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1200 s, strend, path_sep, &i);
1202 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1204 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1206 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1208 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1209 MgTAINTEDDIR_on(mg);
1215 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1221 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1223 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1224 PERL_UNUSED_ARG(sv);
1225 my_setenv(MgPV_nolen_const(mg),NULL);
1230 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1233 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1234 PERL_UNUSED_ARG(mg);
1236 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1238 if (PL_localizing) {
1241 hv_iterinit(MUTABLE_HV(sv));
1242 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1244 my_setenv(hv_iterkey(entry, &keylen),
1245 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1253 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1256 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1257 PERL_UNUSED_ARG(sv);
1258 PERL_UNUSED_ARG(mg);
1260 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1268 #ifdef HAS_SIGPROCMASK
1270 restore_sigmask(pTHX_ SV *save_sv)
1272 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1273 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1277 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1280 /* Are we fetching a signal entry? */
1281 int i = (I16)mg->mg_private;
1283 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1287 const char * sig = MgPV_const(mg, siglen);
1288 mg->mg_private = i = whichsig_pvn(sig, siglen);
1293 sv_setsv(sv,PL_psig_ptr[i]);
1295 Sighandler_t sigstate = rsignal_state(i);
1296 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1297 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1300 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1301 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1304 /* cache state so we don't fetch it again */
1305 if(sigstate == (Sighandler_t) SIG_IGN)
1306 sv_setpvs(sv,"IGNORE");
1308 sv_setsv(sv,&PL_sv_undef);
1309 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1316 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1318 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1320 magic_setsig(NULL, mg);
1321 return sv_unmagic(sv, mg->mg_type);
1325 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1326 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1328 Perl_csighandler(int sig)
1331 #ifdef PERL_GET_SIG_CONTEXT
1332 dTHXa(PERL_GET_SIG_CONTEXT);
1336 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1337 (void) rsignal(sig, PL_csighandlerp);
1338 if (PL_sig_ignoring[sig]) return;
1340 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1341 if (PL_sig_defaulting[sig])
1342 #ifdef KILL_BY_SIGPRC
1343 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1358 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1359 /* Call the perl level handler now--
1360 * with risk we may be in malloc() or being destructed etc. */
1361 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1362 (*PL_sighandlerp)(sig, NULL, NULL);
1364 (*PL_sighandlerp)(sig);
1367 if (!PL_psig_pend) return;
1368 /* Set a flag to say this signal is pending, that is awaiting delivery after
1369 * the current Perl opcode completes */
1370 PL_psig_pend[sig]++;
1372 #ifndef SIG_PENDING_DIE_COUNT
1373 # define SIG_PENDING_DIE_COUNT 120
1375 /* Add one to say _a_ signal is pending */
1376 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1377 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1378 (unsigned long)SIG_PENDING_DIE_COUNT);
1382 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1384 Perl_csighandler_init(void)
1387 if (PL_sig_handlers_initted) return;
1389 for (sig = 1; sig < SIG_SIZE; sig++) {
1390 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1392 PL_sig_defaulting[sig] = 1;
1393 (void) rsignal(sig, PL_csighandlerp);
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396 PL_sig_ignoring[sig] = 0;
1399 PL_sig_handlers_initted = 1;
1403 #if defined HAS_SIGPROCMASK
1405 unblock_sigmask(pTHX_ void* newset)
1407 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1412 Perl_despatch_signals(pTHX)
1417 for (sig = 1; sig < SIG_SIZE; sig++) {
1418 if (PL_psig_pend[sig]) {
1420 #ifdef HAS_SIGPROCMASK
1421 /* From sigaction(2) (FreeBSD man page):
1422 * | Signal routines normally execute with the signal that
1423 * | caused their invocation blocked, but other signals may
1425 * Emulation of this behavior (from within Perl) is enabled
1429 sigset_t newset, oldset;
1431 sigemptyset(&newset);
1432 sigaddset(&newset, sig);
1433 sigprocmask(SIG_BLOCK, &newset, &oldset);
1434 was_blocked = sigismember(&oldset, sig);
1436 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1438 SAVEFREESV(save_sv);
1439 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1442 PL_psig_pend[sig] = 0;
1443 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1444 (*PL_sighandlerp)(sig, NULL, NULL);
1446 (*PL_sighandlerp)(sig);
1448 #ifdef HAS_SIGPROCMASK
1457 /* sv of NULL signifies that we're acting as magic_clearsig. */
1459 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1464 /* Need to be careful with SvREFCNT_dec(), because that can have side
1465 * effects (due to closures). We must make sure that the new disposition
1466 * is in place before it is called.
1470 #ifdef HAS_SIGPROCMASK
1474 const char *s = MgPV_const(mg,len);
1476 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1479 if (memEQs(s, len, "__DIE__"))
1481 else if (memEQs(s, len, "__WARN__")
1482 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1483 /* Merge the existing behaviours, which are as follows:
1484 magic_setsig, we always set svp to &PL_warnhook
1485 (hence we always change the warnings handler)
1486 For magic_clearsig, we don't change the warnings handler if it's
1487 set to the &PL_warnhook. */
1490 SV *tmp = sv_newmortal();
1491 Perl_croak(aTHX_ "No such hook: %s",
1492 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1496 if (*svp != PERL_WARNHOOK_FATAL)
1502 i = (I16)mg->mg_private;
1504 i = whichsig_pvn(s, len); /* ...no, a brick */
1505 mg->mg_private = (U16)i;
1509 SV *tmp = sv_newmortal();
1510 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1511 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1515 #ifdef HAS_SIGPROCMASK
1516 /* Avoid having the signal arrive at a bad time, if possible. */
1519 sigprocmask(SIG_BLOCK, &set, &save);
1521 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1522 SAVEFREESV(save_sv);
1523 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1526 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1527 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1529 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1530 PL_sig_ignoring[i] = 0;
1532 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1533 PL_sig_defaulting[i] = 0;
1535 to_dec = PL_psig_ptr[i];
1537 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1538 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1540 /* Signals don't change name during the program's execution, so once
1541 they're cached in the appropriate slot of PL_psig_name, they can
1544 Ideally we'd find some way of making SVs at (C) compile time, or
1545 at least, doing most of the work. */
1546 if (!PL_psig_name[i]) {
1547 PL_psig_name[i] = newSVpvn(s, len);
1548 SvREADONLY_on(PL_psig_name[i]);
1551 SvREFCNT_dec(PL_psig_name[i]);
1552 PL_psig_name[i] = NULL;
1553 PL_psig_ptr[i] = NULL;
1556 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1558 (void)rsignal(i, PL_csighandlerp);
1561 *svp = SvREFCNT_inc_simple_NN(sv);
1563 if (sv && SvOK(sv)) {
1564 s = SvPV_force(sv, len);
1568 if (sv && memEQs(s, len,"IGNORE")) {
1570 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1571 PL_sig_ignoring[i] = 1;
1572 (void)rsignal(i, PL_csighandlerp);
1574 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1578 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1580 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1581 PL_sig_defaulting[i] = 1;
1582 (void)rsignal(i, PL_csighandlerp);
1584 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1590 * We should warn if HINT_STRICT_REFS, but without
1591 * access to a known hint bit in a known OP, we can't
1592 * tell whether HINT_STRICT_REFS is in force or not.
1594 if (!strchr(s,':') && !strchr(s,'\''))
1595 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1598 (void)rsignal(i, PL_csighandlerp);
1600 *svp = SvREFCNT_inc_simple_NN(sv);
1604 #ifdef HAS_SIGPROCMASK
1608 SvREFCNT_dec(to_dec);
1611 #endif /* !PERL_MICRO */
1614 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1617 PERL_ARGS_ASSERT_MAGIC_SETISA;
1618 PERL_UNUSED_ARG(sv);
1620 /* Skip _isaelem because _isa will handle it shortly */
1621 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1624 return magic_clearisa(NULL, mg);
1627 /* sv of NULL signifies that we're acting as magic_setisa. */
1629 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1634 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1636 /* Bail out if destruction is going on */
1637 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1640 av_clear(MUTABLE_AV(sv));
1642 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1643 /* This occurs with setisa_elem magic, which calls this
1645 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1647 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1648 SV **svp = AvARRAY((AV *)mg->mg_obj);
1649 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1651 stash = GvSTASH((GV *)*svp++);
1652 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1659 (const GV *)mg->mg_obj
1662 /* The stash may have been detached from the symbol table, so check its
1663 name before doing anything. */
1664 if (stash && HvENAME_get(stash))
1665 mro_isa_changed_in(stash);
1671 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1673 HV * const hv = MUTABLE_HV(LvTARG(sv));
1676 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1677 PERL_UNUSED_ARG(mg);
1680 (void) hv_iterinit(hv);
1681 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1684 while (hv_iternext(hv))
1689 sv_setiv(sv, (IV)i);
1694 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1696 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1697 PERL_UNUSED_ARG(mg);
1699 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1705 =for apidoc magic_methcall
1707 Invoke a magic method (like FETCH).
1709 C<sv> and C<mg> are the tied thingy and the tie magic.
1711 C<meth> is the name of the method to call.
1713 C<argc> is the number of args (in addition to $self) to pass to the method.
1715 The C<flags> can be:
1717 G_DISCARD invoke method with G_DISCARD flag and don't
1719 G_UNDEF_FILL fill the stack with argc pointers to
1722 The arguments themselves are any values following the C<flags> argument.
1724 Returns the SV (if any) returned by the method, or NULL on failure.
1731 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1738 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1742 if (flags & G_WRITING_TO_STDERR) {
1746 SAVESPTR(PL_stderrgv);
1750 PUSHSTACKi(PERLSI_MAGIC);
1754 PUSHs(SvTIED_obj(sv, mg));
1755 if (flags & G_UNDEF_FILL) {
1757 PUSHs(&PL_sv_undef);
1759 } else if (argc > 0) {
1761 va_start(args, argc);
1764 SV *const sv = va_arg(args, SV *);
1771 if (flags & G_DISCARD) {
1772 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1775 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1776 ret = *PL_stack_sp--;
1779 if (flags & G_WRITING_TO_STDERR)
1785 /* wrapper for magic_methcall that creates the first arg */
1788 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1794 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1797 if (mg->mg_len >= 0) {
1798 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1800 else if (mg->mg_len == HEf_SVKEY)
1801 arg1 = MUTABLE_SV(mg->mg_ptr);
1803 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1804 arg1 = newSViv((IV)(mg->mg_len));
1808 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1810 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1814 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1819 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1821 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1828 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1830 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1832 if (mg->mg_type == PERL_MAGIC_tiedelem)
1833 mg->mg_flags |= MGf_GSKIP;
1834 magic_methpack(sv,mg,SV_CONST(FETCH));
1839 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1845 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1847 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1848 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1849 * public flags indicate its value based on copying from $val. Doing
1850 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1851 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1852 * wrong if $val happened to be tainted, as sv hasn't got magic
1853 * enabled, even though taint magic is in the chain. In which case,
1854 * fake up a temporary tainted value (this is easier than temporarily
1855 * re-enabling magic on sv). */
1857 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1858 && (tmg->mg_len & 1))
1860 val = sv_mortalcopy(sv);
1866 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
1871 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1873 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1875 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1876 return magic_methpack(sv,mg,SV_CONST(DELETE));
1881 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1887 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1889 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
1891 retval = SvIV(retsv)-1;
1893 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1895 return (U32) retval;
1899 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1903 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1905 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
1910 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1915 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1917 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1918 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
1925 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1927 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1929 return magic_methpack(sv,mg,SV_CONST(EXISTS));
1933 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1937 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1938 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1940 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1942 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1944 if (HvEITER_get(hv))
1945 /* we are in an iteration so the hash cannot be empty */
1947 /* no xhv_eiter so now use FIRSTKEY */
1948 key = sv_newmortal();
1949 magic_nextpack(MUTABLE_SV(hv), mg, key);
1950 HvEITER_set(hv, NULL); /* need to reset iterator */
1951 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1954 /* there is a SCALAR method that we can call */
1955 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
1957 retval = &PL_sv_undef;
1962 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1967 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1969 /* The magic ptr/len for the debugger's hash should always be an SV. */
1970 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
1971 Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
1972 mg->mg_len, mg->mg_ptr);
1975 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
1976 setting/clearing debugger breakpoints is not a hot path. */
1977 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
1978 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
1980 if (svp && SvIOKp(*svp)) {
1981 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1983 #ifdef PERL_DEBUG_READONLY_OPS
1984 Slab_to_rw(OpSLAB(o));
1986 /* set or clear breakpoint in the relevant control op */
1988 o->op_flags |= OPf_SPECIAL;
1990 o->op_flags &= ~OPf_SPECIAL;
1991 #ifdef PERL_DEBUG_READONLY_OPS
1992 Slab_to_ro(OpSLAB(o));
2000 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2003 AV * const obj = MUTABLE_AV(mg->mg_obj);
2005 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2008 sv_setiv(sv, AvFILL(obj));
2016 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2019 AV * const obj = MUTABLE_AV(mg->mg_obj);
2021 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2024 av_fill(obj, SvIV(sv));
2026 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2027 "Attempt to set length of freed array");
2033 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2037 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2038 PERL_UNUSED_ARG(sv);
2040 /* Reset the iterator when the array is cleared */
2041 #if IVSIZE == I32SIZE
2042 *((IV *) &(mg->mg_len)) = 0;
2045 *((IV *) mg->mg_ptr) = 0;
2052 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2056 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2057 PERL_UNUSED_ARG(sv);
2059 /* during global destruction, mg_obj may already have been freed */
2060 if (PL_in_clean_all)
2063 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2066 /* arylen scalar holds a pointer back to the array, but doesn't own a
2067 reference. Hence the we (the array) are about to go away with it
2068 still pointing at us. Clear its pointer, else it would be pointing
2069 at free memory. See the comment in sv_magic about reference loops,
2070 and why it can't own a reference to us. */
2077 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2080 SV* const lsv = LvTARG(sv);
2081 MAGIC * const found = mg_find_mglob(lsv);
2083 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2084 PERL_UNUSED_ARG(mg);
2086 if (found && found->mg_len != -1) {
2087 STRLEN i = found->mg_len;
2088 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2089 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2098 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2101 SV* const lsv = LvTARG(sv);
2108 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2109 PERL_UNUSED_ARG(mg);
2111 found = mg_find_mglob(lsv);
2115 found = sv_magicext_mglob(lsv);
2117 else if (!SvOK(sv)) {
2121 s = SvPV_const(lsv, len);
2126 ulen = sv_or_pv_len_utf8(lsv, s, len);
2136 else if (pos > (SSize_t)len)
2139 found->mg_len = pos;
2140 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2146 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2149 SV * const lsv = LvTARG(sv);
2150 const char * const tmps = SvPV_const(lsv,len);
2151 STRLEN offs = LvTARGOFF(sv);
2152 STRLEN rem = LvTARGLEN(sv);
2153 const bool negoff = LvFLAGS(sv) & 1;
2154 const bool negrem = LvFLAGS(sv) & 2;
2156 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2157 PERL_UNUSED_ARG(mg);
2159 if (!translate_substr_offsets(
2160 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2161 negoff ? -(IV)offs : (IV)offs, !negoff,
2162 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2164 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2165 sv_setsv_nomg(sv, &PL_sv_undef);
2170 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2171 sv_setpvn(sv, tmps + offs, rem);
2178 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2181 STRLEN len, lsv_len, oldtarglen, newtarglen;
2182 const char * const tmps = SvPV_const(sv, len);
2183 SV * const lsv = LvTARG(sv);
2184 STRLEN lvoff = LvTARGOFF(sv);
2185 STRLEN lvlen = LvTARGLEN(sv);
2186 const bool negoff = LvFLAGS(sv) & 1;
2187 const bool neglen = LvFLAGS(sv) & 2;
2189 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2190 PERL_UNUSED_ARG(mg);
2194 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2195 "Attempt to use reference as lvalue in substr"
2197 SvPV_force_nomg(lsv,lsv_len);
2198 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2199 if (!translate_substr_offsets(
2201 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2202 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2204 Perl_croak(aTHX_ "substr outside of string");
2207 sv_utf8_upgrade_nomg(lsv);
2208 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2209 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2210 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2213 else if (SvUTF8(lsv)) {
2215 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2217 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2218 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2222 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2225 if (!neglen) LvTARGLEN(sv) = newtarglen;
2226 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2232 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2236 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2237 PERL_UNUSED_ARG(sv);
2238 #ifdef NO_TAINT_SUPPORT
2239 PERL_UNUSED_ARG(mg);
2242 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2247 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2251 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2252 PERL_UNUSED_ARG(sv);
2254 /* update taint status */
2263 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2265 SV * const lsv = LvTARG(sv);
2267 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2268 PERL_UNUSED_ARG(mg);
2270 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2276 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2278 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2279 PERL_UNUSED_ARG(mg);
2280 do_vecset(sv); /* XXX slurp this routine */
2285 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2289 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2290 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2292 if (LvTARGLEN(sv)) {
2294 SV * const ahv = LvTARG(sv);
2295 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2299 else if (LvSTARGOFF(sv) >= 0) {
2300 AV *const av = MUTABLE_AV(LvTARG(sv));
2301 if (LvSTARGOFF(sv) <= AvFILL(av))
2303 if (SvRMAGICAL(av)) {
2304 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2305 targ = svp ? *svp : NULL;
2308 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2311 if (targ && (targ != &PL_sv_undef)) {
2312 /* somebody else defined it for us */
2313 SvREFCNT_dec(LvTARG(sv));
2314 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2316 SvREFCNT_dec(mg->mg_obj);
2318 mg->mg_flags &= ~MGf_REFCOUNTED;
2327 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2329 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2331 sv_setsv(sv, defelem_target(sv, mg));
2336 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2338 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2339 PERL_UNUSED_ARG(mg);
2343 sv_setsv(LvTARG(sv), sv);
2344 SvSETMAGIC(LvTARG(sv));
2350 Perl_vivify_defelem(pTHX_ SV *sv)
2356 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2358 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2361 SV * const ahv = LvTARG(sv);
2362 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2365 if (!value || value == &PL_sv_undef)
2366 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2368 else if (LvSTARGOFF(sv) < 0)
2369 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2371 AV *const av = MUTABLE_AV(LvTARG(sv));
2372 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2373 LvTARG(sv) = NULL; /* array can't be extended */
2375 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2376 if (!svp || !(value = *svp))
2377 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2380 SvREFCNT_inc_simple_void(value);
2381 SvREFCNT_dec(LvTARG(sv));
2384 SvREFCNT_dec(mg->mg_obj);
2386 mg->mg_flags &= ~MGf_REFCOUNTED;
2390 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2392 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2393 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2398 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2400 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2401 PERL_UNUSED_CONTEXT;
2402 PERL_UNUSED_ARG(sv);
2408 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2410 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2412 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2414 if (uf && uf->uf_set)
2415 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2420 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2422 const char type = mg->mg_type;
2424 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2426 if (type == PERL_MAGIC_qr) {
2427 } else if (type == PERL_MAGIC_bm) {
2431 assert(type == PERL_MAGIC_fm);
2433 return sv_unmagic(sv, type);
2436 #ifdef USE_LOCALE_COLLATE
2438 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2440 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2443 * RenE<eacute> Descartes said "I think not."
2444 * and vanished with a faint plop.
2446 PERL_UNUSED_CONTEXT;
2447 PERL_UNUSED_ARG(sv);
2449 Safefree(mg->mg_ptr);
2455 #endif /* USE_LOCALE_COLLATE */
2457 /* Just clear the UTF-8 cache data. */
2459 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2461 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2462 PERL_UNUSED_CONTEXT;
2463 PERL_UNUSED_ARG(sv);
2464 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2466 mg->mg_len = -1; /* The mg_len holds the len cache. */
2471 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2481 PERL_ARGS_ASSERT_MAGIC_SET;
2485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2487 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2489 /* Croak with a READONLY error when a numbered match var is
2490 * set without a previous pattern match. Unless it's C<local $1>
2493 if (!PL_localizing) {
2494 Perl_croak_no_modify();
2500 switch (*mg->mg_ptr) {
2501 case '\001': /* ^A */
2502 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2503 else SvOK_off(PL_bodytarget);
2504 FmLINES(PL_bodytarget) = 0;
2505 if (SvPOK(PL_bodytarget)) {
2506 char *s = SvPVX(PL_bodytarget);
2507 while ( ((s = strchr(s, '\n'))) ) {
2508 FmLINES(PL_bodytarget)++;
2512 /* mg_set() has temporarily made sv non-magical */
2514 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2515 SvTAINTED_on(PL_bodytarget);
2517 SvTAINTED_off(PL_bodytarget);
2520 case '\003': /* ^C */
2521 PL_minus_c = cBOOL(SvIV(sv));
2524 case '\004': /* ^D */
2526 s = SvPV_nolen_const(sv);
2527 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2528 if (DEBUG_x_TEST || DEBUG_B_TEST)
2529 dump_all_perl(!DEBUG_B_TEST);
2531 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2534 case '\005': /* ^E */
2535 if (*(mg->mg_ptr+1) == '\0') {
2537 set_vaxc_errno(SvIV(sv));
2540 SetLastError( SvIV(sv) );
2543 os2_setsyserrno(SvIV(sv));
2545 /* will anyone ever use this? */
2546 SETERRNO(SvIV(sv), 4);
2551 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2552 SvREFCNT_dec(PL_encoding);
2553 if (SvOK(sv) || SvGMAGICAL(sv)) {
2554 PL_encoding = newSVsv(sv);
2561 case '\006': /* ^F */
2562 PL_maxsysfd = SvIV(sv);
2564 case '\010': /* ^H */
2565 PL_hints = SvIV(sv);
2567 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2568 Safefree(PL_inplace);
2569 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2571 case '\016': /* ^N */
2572 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2573 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2575 case '\017': /* ^O */
2576 if (*(mg->mg_ptr+1) == '\0') {
2577 Safefree(PL_osname);
2580 TAINT_PROPER("assigning to $^O");
2581 PL_osname = savesvpv(sv);
2584 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2586 const char *const start = SvPV(sv, len);
2587 const char *out = (const char*)memchr(start, '\0', len);
2591 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2592 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2594 /* Opening for input is more common than opening for output, so
2595 ensure that hints for input are sooner on linked list. */
2596 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2598 : newSVpvs_flags("", SvUTF8(sv));
2599 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2602 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2604 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2608 case '\020': /* ^P */
2609 PL_perldb = SvIV(sv);
2610 if (PL_perldb && !PL_DBsingle)
2613 case '\024': /* ^T */
2615 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2617 PL_basetime = (Time_t)SvIV(sv);
2620 case '\025': /* ^UTF8CACHE */
2621 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2622 PL_utf8cache = (signed char) sv_2iv(sv);
2625 case '\027': /* ^W & $^WARNING_BITS */
2626 if (*(mg->mg_ptr+1) == '\0') {
2627 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2629 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2630 | (i ? G_WARN_ON : G_WARN_OFF) ;
2633 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2634 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2636 PL_compiling.cop_warnings = pWARN_STD;
2641 int accumulate = 0 ;
2642 int any_fatals = 0 ;
2643 const char * const ptr = SvPV_const(sv, len) ;
2644 for (i = 0 ; i < len ; ++i) {
2645 accumulate |= ptr[i] ;
2646 any_fatals |= (ptr[i] & 0xAA) ;
2649 if (!specialWARN(PL_compiling.cop_warnings))
2650 PerlMemShared_free(PL_compiling.cop_warnings);
2651 PL_compiling.cop_warnings = pWARN_NONE;
2653 /* Yuck. I can't see how to abstract this: */
2655 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2659 if (!specialWARN(PL_compiling.cop_warnings))
2660 PerlMemShared_free(PL_compiling.cop_warnings);
2661 PL_compiling.cop_warnings = pWARN_ALL;
2662 PL_dowarn |= G_WARN_ONCE ;
2666 const char *const p = SvPV_const(sv, len);
2668 PL_compiling.cop_warnings
2669 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2672 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2673 PL_dowarn |= G_WARN_ONCE ;
2681 if (PL_localizing) {
2682 if (PL_localizing == 1)
2683 SAVESPTR(PL_last_in_gv);
2685 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2686 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2689 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2690 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2691 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2694 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2695 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2696 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2699 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2702 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2703 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2704 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2707 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2711 IO * const io = GvIO(PL_defoutgv);
2714 if ((SvIV(sv)) == 0)
2715 IoFLAGS(io) &= ~IOf_FLUSH;
2717 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2718 PerlIO *ofp = IoOFP(io);
2720 (void)PerlIO_flush(ofp);
2721 IoFLAGS(io) |= IOf_FLUSH;
2727 SvREFCNT_dec(PL_rs);
2728 PL_rs = newSVsv(sv);
2731 SvREFCNT_dec(PL_ors_sv);
2733 PL_ors_sv = newSVsv(sv);
2741 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2744 #ifdef COMPLEX_STATUS
2745 if (PL_localizing == 2) {
2746 SvUPGRADE(sv, SVt_PVLV);
2747 PL_statusvalue = LvTARGOFF(sv);
2748 PL_statusvalue_vms = LvTARGLEN(sv);
2752 #ifdef VMSISH_STATUS
2754 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2757 STATUS_UNIX_EXIT_SET(SvIV(sv));
2762 # define PERL_VMS_BANG vaxc$errno
2764 # define PERL_VMS_BANG 0
2766 #if defined(WIN32) && ! defined(UNDER_CE)
2767 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2768 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2770 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2771 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2777 const Uid_t new_uid = SvUID(sv);
2778 PL_delaymagic_uid = new_uid;
2779 if (PL_delaymagic) {
2780 PL_delaymagic |= DM_RUID;
2781 break; /* don't do magic till later */
2784 (void)setruid(new_uid);
2787 (void)setreuid(new_uid, (Uid_t)-1);
2789 #ifdef HAS_SETRESUID
2790 (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2792 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2794 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2795 if (new_uid != 0 && PerlProc_getuid() == 0)
2796 (void)PerlProc_setuid(0);
2798 (void)PerlProc_setuid(new_uid);
2800 Perl_croak(aTHX_ "setruid() not implemented");
2809 const Uid_t new_euid = SvUID(sv);
2810 PL_delaymagic_euid = new_euid;
2811 if (PL_delaymagic) {
2812 PL_delaymagic |= DM_EUID;
2813 break; /* don't do magic till later */
2816 (void)seteuid(new_euid);
2819 (void)setreuid((Uid_t)-1, new_euid);
2821 #ifdef HAS_SETRESUID
2822 (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2824 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2825 PerlProc_setuid(new_euid);
2827 Perl_croak(aTHX_ "seteuid() not implemented");
2836 const Gid_t new_gid = SvGID(sv);
2837 PL_delaymagic_gid = new_gid;
2838 if (PL_delaymagic) {
2839 PL_delaymagic |= DM_RGID;
2840 break; /* don't do magic till later */
2843 (void)setrgid(new_gid);
2846 (void)setregid(new_gid, (Gid_t)-1);
2848 #ifdef HAS_SETRESGID
2849 (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2851 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2852 (void)PerlProc_setgid(new_gid);
2854 Perl_croak(aTHX_ "setrgid() not implemented");
2864 #ifdef HAS_SETGROUPS
2866 const char *p = SvPV_const(sv, len);
2867 Groups_t *gary = NULL;
2868 #ifdef _SC_NGROUPS_MAX
2869 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2874 int maxgrp = NGROUPS;
2879 new_egid = (Gid_t)Atol(p);
2880 for (i = 0; i < maxgrp; ++i) {
2881 while (*p && !isSPACE(*p))
2888 Newx(gary, i + 1, Groups_t);
2890 Renew(gary, i + 1, Groups_t);
2891 gary[i] = (Groups_t)Atol(p);
2894 (void)setgroups(i, gary);
2897 #else /* HAS_SETGROUPS */
2898 new_egid = SvGID(sv);
2899 #endif /* HAS_SETGROUPS */
2900 PL_delaymagic_egid = new_egid;
2901 if (PL_delaymagic) {
2902 PL_delaymagic |= DM_EGID;
2903 break; /* don't do magic till later */
2906 (void)setegid(new_egid);
2909 (void)setregid((Gid_t)-1, new_egid);
2911 #ifdef HAS_SETRESGID
2912 (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2914 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2915 (void)PerlProc_setgid(new_egid);
2917 Perl_croak(aTHX_ "setegid() not implemented");
2925 PL_chopset = SvPV_force(sv,len);
2928 /* Store the pid in mg->mg_obj so we can tell when a fork has
2929 occurred. mg->mg_obj points to *$ by default, so clear it. */
2930 if (isGV(mg->mg_obj)) {
2931 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2932 SvREFCNT_dec(mg->mg_obj);
2933 mg->mg_flags |= MGf_REFCOUNTED;
2934 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2936 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2939 LOCK_DOLLARZERO_MUTEX;
2940 #ifdef HAS_SETPROCTITLE
2941 /* The BSDs don't show the argv[] in ps(1) output, they
2942 * show a string from the process struct and provide
2943 * the setproctitle() routine to manipulate that. */
2944 if (PL_origalen != 1) {
2945 s = SvPV_const(sv, len);
2946 # if __FreeBSD_version > 410001
2947 /* The leading "-" removes the "perl: " prefix,
2948 * but not the "(perl) suffix from the ps(1)
2949 * output, because that's what ps(1) shows if the
2950 * argv[] is modified. */
2951 setproctitle("-%s", s);
2952 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2953 /* This doesn't really work if you assume that
2954 * $0 = 'foobar'; will wipe out 'perl' from the $0
2955 * because in ps(1) output the result will be like
2956 * sprintf("perl: %s (perl)", s)
2957 * I guess this is a security feature:
2958 * one (a user process) cannot get rid of the original name.
2960 setproctitle("%s", s);
2963 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2964 if (PL_origalen != 1) {
2966 s = SvPV_const(sv, len);
2967 un.pst_command = (char *)s;
2968 pstat(PSTAT_SETCMD, un, len, 0, 0);
2971 if (PL_origalen > 1) {
2972 /* PL_origalen is set in perl_parse(). */
2973 s = SvPV_force(sv,len);
2974 if (len >= (STRLEN)PL_origalen-1) {
2975 /* Longer than original, will be truncated. We assume that
2976 * PL_origalen bytes are available. */
2977 Copy(s, PL_origargv[0], PL_origalen-1, char);
2980 /* Shorter than original, will be padded. */
2982 /* Special case for Mac OS X: see [perl #38868] */
2985 /* Is the space counterintuitive? Yes.
2986 * (You were expecting \0?)
2987 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2989 const int pad = ' ';
2991 Copy(s, PL_origargv[0], len, char);
2992 PL_origargv[0][len] = 0;
2993 memset(PL_origargv[0] + len + 1,
2994 pad, PL_origalen - len - 1);
2996 PL_origargv[0][PL_origalen-1] = 0;
2997 for (i = 1; i < PL_origargc; i++)
2999 #ifdef HAS_PRCTL_SET_NAME
3000 /* Set the legacy process name in addition to the POSIX name on Linux */
3001 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3002 /* diag_listed_as: SKIPME */
3003 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3008 UNLOCK_DOLLARZERO_MUTEX;
3015 Perl_whichsig_sv(pTHX_ SV *sigsv)
3019 PERL_ARGS_ASSERT_WHICHSIG_SV;
3020 PERL_UNUSED_CONTEXT;
3021 sigpv = SvPV_const(sigsv, siglen);
3022 return whichsig_pvn(sigpv, siglen);
3026 Perl_whichsig_pv(pTHX_ const char *sig)
3028 PERL_ARGS_ASSERT_WHICHSIG_PV;
3029 PERL_UNUSED_CONTEXT;
3030 return whichsig_pvn(sig, strlen(sig));
3034 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3038 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3039 PERL_UNUSED_CONTEXT;
3041 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3042 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3043 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3045 if (memEQs(sig, len, "CHLD"))
3049 if (memEQs(sig, len, "CLD"))
3056 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3057 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3059 Perl_sighandler(int sig)
3062 #ifdef PERL_GET_SIG_CONTEXT
3063 dTHXa(PERL_GET_SIG_CONTEXT);
3070 SV * const tSv = PL_Sv;
3074 XPV * const tXpv = PL_Xpv;
3075 I32 old_ss_ix = PL_savestack_ix;
3076 SV *errsv_save = NULL;
3079 if (!PL_psig_ptr[sig]) {
3080 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3085 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3086 /* Max number of items pushed there is 3*n or 4. We cannot fix
3087 infinity, so we fix 4 (in fact 5): */
3088 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3090 PL_savestack_ix += 5; /* Protect save in progress. */
3091 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3094 /* sv_2cv is too complicated, try a simpler variant first: */
3095 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3096 || SvTYPE(cv) != SVt_PVCV) {
3098 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3101 if (!cv || !CvROOT(cv)) {
3102 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3103 PL_sig_name[sig], (gv ? GvENAME(gv)
3110 sv = PL_psig_name[sig]
3111 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3112 : newSVpv(PL_sig_name[sig],0);
3116 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3117 /* make sure our assumption about the size of the SAVEs are correct:
3118 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3119 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3122 PUSHSTACKi(PERLSI_SIGNAL);
3125 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3127 struct sigaction oact;
3129 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3132 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3133 /* The siginfo fields signo, code, errno, pid, uid,
3134 * addr, status, and band are defined by POSIX/SUSv3. */
3135 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3136 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3137 #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. */
3138 hv_stores(sih, "errno", newSViv(sip->si_errno));
3139 hv_stores(sih, "status", newSViv(sip->si_status));
3140 hv_stores(sih, "uid", newSViv(sip->si_uid));
3141 hv_stores(sih, "pid", newSViv(sip->si_pid));
3142 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3143 hv_stores(sih, "band", newSViv(sip->si_band));
3147 mPUSHp((char *)sip, sizeof(*sip));
3155 errsv_save = newSVsv(ERRSV);
3157 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3161 SV * const errsv = ERRSV;
3162 if (SvTRUE_NN(errsv)) {
3163 SvREFCNT_dec(errsv_save);
3165 /* Handler "died", for example to get out of a restart-able read().
3166 * Before we re-do that on its behalf re-enable the signal which was
3167 * blocked by the system when we entered.
3169 #ifdef HAS_SIGPROCMASK
3170 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3176 sigaddset(&set,sig);
3177 sigprocmask(SIG_UNBLOCK, &set, NULL);
3180 /* Not clear if this will work */
3181 (void)rsignal(sig, SIG_IGN);
3182 (void)rsignal(sig, PL_csighandlerp);
3184 #endif /* !PERL_MICRO */
3188 sv_setsv(errsv, errsv_save);
3189 SvREFCNT_dec(errsv_save);
3194 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3195 PL_savestack_ix = old_ss_ix;
3197 SvREFCNT_dec_NN(sv);
3198 PL_op = myop; /* Apparently not needed... */
3200 PL_Sv = tSv; /* Restore global temporaries. */
3207 S_restore_magic(pTHX_ const void *p)
3210 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3211 SV* const sv = mgs->mgs_sv;
3217 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3218 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3219 #ifdef PERL_OLD_COPY_ON_WRITE
3220 /* While magic was saved (and off) sv_setsv may well have seen
3221 this SV as a prime candidate for COW. */
3223 sv_force_normal_flags(sv, 0);
3225 if (mgs->mgs_readonly)
3227 if (mgs->mgs_magical)
3228 SvFLAGS(sv) |= mgs->mgs_magical;
3233 bumped = mgs->mgs_bumped;
3234 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3236 /* If we're still on top of the stack, pop us off. (That condition
3237 * will be satisfied if restore_magic was called explicitly, but *not*
3238 * if it's being called via leave_scope.)
3239 * The reason for doing this is that otherwise, things like sv_2cv()
3240 * may leave alloc gunk on the savestack, and some code
3241 * (e.g. sighandler) doesn't expect that...
3243 if (PL_savestack_ix == mgs->mgs_ss_ix)
3245 UV popval = SSPOPUV;
3246 assert(popval == SAVEt_DESTRUCTOR_X);
3247 PL_savestack_ix -= 2;
3249 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3250 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3253 if (SvREFCNT(sv) == 1) {
3254 /* We hold the last reference to this SV, which implies that the
3255 SV was deleted as a side effect of the routines we called.
3256 So artificially keep it alive a bit longer.
3257 We avoid turning on the TEMP flag, which can cause the SV's
3258 buffer to get stolen (and maybe other stuff). */
3263 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3267 /* clean up the mess created by Perl_sighandler().
3268 * Note that this is only called during an exit in a signal handler;
3269 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3273 S_unwind_handler_stack(pTHX_ const void *p)
3278 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3282 =for apidoc magic_sethint
3284 Triggered by a store to %^H, records the key/value pair to
3285 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3286 anything that would need a deep copy. Maybe we should warn if we find a
3292 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3295 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3296 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3298 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3300 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3301 an alternative leaf in there, with PL_compiling.cop_hints being used if
3302 it's NULL. If needed for threads, the alternative could lock a mutex,
3303 or take other more complex action. */
3305 /* Something changed in %^H, so it will need to be restored on scope exit.
3306 Doing this here saves a lot of doing it manually in perl code (and
3307 forgetting to do it, and consequent subtle errors. */
3308 PL_hints |= HINT_LOCALIZE_HH;
3309 CopHINTHASH_set(&PL_compiling,
3310 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3315 =for apidoc magic_clearhint
3317 Triggered by a delete from %^H, records the key to
3318 C<PL_compiling.cop_hints_hash>.
3323 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3327 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3328 PERL_UNUSED_ARG(sv);
3330 PL_hints |= HINT_LOCALIZE_HH;
3331 CopHINTHASH_set(&PL_compiling,
3332 mg->mg_len == HEf_SVKEY
3333 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3334 MUTABLE_SV(mg->mg_ptr), 0, 0)
3335 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3336 mg->mg_ptr, mg->mg_len, 0, 0));
3341 =for apidoc magic_clearhints
3343 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3348 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3350 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3351 PERL_UNUSED_ARG(sv);
3352 PERL_UNUSED_ARG(mg);
3353 cophh_free(CopHINTHASH_get(&PL_compiling));
3354 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3359 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3360 const char *name, I32 namlen)
3364 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3365 PERL_UNUSED_ARG(sv);
3366 PERL_UNUSED_ARG(name);
3367 PERL_UNUSED_ARG(namlen);
3369 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3370 nmg = mg_find(nsv, mg->mg_type);
3371 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3372 nmg->mg_ptr = mg->mg_ptr;
3373 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3374 nmg->mg_flags |= MGf_REFCOUNTED;
3380 * c-indentation-style: bsd
3382 * indent-tabs-mode: nil
3385 * ex: set ts=8 sts=4 sw=4 et: