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(pTHX_ I32 mgs_ix, SV *sv)
99 PERL_ARGS_ASSERT_SAVE_MAGIC;
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;
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);
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. See C<sv_magic>.
171 Perl_mg_get(pTHX_ SV *sv)
174 const I32 mgs_ix = SSNEW(sizeof(MGS));
177 MAGIC *newmg, *head, *cur, *mg;
179 PERL_ARGS_ASSERT_MG_GET;
181 if (PL_localizing == 1 && sv == DEFSV) return 0;
183 /* We must call svt_get(sv, mg) for each valid entry in the linked
184 list of magic. svt_get() may delete the current entry, add new
185 magic to the head of the list, or upgrade the SV. AMS 20010810 */
187 newmg = cur = head = mg = SvMAGIC(sv);
189 const MGVTBL * const vtbl = mg->mg_virtual;
190 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
192 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
194 /* taint's mg get is so dumb it doesn't need flag saving */
195 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
196 save_magic(mgs_ix, sv);
200 vtbl->svt_get(aTHX_ sv, mg);
202 /* guard against magic having been deleted - eg FETCH calling
205 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
209 /* recalculate flags if this entry was deleted. */
210 if (mg->mg_flags & MGf_GSKIP)
211 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
213 else if (vtbl == &PL_vtbl_utf8) {
214 /* get-magic can reallocate the PV */
215 magic_setutf8(sv, mg);
221 /* Have we finished with the new entries we saw? Start again
222 where we left off (unless there are more new entries). */
230 /* Were any new entries added? */
231 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
235 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
240 restore_magic(INT2PTR(void *, (IV)mgs_ix));
248 Do magic after a value is assigned to the SV. See C<sv_magic>.
254 Perl_mg_set(pTHX_ SV *sv)
257 const I32 mgs_ix = SSNEW(sizeof(MGS));
261 PERL_ARGS_ASSERT_MG_SET;
263 if (PL_localizing == 2 && sv == DEFSV) return 0;
265 save_magic(mgs_ix, sv);
267 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
268 const MGVTBL* vtbl = mg->mg_virtual;
269 nextmg = mg->mg_moremagic; /* it may delete itself */
270 if (mg->mg_flags & MGf_GSKIP) {
271 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
272 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
274 if (PL_localizing == 2
275 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
277 if (vtbl && vtbl->svt_set)
278 vtbl->svt_set(aTHX_ sv, mg);
281 restore_magic(INT2PTR(void*, (IV)mgs_ix));
286 =for apidoc mg_length
288 This function is deprecated.
290 It reports on the SV's length in bytes, calling length magic if available,
291 but does not set the UTF8 flag on the sv. It will fall back to 'get'
292 magic if there is no 'length' magic, but with no indication as to
293 whether it called 'get' magic. It assumes the sv is a PVMG or
294 higher. Use sv_len() instead.
300 Perl_mg_length(pTHX_ SV *sv)
306 PERL_ARGS_ASSERT_MG_LENGTH;
308 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
309 const MGVTBL * const vtbl = mg->mg_virtual;
310 if (vtbl && vtbl->svt_len) {
311 const I32 mgs_ix = SSNEW(sizeof(MGS));
312 save_magic(mgs_ix, sv);
313 /* omit MGf_GSKIP -- not changed here */
314 len = vtbl->svt_len(aTHX_ sv, mg);
315 restore_magic(INT2PTR(void*, (IV)mgs_ix));
320 (void)SvPV_const(sv, len);
325 Perl_mg_size(pTHX_ SV *sv)
329 PERL_ARGS_ASSERT_MG_SIZE;
331 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
332 const MGVTBL* const vtbl = mg->mg_virtual;
333 if (vtbl && vtbl->svt_len) {
334 const I32 mgs_ix = SSNEW(sizeof(MGS));
336 save_magic(mgs_ix, sv);
337 /* omit MGf_GSKIP -- not changed here */
338 len = vtbl->svt_len(aTHX_ sv, mg);
339 restore_magic(INT2PTR(void*, (IV)mgs_ix));
346 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
350 Perl_croak(aTHX_ "Size magic not implemented");
359 Clear something magical that the SV represents. See C<sv_magic>.
365 Perl_mg_clear(pTHX_ SV *sv)
367 const I32 mgs_ix = SSNEW(sizeof(MGS));
371 PERL_ARGS_ASSERT_MG_CLEAR;
373 save_magic(mgs_ix, sv);
375 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 /* omit GSKIP -- never set here */
379 nextmg = mg->mg_moremagic; /* it may delete itself */
381 if (vtbl && vtbl->svt_clear)
382 vtbl->svt_clear(aTHX_ sv, mg);
385 restore_magic(INT2PTR(void*, (IV)mgs_ix));
390 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
399 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
400 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
412 Finds the magic pointer for type matching the SV. See C<sv_magic>.
418 Perl_mg_find(pTHX_ const SV *sv, int type)
420 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
424 =for apidoc mg_findext
426 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
433 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
435 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
441 Copies the magic from one SV to another. See C<sv_magic>.
447 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
452 PERL_ARGS_ASSERT_MG_COPY;
454 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
455 const MGVTBL* const vtbl = mg->mg_virtual;
456 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
457 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
460 const char type = mg->mg_type;
461 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
463 (type == PERL_MAGIC_tied)
465 : (type == PERL_MAGIC_regdata && mg->mg_obj)
468 toLOWER(type), key, klen);
477 =for apidoc mg_localize
479 Copy some of the magic from an existing SV to new localized version of that
480 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
483 If setmagic is false then no set magic will be called on the new (empty) SV.
484 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
485 and that will handle the magic.
491 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
496 PERL_ARGS_ASSERT_MG_LOCALIZE;
501 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
502 const MGVTBL* const vtbl = mg->mg_virtual;
503 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
506 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
507 (void)vtbl->svt_local(aTHX_ nsv, mg);
509 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
510 mg->mg_ptr, mg->mg_len);
512 /* container types should remain read-only across localization */
513 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
516 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
517 SvFLAGS(nsv) |= SvMAGICAL(sv);
526 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
528 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
530 const MGVTBL* const vtbl = mg->mg_virtual;
531 if (vtbl && vtbl->svt_free)
532 vtbl->svt_free(aTHX_ sv, mg);
533 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
534 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
535 Safefree(mg->mg_ptr);
536 else if (mg->mg_len == HEf_SVKEY)
537 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
539 if (mg->mg_flags & MGf_REFCOUNTED)
540 SvREFCNT_dec(mg->mg_obj);
547 Free any magic storage used by the SV. See C<sv_magic>.
553 Perl_mg_free(pTHX_ SV *sv)
558 PERL_ARGS_ASSERT_MG_FREE;
560 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
561 moremagic = mg->mg_moremagic;
562 mg_free_struct(sv, mg);
563 SvMAGIC_set(sv, moremagic);
565 SvMAGIC_set(sv, NULL);
571 =for apidoc Am|void|mg_free_type|SV *sv|int how
573 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
579 Perl_mg_free_type(pTHX_ SV *sv, int how)
581 MAGIC *mg, *prevmg, *moremg;
582 PERL_ARGS_ASSERT_MG_FREE_TYPE;
583 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
585 moremg = mg->mg_moremagic;
586 if (mg->mg_type == how) {
587 /* temporarily move to the head of the magic chain, in case
588 custom free code relies on this historical aspect of mg_free */
590 prevmg->mg_moremagic = moremg;
591 mg->mg_moremagic = SvMAGIC(sv);
594 newhead = mg->mg_moremagic;
595 mg_free_struct(sv, mg);
596 SvMAGIC_set(sv, newhead);
606 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
611 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
614 const REGEXP * const rx = PM_GETRE(PL_curpm);
616 if (mg->mg_obj) { /* @+ */
617 /* return the number possible */
618 return RX_NPARENS(rx);
620 I32 paren = RX_LASTPAREN(rx);
622 /* return the last filled */
624 && (RX_OFFS(rx)[paren].start == -1
625 || RX_OFFS(rx)[paren].end == -1) )
638 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
642 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
645 const REGEXP * const rx = PM_GETRE(PL_curpm);
647 const I32 paren = mg->mg_len;
652 if (paren <= (I32)RX_NPARENS(rx) &&
653 (s = RX_OFFS(rx)[paren].start) != -1 &&
654 (t = RX_OFFS(rx)[paren].end) != -1)
657 if (mg->mg_obj) /* @+ */
662 if (i > 0 && RX_MATCH_UTF8(rx)) {
663 const char * const b = RX_SUBBEG(rx);
665 i = RX_SUBCOFFSET(rx) +
667 (U8*)(b-RX_SUBOFFSET(rx)+i));
680 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
682 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
685 Perl_croak_no_modify();
686 NORETURN_FUNCTION_END;
689 #define SvRTRIM(sv) STMT_START { \
691 STRLEN len = SvCUR(sv); \
692 char * const p = SvPVX(sv); \
693 while (len > 0 && isSPACE(p[len-1])) \
695 SvCUR_set(sv, len); \
701 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
703 PERL_ARGS_ASSERT_EMULATE_COP_IO;
705 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
706 sv_setsv(sv, &PL_sv_undef);
710 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
711 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
716 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
717 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
730 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
734 const char *s = NULL;
736 const char * const remaining = mg->mg_ptr + 1;
737 const char nextchar = *remaining;
739 PERL_ARGS_ASSERT_MAGIC_GET;
741 switch (*mg->mg_ptr) {
742 case '\001': /* ^A */
743 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
744 else sv_setsv(sv, &PL_sv_undef);
745 if (SvTAINTED(PL_bodytarget))
748 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
749 if (nextchar == '\0') {
750 sv_setiv(sv, (IV)PL_minus_c);
752 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
753 sv_setiv(sv, (IV)STATUS_NATIVE);
757 case '\004': /* ^D */
758 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
760 case '\005': /* ^E */
761 if (nextchar == '\0') {
765 $DESCRIPTOR(msgdsc,msg);
766 sv_setnv(sv,(NV) vaxc$errno);
767 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
768 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
773 if (!(_emx_env & 0x200)) { /* Under DOS */
774 sv_setnv(sv, (NV)errno);
775 sv_setpv(sv, errno ? Strerror(errno) : "");
777 if (errno != errno_isOS2) {
778 const int tmp = _syserrno();
779 if (tmp) /* 2nd call to _syserrno() makes it 0 */
782 sv_setnv(sv, (NV)Perl_rc);
783 sv_setpv(sv, os2error(Perl_rc));
787 const DWORD dwErr = GetLastError();
788 sv_setnv(sv, (NV)dwErr);
790 PerlProc_GetOSError(sv, dwErr);
799 sv_setnv(sv, (NV)errno);
800 sv_setpv(sv, errno ? Strerror(errno) : "");
805 SvNOK_on(sv); /* what a wonderful hack! */
807 else if (strEQ(remaining, "NCODING"))
808 sv_setsv(sv, PL_encoding);
810 case '\006': /* ^F */
811 sv_setiv(sv, (IV)PL_maxsysfd);
813 case '\007': /* ^GLOBAL_PHASE */
814 if (strEQ(remaining, "LOBAL_PHASE")) {
815 sv_setpvn(sv, PL_phase_names[PL_phase],
816 strlen(PL_phase_names[PL_phase]));
819 case '\010': /* ^H */
820 sv_setiv(sv, (IV)PL_hints);
822 case '\011': /* ^I */ /* NOT \t in EBCDIC */
823 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
825 case '\014': /* ^LAST_FH */
826 if (strEQ(remaining, "AST_FH")) {
828 assert(isGV_with_GP(PL_last_in_gv));
829 SV_CHECK_THINKFIRST_COW_DROP(sv);
830 prepare_SV_for_RV(sv);
832 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
836 else sv_setsv_nomg(sv, NULL);
839 case '\017': /* ^O & ^OPEN */
840 if (nextchar == '\0') {
841 sv_setpv(sv, PL_osname);
844 else if (strEQ(remaining, "PEN")) {
845 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
849 if (nextchar == '\0') { /* ^P */
850 sv_setiv(sv, (IV)PL_perldb);
851 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
853 paren = RX_BUFF_IDX_CARET_PREMATCH;
854 goto do_numbuf_fetch;
855 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
856 paren = RX_BUFF_IDX_CARET_POSTMATCH;
857 goto do_numbuf_fetch;
860 case '\023': /* ^S */
861 if (nextchar == '\0') {
862 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
865 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
870 case '\024': /* ^T */
871 if (nextchar == '\0') {
873 sv_setnv(sv, PL_basetime);
875 sv_setiv(sv, (IV)PL_basetime);
878 else if (strEQ(remaining, "AINT"))
879 sv_setiv(sv, TAINTING_get
880 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
883 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
884 if (strEQ(remaining, "NICODE"))
885 sv_setuv(sv, (UV) PL_unicode);
886 else if (strEQ(remaining, "TF8LOCALE"))
887 sv_setuv(sv, (UV) PL_utf8locale);
888 else if (strEQ(remaining, "TF8CACHE"))
889 sv_setiv(sv, (IV) PL_utf8cache);
891 case '\027': /* ^W & $^WARNING_BITS */
892 if (nextchar == '\0')
893 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
894 else if (strEQ(remaining, "ARNING_BITS")) {
895 if (PL_compiling.cop_warnings == pWARN_NONE) {
896 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
898 else if (PL_compiling.cop_warnings == pWARN_STD) {
899 sv_setsv(sv, &PL_sv_undef);
902 else if (PL_compiling.cop_warnings == pWARN_ALL) {
903 /* Get the bit mask for $warnings::Bits{all}, because
904 * it could have been extended by warnings::register */
905 HV * const bits = get_hv("warnings::Bits", 0);
906 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
908 sv_copypv(sv, *bits_all);
910 sv_setpvn(sv, WARN_ALLstring, WARNsize);
913 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
914 *PL_compiling.cop_warnings);
918 case '\015': /* $^MATCH */
919 if (strEQ(remaining, "ATCH")) {
920 paren = RX_BUFF_IDX_CARET_FULLMATCH;
921 goto do_numbuf_fetch;
924 case '1': case '2': case '3': case '4':
925 case '5': case '6': case '7': case '8': case '9': case '&':
927 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
928 * XXX Does the new way break anything?
930 paren = atoi(mg->mg_ptr); /* $& is in [0] */
932 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
933 CALLREG_NUMBUF_FETCH(rx,paren,sv);
936 sv_setsv(sv,&PL_sv_undef);
939 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
940 paren = RX_LASTPAREN(rx);
942 goto do_numbuf_fetch;
944 sv_setsv(sv,&PL_sv_undef);
946 case '\016': /* ^N */
947 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
948 paren = RX_LASTCLOSEPAREN(rx);
950 goto do_numbuf_fetch;
952 sv_setsv(sv,&PL_sv_undef);
955 paren = RX_BUFF_IDX_PREMATCH;
956 goto do_numbuf_fetch;
958 paren = RX_BUFF_IDX_POSTMATCH;
959 goto do_numbuf_fetch;
961 if (GvIO(PL_last_in_gv)) {
962 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
967 sv_setiv(sv, (IV)STATUS_CURRENT);
968 #ifdef COMPLEX_STATUS
969 SvUPGRADE(sv, SVt_PVLV);
970 LvTARGOFF(sv) = PL_statusvalue;
971 LvTARGLEN(sv) = PL_statusvalue_vms;
976 if (GvIOp(PL_defoutgv))
977 s = IoTOP_NAME(GvIOp(PL_defoutgv));
981 sv_setpv(sv,GvENAME(PL_defoutgv));
982 sv_catpvs(sv,"_TOP");
986 if (GvIOp(PL_defoutgv))
987 s = IoFMT_NAME(GvIOp(PL_defoutgv));
989 s = GvENAME(PL_defoutgv);
993 if (GvIO(PL_defoutgv))
994 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
997 if (GvIO(PL_defoutgv))
998 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1001 if (GvIO(PL_defoutgv))
1002 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1012 if (GvIO(PL_defoutgv))
1013 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1017 sv_copypv(sv, PL_ors_sv);
1019 sv_setsv(sv, &PL_sv_undef);
1023 IV const pid = (IV)PerlProc_getpid();
1024 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1025 /* never set manually, or at least not since last fork */
1027 /* never unsafe, even if reading in a tainted expression */
1030 /* else a value has been assigned manually, so do nothing */
1038 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1040 sv_setnv(sv, (NV)errno);
1043 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1044 sv_setpv(sv, os2error(Perl_rc));
1047 sv_setpv(sv, errno ? Strerror(errno) : "");
1052 SvNOK_on(sv); /* what a wonderful hack! */
1055 sv_setiv(sv, (IV)PerlProc_getuid());
1058 sv_setiv(sv, (IV)PerlProc_geteuid());
1061 sv_setiv(sv, (IV)PerlProc_getgid());
1064 sv_setiv(sv, (IV)PerlProc_getegid());
1066 #ifdef HAS_GETGROUPS
1068 Groups_t *gary = NULL;
1069 I32 i, num_groups = getgroups(0, gary);
1070 Newx(gary, num_groups, Groups_t);
1071 num_groups = getgroups(num_groups, gary);
1072 for (i = 0; i < num_groups; i++)
1073 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1076 (void)SvIOK_on(sv); /* what a wonderful hack! */
1086 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1088 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1090 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1092 if (uf && uf->uf_val)
1093 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1098 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1101 STRLEN len = 0, klen;
1102 const char * const key = MgPV_const(mg,klen);
1103 const char *s = NULL;
1105 PERL_ARGS_ASSERT_MAGIC_SETENV;
1109 /* defined environment variables are byte strings; unfortunately
1110 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1111 (void)SvPV_force_nomg_nolen(sv);
1112 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1114 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1120 my_setenv(key, s); /* does the deed */
1122 #ifdef DYNAMIC_ENV_FETCH
1123 /* We just undefd an environment var. Is a replacement */
1124 /* waiting in the wings? */
1126 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1128 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1132 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1133 /* And you'll never guess what the dog had */
1134 /* in its mouth... */
1136 MgTAINTEDDIR_off(mg);
1138 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1139 char pathbuf[256], eltbuf[256], *cp, *elt;
1142 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1144 do { /* DCL$PATH may be a search list */
1145 while (1) { /* as may dev portion of any element */
1146 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1147 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1148 cando_by_name(S_IWUSR,0,elt) ) {
1149 MgTAINTEDDIR_on(mg);
1153 if ((cp = strchr(elt, ':')) != NULL)
1155 if (my_trnlnm(elt, eltbuf, j++))
1161 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1164 if (s && klen == 4 && strEQ(key,"PATH")) {
1165 const char * const strend = s + len;
1167 while (s < strend) {
1171 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1172 const char path_sep = '|';
1174 const char path_sep = ':';
1176 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1177 s, strend, path_sep, &i);
1179 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1181 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1183 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1185 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1186 MgTAINTEDDIR_on(mg);
1192 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1198 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1200 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1201 PERL_UNUSED_ARG(sv);
1202 my_setenv(MgPV_nolen_const(mg),NULL);
1207 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1210 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1211 PERL_UNUSED_ARG(mg);
1213 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1215 if (PL_localizing) {
1218 hv_iterinit(MUTABLE_HV(sv));
1219 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1221 my_setenv(hv_iterkey(entry, &keylen),
1222 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1230 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1233 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1234 PERL_UNUSED_ARG(sv);
1235 PERL_UNUSED_ARG(mg);
1237 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1245 #ifdef HAS_SIGPROCMASK
1247 restore_sigmask(pTHX_ SV *save_sv)
1249 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1250 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1254 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1257 /* Are we fetching a signal entry? */
1258 int i = (I16)mg->mg_private;
1260 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1264 const char * sig = MgPV_const(mg, siglen);
1265 mg->mg_private = i = whichsig_pvn(sig, siglen);
1270 sv_setsv(sv,PL_psig_ptr[i]);
1272 Sighandler_t sigstate = rsignal_state(i);
1273 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1274 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1277 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1278 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1281 /* cache state so we don't fetch it again */
1282 if(sigstate == (Sighandler_t) SIG_IGN)
1283 sv_setpvs(sv,"IGNORE");
1285 sv_setsv(sv,&PL_sv_undef);
1286 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1293 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1295 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1297 magic_setsig(NULL, mg);
1298 return sv_unmagic(sv, mg->mg_type);
1302 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1303 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1305 Perl_csighandler(int sig)
1308 #ifdef PERL_GET_SIG_CONTEXT
1309 dTHXa(PERL_GET_SIG_CONTEXT);
1313 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1314 (void) rsignal(sig, PL_csighandlerp);
1315 if (PL_sig_ignoring[sig]) return;
1317 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1318 if (PL_sig_defaulting[sig])
1319 #ifdef KILL_BY_SIGPRC
1320 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1335 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1336 /* Call the perl level handler now--
1337 * with risk we may be in malloc() or being destructed etc. */
1338 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1339 (*PL_sighandlerp)(sig, NULL, NULL);
1341 (*PL_sighandlerp)(sig);
1344 if (!PL_psig_pend) return;
1345 /* Set a flag to say this signal is pending, that is awaiting delivery after
1346 * the current Perl opcode completes */
1347 PL_psig_pend[sig]++;
1349 #ifndef SIG_PENDING_DIE_COUNT
1350 # define SIG_PENDING_DIE_COUNT 120
1352 /* Add one to say _a_ signal is pending */
1353 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1354 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1355 (unsigned long)SIG_PENDING_DIE_COUNT);
1359 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1361 Perl_csighandler_init(void)
1364 if (PL_sig_handlers_initted) return;
1366 for (sig = 1; sig < SIG_SIZE; sig++) {
1367 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1369 PL_sig_defaulting[sig] = 1;
1370 (void) rsignal(sig, PL_csighandlerp);
1372 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1373 PL_sig_ignoring[sig] = 0;
1376 PL_sig_handlers_initted = 1;
1380 #if defined HAS_SIGPROCMASK
1382 unblock_sigmask(pTHX_ void* newset)
1384 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1389 Perl_despatch_signals(pTHX)
1394 for (sig = 1; sig < SIG_SIZE; sig++) {
1395 if (PL_psig_pend[sig]) {
1397 #ifdef HAS_SIGPROCMASK
1398 /* From sigaction(2) (FreeBSD man page):
1399 * | Signal routines normally execute with the signal that
1400 * | caused their invocation blocked, but other signals may
1402 * Emulation of this behavior (from within Perl) is enabled
1406 sigset_t newset, oldset;
1408 sigemptyset(&newset);
1409 sigaddset(&newset, sig);
1410 sigprocmask(SIG_BLOCK, &newset, &oldset);
1411 was_blocked = sigismember(&oldset, sig);
1413 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1415 SAVEFREESV(save_sv);
1416 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1419 PL_psig_pend[sig] = 0;
1420 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1421 (*PL_sighandlerp)(sig, NULL, NULL);
1423 (*PL_sighandlerp)(sig);
1425 #ifdef HAS_SIGPROCMASK
1434 /* sv of NULL signifies that we're acting as magic_clearsig. */
1436 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1441 /* Need to be careful with SvREFCNT_dec(), because that can have side
1442 * effects (due to closures). We must make sure that the new disposition
1443 * is in place before it is called.
1447 #ifdef HAS_SIGPROCMASK
1451 const char *s = MgPV_const(mg,len);
1453 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1456 if (memEQs(s, len, "__DIE__"))
1458 else if (memEQs(s, len, "__WARN__")
1459 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1460 /* Merge the existing behaviours, which are as follows:
1461 magic_setsig, we always set svp to &PL_warnhook
1462 (hence we always change the warnings handler)
1463 For magic_clearsig, we don't change the warnings handler if it's
1464 set to the &PL_warnhook. */
1467 SV *tmp = sv_newmortal();
1468 Perl_croak(aTHX_ "No such hook: %s",
1469 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1473 if (*svp != PERL_WARNHOOK_FATAL)
1479 i = (I16)mg->mg_private;
1481 i = whichsig_pvn(s, len); /* ...no, a brick */
1482 mg->mg_private = (U16)i;
1486 SV *tmp = sv_newmortal();
1487 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1488 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1492 #ifdef HAS_SIGPROCMASK
1493 /* Avoid having the signal arrive at a bad time, if possible. */
1496 sigprocmask(SIG_BLOCK, &set, &save);
1498 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1499 SAVEFREESV(save_sv);
1500 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1503 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1504 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1506 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1507 PL_sig_ignoring[i] = 0;
1509 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1510 PL_sig_defaulting[i] = 0;
1512 to_dec = PL_psig_ptr[i];
1514 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1515 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1517 /* Signals don't change name during the program's execution, so once
1518 they're cached in the appropriate slot of PL_psig_name, they can
1521 Ideally we'd find some way of making SVs at (C) compile time, or
1522 at least, doing most of the work. */
1523 if (!PL_psig_name[i]) {
1524 PL_psig_name[i] = newSVpvn(s, len);
1525 SvREADONLY_on(PL_psig_name[i]);
1528 SvREFCNT_dec(PL_psig_name[i]);
1529 PL_psig_name[i] = NULL;
1530 PL_psig_ptr[i] = NULL;
1533 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1535 (void)rsignal(i, PL_csighandlerp);
1538 *svp = SvREFCNT_inc_simple_NN(sv);
1540 if (sv && SvOK(sv)) {
1541 s = SvPV_force(sv, len);
1545 if (sv && memEQs(s, len,"IGNORE")) {
1547 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1548 PL_sig_ignoring[i] = 1;
1549 (void)rsignal(i, PL_csighandlerp);
1551 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1555 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1557 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1558 PL_sig_defaulting[i] = 1;
1559 (void)rsignal(i, PL_csighandlerp);
1561 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1567 * We should warn if HINT_STRICT_REFS, but without
1568 * access to a known hint bit in a known OP, we can't
1569 * tell whether HINT_STRICT_REFS is in force or not.
1571 if (!strchr(s,':') && !strchr(s,'\''))
1572 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1575 (void)rsignal(i, PL_csighandlerp);
1577 *svp = SvREFCNT_inc_simple_NN(sv);
1581 #ifdef HAS_SIGPROCMASK
1585 SvREFCNT_dec(to_dec);
1588 #endif /* !PERL_MICRO */
1591 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1594 PERL_ARGS_ASSERT_MAGIC_SETISA;
1595 PERL_UNUSED_ARG(sv);
1597 /* Skip _isaelem because _isa will handle it shortly */
1598 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1601 return magic_clearisa(NULL, mg);
1604 /* sv of NULL signifies that we're acting as magic_setisa. */
1606 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1611 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1613 /* Bail out if destruction is going on */
1614 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1617 av_clear(MUTABLE_AV(sv));
1619 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1620 /* This occurs with setisa_elem magic, which calls this
1622 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1624 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1625 SV **svp = AvARRAY((AV *)mg->mg_obj);
1626 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1628 stash = GvSTASH((GV *)*svp++);
1629 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1636 (const GV *)mg->mg_obj
1639 /* The stash may have been detached from the symbol table, so check its
1640 name before doing anything. */
1641 if (stash && HvENAME_get(stash))
1642 mro_isa_changed_in(stash);
1648 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1650 HV * const hv = MUTABLE_HV(LvTARG(sv));
1653 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1654 PERL_UNUSED_ARG(mg);
1657 (void) hv_iterinit(hv);
1658 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1661 while (hv_iternext(hv))
1666 sv_setiv(sv, (IV)i);
1671 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1673 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1674 PERL_UNUSED_ARG(mg);
1676 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1682 =for apidoc magic_methcall
1684 Invoke a magic method (like FETCH).
1686 C<sv> and C<mg> are the tied thingy and the tie magic.
1688 C<meth> is the name of the method to call.
1690 C<argc> is the number of args (in addition to $self) to pass to the method.
1692 The C<flags> can be:
1694 G_DISCARD invoke method with G_DISCARD flag and don't
1696 G_UNDEF_FILL fill the stack with argc pointers to
1699 The arguments themselves are any values following the C<flags> argument.
1701 Returns the SV (if any) returned by the method, or NULL on failure.
1708 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1715 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1719 if (flags & G_WRITING_TO_STDERR) {
1723 SAVESPTR(PL_stderrgv);
1727 PUSHSTACKi(PERLSI_MAGIC);
1731 PUSHs(SvTIED_obj(sv, mg));
1732 if (flags & G_UNDEF_FILL) {
1734 PUSHs(&PL_sv_undef);
1736 } else if (argc > 0) {
1738 va_start(args, argc);
1741 SV *const sv = va_arg(args, SV *);
1748 if (flags & G_DISCARD) {
1749 call_method(meth, G_SCALAR|G_DISCARD);
1752 if (call_method(meth, G_SCALAR))
1753 ret = *PL_stack_sp--;
1756 if (flags & G_WRITING_TO_STDERR)
1763 /* wrapper for magic_methcall that creates the first arg */
1766 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1772 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1775 if (mg->mg_len >= 0) {
1776 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1778 else if (mg->mg_len == HEf_SVKEY)
1779 arg1 = MUTABLE_SV(mg->mg_ptr);
1781 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1782 arg1 = newSViv((IV)(mg->mg_len));
1786 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1788 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1792 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1797 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1799 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1806 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1808 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1810 if (mg->mg_type == PERL_MAGIC_tiedelem)
1811 mg->mg_flags |= MGf_GSKIP;
1812 magic_methpack(sv,mg,"FETCH");
1817 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1823 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1825 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1826 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1827 * public flags indicate its value based on copying from $val. Doing
1828 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1829 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1830 * wrong if $val happened to be tainted, as sv hasn't got magic
1831 * enabled, even though taint magic is in the chain. In which case,
1832 * fake up a temporary tainted value (this is easier than temporarily
1833 * re-enabling magic on sv). */
1835 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1836 && (tmg->mg_len & 1))
1838 val = sv_mortalcopy(sv);
1844 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1849 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1853 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1854 return magic_methpack(sv,mg,"DELETE");
1859 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1865 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1867 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1869 retval = SvIV(retsv)-1;
1871 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1873 return (U32) retval;
1877 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1881 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1883 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1888 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1893 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1895 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1896 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1903 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1905 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1907 return magic_methpack(sv,mg,"EXISTS");
1911 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1915 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1916 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1918 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1920 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1922 if (HvEITER_get(hv))
1923 /* we are in an iteration so the hash cannot be empty */
1925 /* no xhv_eiter so now use FIRSTKEY */
1926 key = sv_newmortal();
1927 magic_nextpack(MUTABLE_SV(hv), mg, key);
1928 HvEITER_set(hv, NULL); /* need to reset iterator */
1929 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1932 /* there is a SCALAR method that we can call */
1933 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1935 retval = &PL_sv_undef;
1940 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1943 GV * const gv = PL_DBline;
1944 const I32 i = SvTRUE(sv);
1945 SV ** const svp = av_fetch(GvAV(gv),
1946 atoi(MgPV_nolen_const(mg)), FALSE);
1948 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1950 if (svp && SvIOKp(*svp)) {
1951 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1953 #ifdef PERL_DEBUG_READONLY_OPS
1954 Slab_to_rw(OpSLAB(o));
1956 /* set or clear breakpoint in the relevant control op */
1958 o->op_flags |= OPf_SPECIAL;
1960 o->op_flags &= ~OPf_SPECIAL;
1961 #ifdef PERL_DEBUG_READONLY_OPS
1962 Slab_to_ro(OpSLAB(o));
1970 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1973 AV * const obj = MUTABLE_AV(mg->mg_obj);
1975 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1978 sv_setiv(sv, AvFILL(obj));
1986 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1989 AV * const obj = MUTABLE_AV(mg->mg_obj);
1991 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1994 av_fill(obj, SvIV(sv));
1996 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1997 "Attempt to set length of freed array");
2003 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2007 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2008 PERL_UNUSED_ARG(sv);
2010 /* Reset the iterator when the array is cleared */
2011 #if IVSIZE == I32SIZE
2012 *((IV *) &(mg->mg_len)) = 0;
2015 *((IV *) mg->mg_ptr) = 0;
2022 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2026 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2027 PERL_UNUSED_ARG(sv);
2029 /* during global destruction, mg_obj may already have been freed */
2030 if (PL_in_clean_all)
2033 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2036 /* arylen scalar holds a pointer back to the array, but doesn't own a
2037 reference. Hence the we (the array) are about to go away with it
2038 still pointing at us. Clear its pointer, else it would be pointing
2039 at free memory. See the comment in sv_magic about reference loops,
2040 and why it can't own a reference to us. */
2047 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2050 SV* const lsv = LvTARG(sv);
2052 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2053 PERL_UNUSED_ARG(mg);
2055 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2056 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2057 if (found && found->mg_len >= 0) {
2058 I32 i = found->mg_len;
2060 sv_pos_b2u(lsv, &i);
2070 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2073 SV* const lsv = LvTARG(sv);
2080 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2081 PERL_UNUSED_ARG(mg);
2083 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2084 found = mg_find(lsv, PERL_MAGIC_regex_global);
2090 #ifdef PERL_OLD_COPY_ON_WRITE
2092 sv_force_normal_flags(lsv, 0);
2094 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2097 else if (!SvOK(sv)) {
2101 s = SvPV_const(lsv, len);
2106 ulen = sv_or_pv_len_utf8(lsv, s, len);
2116 else if (pos > (SSize_t)len)
2120 pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
2123 found->mg_len = pos;
2124 found->mg_flags &= ~MGf_MINMATCH;
2130 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2133 SV * const lsv = LvTARG(sv);
2134 const char * const tmps = SvPV_const(lsv,len);
2135 STRLEN offs = LvTARGOFF(sv);
2136 STRLEN rem = LvTARGLEN(sv);
2137 const bool negoff = LvFLAGS(sv) & 1;
2138 const bool negrem = LvFLAGS(sv) & 2;
2140 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2141 PERL_UNUSED_ARG(mg);
2143 if (!translate_substr_offsets(
2144 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2145 negoff ? -(IV)offs : (IV)offs, !negoff,
2146 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2148 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2149 sv_setsv_nomg(sv, &PL_sv_undef);
2154 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2155 sv_setpvn(sv, tmps + offs, rem);
2162 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2165 STRLEN len, lsv_len, oldtarglen, newtarglen;
2166 const char * const tmps = SvPV_const(sv, len);
2167 SV * const lsv = LvTARG(sv);
2168 STRLEN lvoff = LvTARGOFF(sv);
2169 STRLEN lvlen = LvTARGLEN(sv);
2170 const bool negoff = LvFLAGS(sv) & 1;
2171 const bool neglen = LvFLAGS(sv) & 2;
2173 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2174 PERL_UNUSED_ARG(mg);
2178 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2179 "Attempt to use reference as lvalue in substr"
2181 SvPV_force_nomg(lsv,lsv_len);
2182 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2183 if (!translate_substr_offsets(
2185 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2186 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2188 Perl_croak(aTHX_ "substr outside of string");
2191 sv_utf8_upgrade_nomg(lsv);
2192 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2193 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2194 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2197 else if (SvUTF8(lsv)) {
2199 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2201 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2202 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2206 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2209 if (!neglen) LvTARGLEN(sv) = newtarglen;
2210 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2216 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2220 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2221 PERL_UNUSED_ARG(sv);
2223 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2228 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2232 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2233 PERL_UNUSED_ARG(sv);
2235 /* update taint status */
2244 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2246 SV * const lsv = LvTARG(sv);
2248 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2249 PERL_UNUSED_ARG(mg);
2252 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2260 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2262 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2263 PERL_UNUSED_ARG(mg);
2264 do_vecset(sv); /* XXX slurp this routine */
2269 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2274 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2276 if (LvTARGLEN(sv)) {
2278 SV * const ahv = LvTARG(sv);
2279 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2284 AV *const av = MUTABLE_AV(LvTARG(sv));
2285 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2286 targ = AvARRAY(av)[LvTARGOFF(sv)];
2288 if (targ && (targ != &PL_sv_undef)) {
2289 /* somebody else defined it for us */
2290 SvREFCNT_dec(LvTARG(sv));
2291 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2293 SvREFCNT_dec(mg->mg_obj);
2295 mg->mg_flags &= ~MGf_REFCOUNTED;
2300 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2305 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2307 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2308 PERL_UNUSED_ARG(mg);
2312 sv_setsv(LvTARG(sv), sv);
2313 SvSETMAGIC(LvTARG(sv));
2319 Perl_vivify_defelem(pTHX_ SV *sv)
2325 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2327 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2330 SV * const ahv = LvTARG(sv);
2331 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2334 if (!value || value == &PL_sv_undef)
2335 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2338 AV *const av = MUTABLE_AV(LvTARG(sv));
2339 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2340 LvTARG(sv) = NULL; /* array can't be extended */
2342 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2343 if (!svp || (value = *svp) == &PL_sv_undef)
2344 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2347 SvREFCNT_inc_simple_void(value);
2348 SvREFCNT_dec(LvTARG(sv));
2351 SvREFCNT_dec(mg->mg_obj);
2353 mg->mg_flags &= ~MGf_REFCOUNTED;
2357 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2359 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2360 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2365 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2367 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2368 PERL_UNUSED_CONTEXT;
2369 PERL_UNUSED_ARG(sv);
2375 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2377 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2379 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2381 if (uf && uf->uf_set)
2382 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2387 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2389 const char type = mg->mg_type;
2391 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2393 if (type == PERL_MAGIC_qr) {
2394 } else if (type == PERL_MAGIC_bm) {
2398 assert(type == PERL_MAGIC_fm);
2400 return sv_unmagic(sv, type);
2403 #ifdef USE_LOCALE_COLLATE
2405 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2407 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2410 * RenE<eacute> Descartes said "I think not."
2411 * and vanished with a faint plop.
2413 PERL_UNUSED_CONTEXT;
2414 PERL_UNUSED_ARG(sv);
2416 Safefree(mg->mg_ptr);
2422 #endif /* USE_LOCALE_COLLATE */
2424 /* Just clear the UTF-8 cache data. */
2426 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2428 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2429 PERL_UNUSED_CONTEXT;
2430 PERL_UNUSED_ARG(sv);
2431 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2433 mg->mg_len = -1; /* The mg_len holds the len cache. */
2438 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2444 const char * const remaining = mg->mg_ptr + 1;
2449 PERL_ARGS_ASSERT_MAGIC_SET;
2451 switch (*mg->mg_ptr) {
2452 case '\015': /* $^MATCH */
2453 if (strEQ(remaining, "ATCH"))
2455 case '`': /* ${^PREMATCH} caught below */
2457 paren = RX_BUFF_IDX_PREMATCH;
2459 case '\'': /* ${^POSTMATCH} caught below */
2461 paren = RX_BUFF_IDX_POSTMATCH;
2465 paren = RX_BUFF_IDX_FULLMATCH;
2467 case '1': case '2': case '3': case '4':
2468 case '5': case '6': case '7': case '8': case '9':
2469 paren = atoi(mg->mg_ptr);
2471 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2473 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2475 /* Croak with a READONLY error when a numbered match var is
2476 * set without a previous pattern match. Unless it's C<local $1>
2479 if (!PL_localizing) {
2480 Perl_croak_no_modify();
2484 case '\001': /* ^A */
2485 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2486 else SvOK_off(PL_bodytarget);
2487 FmLINES(PL_bodytarget) = 0;
2488 if (SvPOK(PL_bodytarget)) {
2489 char *s = SvPVX(PL_bodytarget);
2490 while ( ((s = strchr(s, '\n'))) ) {
2491 FmLINES(PL_bodytarget)++;
2495 /* mg_set() has temporarily made sv non-magical */
2497 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2498 SvTAINTED_on(PL_bodytarget);
2500 SvTAINTED_off(PL_bodytarget);
2503 case '\003': /* ^C */
2504 PL_minus_c = cBOOL(SvIV(sv));
2507 case '\004': /* ^D */
2509 s = SvPV_nolen_const(sv);
2510 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2511 if (DEBUG_x_TEST || DEBUG_B_TEST)
2512 dump_all_perl(!DEBUG_B_TEST);
2514 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2517 case '\005': /* ^E */
2518 if (*(mg->mg_ptr+1) == '\0') {
2520 set_vaxc_errno(SvIV(sv));
2523 SetLastError( SvIV(sv) );
2526 os2_setsyserrno(SvIV(sv));
2528 /* will anyone ever use this? */
2529 SETERRNO(SvIV(sv), 4);
2534 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2535 SvREFCNT_dec(PL_encoding);
2536 if (SvOK(sv) || SvGMAGICAL(sv)) {
2537 PL_encoding = newSVsv(sv);
2544 case '\006': /* ^F */
2545 PL_maxsysfd = SvIV(sv);
2547 case '\010': /* ^H */
2548 PL_hints = SvIV(sv);
2550 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2551 Safefree(PL_inplace);
2552 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2554 case '\016': /* ^N */
2555 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2556 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2558 case '\017': /* ^O */
2559 if (*(mg->mg_ptr+1) == '\0') {
2560 Safefree(PL_osname);
2563 TAINT_PROPER("assigning to $^O");
2564 PL_osname = savesvpv(sv);
2567 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2569 const char *const start = SvPV(sv, len);
2570 const char *out = (const char*)memchr(start, '\0', len);
2574 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2575 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2577 /* Opening for input is more common than opening for output, so
2578 ensure that hints for input are sooner on linked list. */
2579 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2581 : newSVpvs_flags("", SvUTF8(sv));
2582 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2585 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2587 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2591 case '\020': /* ^P */
2592 if (*remaining == '\0') { /* ^P */
2593 PL_perldb = SvIV(sv);
2594 if (PL_perldb && !PL_DBsingle)
2597 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2599 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2603 case '\024': /* ^T */
2605 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2607 PL_basetime = (Time_t)SvIV(sv);
2610 case '\025': /* ^UTF8CACHE */
2611 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2612 PL_utf8cache = (signed char) sv_2iv(sv);
2615 case '\027': /* ^W & $^WARNING_BITS */
2616 if (*(mg->mg_ptr+1) == '\0') {
2617 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2619 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2620 | (i ? G_WARN_ON : G_WARN_OFF) ;
2623 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2624 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2626 PL_compiling.cop_warnings = pWARN_STD;
2631 int accumulate = 0 ;
2632 int any_fatals = 0 ;
2633 const char * const ptr = SvPV_const(sv, len) ;
2634 for (i = 0 ; i < len ; ++i) {
2635 accumulate |= ptr[i] ;
2636 any_fatals |= (ptr[i] & 0xAA) ;
2639 if (!specialWARN(PL_compiling.cop_warnings))
2640 PerlMemShared_free(PL_compiling.cop_warnings);
2641 PL_compiling.cop_warnings = pWARN_NONE;
2643 /* Yuck. I can't see how to abstract this: */
2644 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2645 WARN_ALL) && !any_fatals) {
2646 if (!specialWARN(PL_compiling.cop_warnings))
2647 PerlMemShared_free(PL_compiling.cop_warnings);
2648 PL_compiling.cop_warnings = pWARN_ALL;
2649 PL_dowarn |= G_WARN_ONCE ;
2653 const char *const p = SvPV_const(sv, len);
2655 PL_compiling.cop_warnings
2656 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2659 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2660 PL_dowarn |= G_WARN_ONCE ;
2668 if (PL_localizing) {
2669 if (PL_localizing == 1)
2670 SAVESPTR(PL_last_in_gv);
2672 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2673 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2676 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2677 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2678 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2681 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2682 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2683 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2686 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2689 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2690 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2691 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2694 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2698 IO * const io = GvIO(PL_defoutgv);
2701 if ((SvIV(sv)) == 0)
2702 IoFLAGS(io) &= ~IOf_FLUSH;
2704 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2705 PerlIO *ofp = IoOFP(io);
2707 (void)PerlIO_flush(ofp);
2708 IoFLAGS(io) |= IOf_FLUSH;
2714 SvREFCNT_dec(PL_rs);
2715 PL_rs = newSVsv(sv);
2718 SvREFCNT_dec(PL_ors_sv);
2720 PL_ors_sv = newSVsv(sv);
2728 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2731 #ifdef COMPLEX_STATUS
2732 if (PL_localizing == 2) {
2733 SvUPGRADE(sv, SVt_PVLV);
2734 PL_statusvalue = LvTARGOFF(sv);
2735 PL_statusvalue_vms = LvTARGLEN(sv);
2739 #ifdef VMSISH_STATUS
2741 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2744 STATUS_UNIX_EXIT_SET(SvIV(sv));
2749 # define PERL_VMS_BANG vaxc$errno
2751 # define PERL_VMS_BANG 0
2753 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2754 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2759 const IV new_uid = SvIV(sv);
2760 PL_delaymagic_uid = new_uid;
2761 if (PL_delaymagic) {
2762 PL_delaymagic |= DM_RUID;
2763 break; /* don't do magic till later */
2766 (void)setruid((Uid_t)new_uid);
2769 (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2771 #ifdef HAS_SETRESUID
2772 (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2774 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2776 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2777 if (new_uid != 0 && PerlProc_getuid() == 0)
2778 (void)PerlProc_setuid(0);
2780 (void)PerlProc_setuid(new_uid);
2782 Perl_croak(aTHX_ "setruid() not implemented");
2791 const UV new_euid = SvIV(sv);
2792 PL_delaymagic_euid = new_euid;
2793 if (PL_delaymagic) {
2794 PL_delaymagic |= DM_EUID;
2795 break; /* don't do magic till later */
2798 (void)seteuid((Uid_t)new_euid);
2801 (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2803 #ifdef HAS_SETRESUID
2804 (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2806 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2807 PerlProc_setuid(new_euid);
2809 Perl_croak(aTHX_ "seteuid() not implemented");
2818 const UV new_gid = SvIV(sv);
2819 PL_delaymagic_gid = new_gid;
2820 if (PL_delaymagic) {
2821 PL_delaymagic |= DM_RGID;
2822 break; /* don't do magic till later */
2825 (void)setrgid((Gid_t)new_gid);
2828 (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2830 #ifdef HAS_SETRESGID
2831 (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2833 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2834 (void)PerlProc_setgid(new_gid);
2836 Perl_croak(aTHX_ "setrgid() not implemented");
2846 #ifdef HAS_SETGROUPS
2848 const char *p = SvPV_const(sv, len);
2849 Groups_t *gary = NULL;
2850 #ifdef _SC_NGROUPS_MAX
2851 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2856 int maxgrp = NGROUPS;
2862 for (i = 0; i < maxgrp; ++i) {
2863 while (*p && !isSPACE(*p))
2870 Newx(gary, i + 1, Groups_t);
2872 Renew(gary, i + 1, Groups_t);
2876 (void)setgroups(i, gary);
2879 #else /* HAS_SETGROUPS */
2880 new_egid = SvIV(sv);
2881 #endif /* HAS_SETGROUPS */
2882 PL_delaymagic_egid = new_egid;
2883 if (PL_delaymagic) {
2884 PL_delaymagic |= DM_EGID;
2885 break; /* don't do magic till later */
2888 (void)setegid((Gid_t)new_egid);
2891 (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2893 #ifdef HAS_SETRESGID
2894 (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2896 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2897 (void)PerlProc_setgid(new_egid);
2899 Perl_croak(aTHX_ "setegid() not implemented");
2907 PL_chopset = SvPV_force(sv,len);
2910 /* Store the pid in mg->mg_obj so we can tell when a fork has
2911 occurred. mg->mg_obj points to *$ by default, so clear it. */
2912 if (isGV(mg->mg_obj)) {
2913 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2914 SvREFCNT_dec(mg->mg_obj);
2915 mg->mg_flags |= MGf_REFCOUNTED;
2916 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2918 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2921 LOCK_DOLLARZERO_MUTEX;
2922 #ifdef HAS_SETPROCTITLE
2923 /* The BSDs don't show the argv[] in ps(1) output, they
2924 * show a string from the process struct and provide
2925 * the setproctitle() routine to manipulate that. */
2926 if (PL_origalen != 1) {
2927 s = SvPV_const(sv, len);
2928 # if __FreeBSD_version > 410001
2929 /* The leading "-" removes the "perl: " prefix,
2930 * but not the "(perl) suffix from the ps(1)
2931 * output, because that's what ps(1) shows if the
2932 * argv[] is modified. */
2933 setproctitle("-%s", s);
2934 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2935 /* This doesn't really work if you assume that
2936 * $0 = 'foobar'; will wipe out 'perl' from the $0
2937 * because in ps(1) output the result will be like
2938 * sprintf("perl: %s (perl)", s)
2939 * I guess this is a security feature:
2940 * one (a user process) cannot get rid of the original name.
2942 setproctitle("%s", s);
2945 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2946 if (PL_origalen != 1) {
2948 s = SvPV_const(sv, len);
2949 un.pst_command = (char *)s;
2950 pstat(PSTAT_SETCMD, un, len, 0, 0);
2953 if (PL_origalen > 1) {
2954 /* PL_origalen is set in perl_parse(). */
2955 s = SvPV_force(sv,len);
2956 if (len >= (STRLEN)PL_origalen-1) {
2957 /* Longer than original, will be truncated. We assume that
2958 * PL_origalen bytes are available. */
2959 Copy(s, PL_origargv[0], PL_origalen-1, char);
2962 /* Shorter than original, will be padded. */
2964 /* Special case for Mac OS X: see [perl #38868] */
2967 /* Is the space counterintuitive? Yes.
2968 * (You were expecting \0?)
2969 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2971 const int pad = ' ';
2973 Copy(s, PL_origargv[0], len, char);
2974 PL_origargv[0][len] = 0;
2975 memset(PL_origargv[0] + len + 1,
2976 pad, PL_origalen - len - 1);
2978 PL_origargv[0][PL_origalen-1] = 0;
2979 for (i = 1; i < PL_origargc; i++)
2981 #ifdef HAS_PRCTL_SET_NAME
2982 /* Set the legacy process name in addition to the POSIX name on Linux */
2983 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2984 /* diag_listed_as: SKIPME */
2985 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2990 UNLOCK_DOLLARZERO_MUTEX;
2997 Perl_whichsig_sv(pTHX_ SV *sigsv)
3001 PERL_ARGS_ASSERT_WHICHSIG_SV;
3002 PERL_UNUSED_CONTEXT;
3003 sigpv = SvPV_const(sigsv, siglen);
3004 return whichsig_pvn(sigpv, siglen);
3008 Perl_whichsig_pv(pTHX_ const char *sig)
3010 PERL_ARGS_ASSERT_WHICHSIG_PV;
3011 PERL_UNUSED_CONTEXT;
3012 return whichsig_pvn(sig, strlen(sig));
3016 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3020 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3021 PERL_UNUSED_CONTEXT;
3023 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3024 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3025 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3027 if (memEQs(sig, len, "CHLD"))
3031 if (memEQs(sig, len, "CLD"))
3038 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3039 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3041 Perl_sighandler(int sig)
3044 #ifdef PERL_GET_SIG_CONTEXT
3045 dTHXa(PERL_GET_SIG_CONTEXT);
3052 SV * const tSv = PL_Sv;
3056 XPV * const tXpv = PL_Xpv;
3057 I32 old_ss_ix = PL_savestack_ix;
3058 SV *errsv_save = NULL;
3061 if (!PL_psig_ptr[sig]) {
3062 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3067 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3068 /* Max number of items pushed there is 3*n or 4. We cannot fix
3069 infinity, so we fix 4 (in fact 5): */
3070 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3072 PL_savestack_ix += 5; /* Protect save in progress. */
3073 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3076 /* sv_2cv is too complicated, try a simpler variant first: */
3077 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3078 || SvTYPE(cv) != SVt_PVCV) {
3080 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3083 if (!cv || !CvROOT(cv)) {
3084 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3085 PL_sig_name[sig], (gv ? GvENAME(gv)
3092 sv = PL_psig_name[sig]
3093 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3094 : newSVpv(PL_sig_name[sig],0);
3098 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3099 /* make sure our assumption about the size of the SAVEs are correct:
3100 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3101 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3104 PUSHSTACKi(PERLSI_SIGNAL);
3107 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3109 struct sigaction oact;
3111 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3114 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3115 /* The siginfo fields signo, code, errno, pid, uid,
3116 * addr, status, and band are defined by POSIX/SUSv3. */
3117 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3118 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3119 #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. */
3120 hv_stores(sih, "errno", newSViv(sip->si_errno));
3121 hv_stores(sih, "status", newSViv(sip->si_status));
3122 hv_stores(sih, "uid", newSViv(sip->si_uid));
3123 hv_stores(sih, "pid", newSViv(sip->si_pid));
3124 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3125 hv_stores(sih, "band", newSViv(sip->si_band));
3129 mPUSHp((char *)sip, sizeof(*sip));
3137 errsv_save = newSVsv(ERRSV);
3139 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3143 SV * const errsv = ERRSV;
3144 if (SvTRUE_NN(errsv)) {
3145 SvREFCNT_dec(errsv_save);
3147 /* Handler "died", for example to get out of a restart-able read().
3148 * Before we re-do that on its behalf re-enable the signal which was
3149 * blocked by the system when we entered.
3151 #ifdef HAS_SIGPROCMASK
3152 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3158 sigaddset(&set,sig);
3159 sigprocmask(SIG_UNBLOCK, &set, NULL);
3162 /* Not clear if this will work */
3163 (void)rsignal(sig, SIG_IGN);
3164 (void)rsignal(sig, PL_csighandlerp);
3166 #endif /* !PERL_MICRO */
3170 sv_setsv(errsv, errsv_save);
3171 SvREFCNT_dec(errsv_save);
3176 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3177 PL_savestack_ix = old_ss_ix;
3180 PL_op = myop; /* Apparently not needed... */
3182 PL_Sv = tSv; /* Restore global temporaries. */
3189 S_restore_magic(pTHX_ const void *p)
3192 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3193 SV* const sv = mgs->mgs_sv;
3199 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3200 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3201 #ifdef PERL_OLD_COPY_ON_WRITE
3202 /* While magic was saved (and off) sv_setsv may well have seen
3203 this SV as a prime candidate for COW. */
3205 sv_force_normal_flags(sv, 0);
3207 if (mgs->mgs_readonly)
3209 if (mgs->mgs_magical)
3210 SvFLAGS(sv) |= mgs->mgs_magical;
3215 bumped = mgs->mgs_bumped;
3216 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3218 /* If we're still on top of the stack, pop us off. (That condition
3219 * will be satisfied if restore_magic was called explicitly, but *not*
3220 * if it's being called via leave_scope.)
3221 * The reason for doing this is that otherwise, things like sv_2cv()
3222 * may leave alloc gunk on the savestack, and some code
3223 * (e.g. sighandler) doesn't expect that...
3225 if (PL_savestack_ix == mgs->mgs_ss_ix)
3227 UV popval = SSPOPUV;
3228 assert(popval == SAVEt_DESTRUCTOR_X);
3229 PL_savestack_ix -= 2;
3231 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3232 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3235 if (SvREFCNT(sv) == 1) {
3236 /* We hold the last reference to this SV, which implies that the
3237 SV was deleted as a side effect of the routines we called.
3238 So artificially keep it alive a bit longer.
3239 We avoid turning on the TEMP flag, which can cause the SV's
3240 buffer to get stolen (and maybe other stuff). */
3245 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3249 /* clean up the mess created by Perl_sighandler().
3250 * Note that this is only called during an exit in a signal handler;
3251 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3255 S_unwind_handler_stack(pTHX_ const void *p)
3260 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3264 =for apidoc magic_sethint
3266 Triggered by a store to %^H, records the key/value pair to
3267 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3268 anything that would need a deep copy. Maybe we should warn if we find a
3274 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3277 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3278 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3280 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3282 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3283 an alternative leaf in there, with PL_compiling.cop_hints being used if
3284 it's NULL. If needed for threads, the alternative could lock a mutex,
3285 or take other more complex action. */
3287 /* Something changed in %^H, so it will need to be restored on scope exit.
3288 Doing this here saves a lot of doing it manually in perl code (and
3289 forgetting to do it, and consequent subtle errors. */
3290 PL_hints |= HINT_LOCALIZE_HH;
3291 CopHINTHASH_set(&PL_compiling,
3292 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3297 =for apidoc magic_clearhint
3299 Triggered by a delete from %^H, records the key to
3300 C<PL_compiling.cop_hints_hash>.
3305 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3309 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3310 PERL_UNUSED_ARG(sv);
3312 PL_hints |= HINT_LOCALIZE_HH;
3313 CopHINTHASH_set(&PL_compiling,
3314 mg->mg_len == HEf_SVKEY
3315 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3316 MUTABLE_SV(mg->mg_ptr), 0, 0)
3317 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3318 mg->mg_ptr, mg->mg_len, 0, 0));
3323 =for apidoc magic_clearhints
3325 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3330 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3332 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3333 PERL_UNUSED_ARG(sv);
3334 PERL_UNUSED_ARG(mg);
3335 cophh_free(CopHINTHASH_get(&PL_compiling));
3336 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3341 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3342 const char *name, I32 namlen)
3346 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3347 PERL_UNUSED_ARG(sv);
3348 PERL_UNUSED_ARG(name);
3349 PERL_UNUSED_ARG(namlen);
3351 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3352 nmg = mg_find(nsv, mg->mg_type);
3353 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3354 nmg->mg_ptr = mg->mg_ptr;
3355 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3356 nmg->mg_flags |= MGf_REFCOUNTED;
3362 * c-indentation-style: bsd
3364 * indent-tabs-mode: nil
3367 * ex: set ts=8 sts=4 sw=4 et: