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. 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(mgs_ix, sv);
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 This function is deprecated.
291 It reports on the SV's length in bytes, calling length magic if available,
292 but does not set the UTF8 flag on the sv. It will fall back to 'get'
293 magic if there is no 'length' magic, but with no indication as to
294 whether it called 'get' magic. It assumes the sv is a PVMG or
295 higher. Use sv_len() instead.
301 Perl_mg_length(pTHX_ SV *sv)
307 PERL_ARGS_ASSERT_MG_LENGTH;
309 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
310 const MGVTBL * const vtbl = mg->mg_virtual;
311 if (vtbl && vtbl->svt_len) {
312 const I32 mgs_ix = SSNEW(sizeof(MGS));
313 save_magic(mgs_ix, sv);
314 /* omit MGf_GSKIP -- not changed here */
315 len = vtbl->svt_len(aTHX_ sv, mg);
316 restore_magic(INT2PTR(void*, (IV)mgs_ix));
321 (void)SvPV_const(sv, len);
326 Perl_mg_size(pTHX_ SV *sv)
330 PERL_ARGS_ASSERT_MG_SIZE;
332 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
333 const MGVTBL* const vtbl = mg->mg_virtual;
334 if (vtbl && vtbl->svt_len) {
335 const I32 mgs_ix = SSNEW(sizeof(MGS));
337 save_magic(mgs_ix, sv);
338 /* omit MGf_GSKIP -- not changed here */
339 len = vtbl->svt_len(aTHX_ sv, mg);
340 restore_magic(INT2PTR(void*, (IV)mgs_ix));
347 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
351 Perl_croak(aTHX_ "Size magic not implemented");
360 Clear something magical that the SV represents. See C<sv_magic>.
366 Perl_mg_clear(pTHX_ SV *sv)
368 const I32 mgs_ix = SSNEW(sizeof(MGS));
372 PERL_ARGS_ASSERT_MG_CLEAR;
374 save_magic(mgs_ix, sv);
376 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
377 const MGVTBL* const vtbl = mg->mg_virtual;
378 /* omit GSKIP -- never set here */
380 nextmg = mg->mg_moremagic; /* it may delete itself */
382 if (vtbl && vtbl->svt_clear)
383 vtbl->svt_clear(aTHX_ sv, mg);
386 restore_magic(INT2PTR(void*, (IV)mgs_ix));
391 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
400 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
401 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
413 Finds the magic pointer for type matching the SV. See C<sv_magic>.
419 Perl_mg_find(pTHX_ const SV *sv, int type)
421 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
425 =for apidoc mg_findext
427 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
434 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
436 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
442 Copies the magic from one SV to another. See C<sv_magic>.
448 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
453 PERL_ARGS_ASSERT_MG_COPY;
455 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
456 const MGVTBL* const vtbl = mg->mg_virtual;
457 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
458 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
461 const char type = mg->mg_type;
462 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
464 (type == PERL_MAGIC_tied)
466 : (type == PERL_MAGIC_regdata && mg->mg_obj)
469 toLOWER(type), key, klen);
478 =for apidoc mg_localize
480 Copy some of the magic from an existing SV to new localized version of that
481 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
484 If setmagic is false then no set magic will be called on the new (empty) SV.
485 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
486 and that will handle the magic.
492 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
497 PERL_ARGS_ASSERT_MG_LOCALIZE;
502 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
503 const MGVTBL* const vtbl = mg->mg_virtual;
504 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
507 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
508 (void)vtbl->svt_local(aTHX_ nsv, mg);
510 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
511 mg->mg_ptr, mg->mg_len);
513 /* container types should remain read-only across localization */
514 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
517 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
518 SvFLAGS(nsv) |= SvMAGICAL(sv);
527 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
529 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
531 const MGVTBL* const vtbl = mg->mg_virtual;
532 if (vtbl && vtbl->svt_free)
533 vtbl->svt_free(aTHX_ sv, mg);
534 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
535 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
536 Safefree(mg->mg_ptr);
537 else if (mg->mg_len == HEf_SVKEY)
538 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
540 if (mg->mg_flags & MGf_REFCOUNTED)
541 SvREFCNT_dec(mg->mg_obj);
548 Free any magic storage used by the SV. See C<sv_magic>.
554 Perl_mg_free(pTHX_ SV *sv)
559 PERL_ARGS_ASSERT_MG_FREE;
561 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
562 moremagic = mg->mg_moremagic;
563 mg_free_struct(sv, mg);
564 SvMAGIC_set(sv, moremagic);
566 SvMAGIC_set(sv, NULL);
572 =for apidoc Am|void|mg_free_type|SV *sv|int how
574 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
580 Perl_mg_free_type(pTHX_ SV *sv, int how)
582 MAGIC *mg, *prevmg, *moremg;
583 PERL_ARGS_ASSERT_MG_FREE_TYPE;
584 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
586 moremg = mg->mg_moremagic;
587 if (mg->mg_type == how) {
588 /* temporarily move to the head of the magic chain, in case
589 custom free code relies on this historical aspect of mg_free */
591 prevmg->mg_moremagic = moremg;
592 mg->mg_moremagic = SvMAGIC(sv);
595 newhead = mg->mg_moremagic;
596 mg_free_struct(sv, mg);
597 SvMAGIC_set(sv, newhead);
607 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
612 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
615 const REGEXP * const rx = PM_GETRE(PL_curpm);
617 if (mg->mg_obj) { /* @+ */
618 /* return the number possible */
619 return RX_NPARENS(rx);
621 I32 paren = RX_LASTPAREN(rx);
623 /* return the last filled */
625 && (RX_OFFS(rx)[paren].start == -1
626 || RX_OFFS(rx)[paren].end == -1) )
639 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
643 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
646 const REGEXP * const rx = PM_GETRE(PL_curpm);
648 const I32 paren = mg->mg_len;
653 if (paren <= (I32)RX_NPARENS(rx) &&
654 (s = RX_OFFS(rx)[paren].start) != -1 &&
655 (t = RX_OFFS(rx)[paren].end) != -1)
658 if (mg->mg_obj) /* @+ */
663 if (i > 0 && RX_MATCH_UTF8(rx)) {
664 const char * const b = RX_SUBBEG(rx);
666 i = RX_SUBCOFFSET(rx) +
668 (U8*)(b-RX_SUBOFFSET(rx)+i));
681 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
683 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
686 Perl_croak_no_modify();
687 NORETURN_FUNCTION_END;
690 #define SvRTRIM(sv) STMT_START { \
692 STRLEN len = SvCUR(sv); \
693 char * const p = SvPVX(sv); \
694 while (len > 0 && isSPACE(p[len-1])) \
696 SvCUR_set(sv, len); \
702 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
704 PERL_ARGS_ASSERT_EMULATE_COP_IO;
706 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
707 sv_setsv(sv, &PL_sv_undef);
711 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
712 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
717 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
718 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
731 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
735 const char *s = NULL;
737 const char * const remaining = mg->mg_ptr + 1;
738 const char nextchar = *remaining;
740 PERL_ARGS_ASSERT_MAGIC_GET;
742 switch (*mg->mg_ptr) {
743 case '\001': /* ^A */
744 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
745 else sv_setsv(sv, &PL_sv_undef);
746 if (SvTAINTED(PL_bodytarget))
749 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
750 if (nextchar == '\0') {
751 sv_setiv(sv, (IV)PL_minus_c);
753 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
754 sv_setiv(sv, (IV)STATUS_NATIVE);
758 case '\004': /* ^D */
759 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
761 case '\005': /* ^E */
762 if (nextchar == '\0') {
766 $DESCRIPTOR(msgdsc,msg);
767 sv_setnv(sv,(NV) vaxc$errno);
768 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
769 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
774 if (!(_emx_env & 0x200)) { /* Under DOS */
775 sv_setnv(sv, (NV)errno);
776 sv_setpv(sv, errno ? Strerror(errno) : "");
778 if (errno != errno_isOS2) {
779 const int tmp = _syserrno();
780 if (tmp) /* 2nd call to _syserrno() makes it 0 */
783 sv_setnv(sv, (NV)Perl_rc);
784 sv_setpv(sv, os2error(Perl_rc));
788 const DWORD dwErr = GetLastError();
789 sv_setnv(sv, (NV)dwErr);
791 PerlProc_GetOSError(sv, dwErr);
800 sv_setnv(sv, (NV)errno);
801 sv_setpv(sv, errno ? Strerror(errno) : "");
806 SvNOK_on(sv); /* what a wonderful hack! */
808 else if (strEQ(remaining, "NCODING"))
809 sv_setsv(sv, PL_encoding);
811 case '\006': /* ^F */
812 sv_setiv(sv, (IV)PL_maxsysfd);
814 case '\007': /* ^GLOBAL_PHASE */
815 if (strEQ(remaining, "LOBAL_PHASE")) {
816 sv_setpvn(sv, PL_phase_names[PL_phase],
817 strlen(PL_phase_names[PL_phase]));
820 case '\010': /* ^H */
821 sv_setiv(sv, (IV)PL_hints);
823 case '\011': /* ^I */ /* NOT \t in EBCDIC */
824 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
826 case '\014': /* ^LAST_FH */
827 if (strEQ(remaining, "AST_FH")) {
829 assert(isGV_with_GP(PL_last_in_gv));
830 SV_CHECK_THINKFIRST_COW_DROP(sv);
831 prepare_SV_for_RV(sv);
833 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
837 else sv_setsv_nomg(sv, NULL);
840 case '\017': /* ^O & ^OPEN */
841 if (nextchar == '\0') {
842 sv_setpv(sv, PL_osname);
845 else if (strEQ(remaining, "PEN")) {
846 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
850 if (nextchar == '\0') { /* ^P */
851 sv_setiv(sv, (IV)PL_perldb);
852 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
854 paren = RX_BUFF_IDX_CARET_PREMATCH;
855 goto do_numbuf_fetch;
856 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
857 paren = RX_BUFF_IDX_CARET_POSTMATCH;
858 goto do_numbuf_fetch;
861 case '\023': /* ^S */
862 if (nextchar == '\0') {
863 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
866 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
871 case '\024': /* ^T */
872 if (nextchar == '\0') {
874 sv_setnv(sv, PL_basetime);
876 sv_setiv(sv, (IV)PL_basetime);
879 else if (strEQ(remaining, "AINT"))
880 sv_setiv(sv, TAINTING_get
881 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
884 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
885 if (strEQ(remaining, "NICODE"))
886 sv_setuv(sv, (UV) PL_unicode);
887 else if (strEQ(remaining, "TF8LOCALE"))
888 sv_setuv(sv, (UV) PL_utf8locale);
889 else if (strEQ(remaining, "TF8CACHE"))
890 sv_setiv(sv, (IV) PL_utf8cache);
892 case '\027': /* ^W & $^WARNING_BITS */
893 if (nextchar == '\0')
894 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
895 else if (strEQ(remaining, "ARNING_BITS")) {
896 if (PL_compiling.cop_warnings == pWARN_NONE) {
897 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
899 else if (PL_compiling.cop_warnings == pWARN_STD) {
900 sv_setsv(sv, &PL_sv_undef);
903 else if (PL_compiling.cop_warnings == pWARN_ALL) {
904 /* Get the bit mask for $warnings::Bits{all}, because
905 * it could have been extended by warnings::register */
906 HV * const bits = get_hv("warnings::Bits", 0);
907 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
909 sv_copypv(sv, *bits_all);
911 sv_setpvn(sv, WARN_ALLstring, WARNsize);
914 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
915 *PL_compiling.cop_warnings);
919 case '\015': /* $^MATCH */
920 if (strEQ(remaining, "ATCH")) {
921 paren = RX_BUFF_IDX_CARET_FULLMATCH;
922 goto do_numbuf_fetch;
925 case '1': case '2': case '3': case '4':
926 case '5': case '6': case '7': case '8': case '9': case '&':
928 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
929 * XXX Does the new way break anything?
931 paren = atoi(mg->mg_ptr); /* $& is in [0] */
933 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
934 CALLREG_NUMBUF_FETCH(rx,paren,sv);
937 sv_setsv(sv,&PL_sv_undef);
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 paren = RX_BUFF_IDX_PREMATCH;
957 goto do_numbuf_fetch;
959 paren = RX_BUFF_IDX_POSTMATCH;
960 goto do_numbuf_fetch;
962 if (GvIO(PL_last_in_gv)) {
963 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
968 sv_setiv(sv, (IV)STATUS_CURRENT);
969 #ifdef COMPLEX_STATUS
970 SvUPGRADE(sv, SVt_PVLV);
971 LvTARGOFF(sv) = PL_statusvalue;
972 LvTARGLEN(sv) = PL_statusvalue_vms;
977 if (GvIOp(PL_defoutgv))
978 s = IoTOP_NAME(GvIOp(PL_defoutgv));
982 sv_setpv(sv,GvENAME(PL_defoutgv));
983 sv_catpvs(sv,"_TOP");
987 if (GvIOp(PL_defoutgv))
988 s = IoFMT_NAME(GvIOp(PL_defoutgv));
990 s = GvENAME(PL_defoutgv);
994 if (GvIO(PL_defoutgv))
995 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
998 if (GvIO(PL_defoutgv))
999 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1002 if (GvIO(PL_defoutgv))
1003 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1013 if (GvIO(PL_defoutgv))
1014 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1018 sv_copypv(sv, PL_ors_sv);
1020 sv_setsv(sv, &PL_sv_undef);
1024 IV const pid = (IV)PerlProc_getpid();
1025 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1026 /* never set manually, or at least not since last fork */
1028 /* never unsafe, even if reading in a tainted expression */
1031 /* else a value has been assigned manually, so do nothing */
1039 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1041 sv_setnv(sv, (NV)errno);
1044 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1045 sv_setpv(sv, os2error(Perl_rc));
1048 sv_setpv(sv, errno ? Strerror(errno) : "");
1053 SvNOK_on(sv); /* what a wonderful hack! */
1056 sv_setiv(sv, (IV)PerlProc_getuid());
1059 sv_setiv(sv, (IV)PerlProc_geteuid());
1062 sv_setiv(sv, (IV)PerlProc_getgid());
1065 sv_setiv(sv, (IV)PerlProc_getegid());
1067 #ifdef HAS_GETGROUPS
1069 Groups_t *gary = NULL;
1070 I32 i, num_groups = getgroups(0, gary);
1071 Newx(gary, num_groups, Groups_t);
1072 num_groups = getgroups(num_groups, gary);
1073 for (i = 0; i < num_groups; i++)
1074 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1077 (void)SvIOK_on(sv); /* what a wonderful hack! */
1087 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1089 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1091 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1093 if (uf && uf->uf_val)
1094 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1099 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1102 STRLEN len = 0, klen;
1103 const char * const key = MgPV_const(mg,klen);
1104 const char *s = NULL;
1106 PERL_ARGS_ASSERT_MAGIC_SETENV;
1110 /* defined environment variables are byte strings; unfortunately
1111 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1112 (void)SvPV_force_nomg_nolen(sv);
1113 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1115 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1121 my_setenv(key, s); /* does the deed */
1123 #ifdef DYNAMIC_ENV_FETCH
1124 /* We just undefd an environment var. Is a replacement */
1125 /* waiting in the wings? */
1127 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1129 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1133 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1134 /* And you'll never guess what the dog had */
1135 /* in its mouth... */
1137 MgTAINTEDDIR_off(mg);
1139 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1140 char pathbuf[256], eltbuf[256], *cp, *elt;
1143 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1145 do { /* DCL$PATH may be a search list */
1146 while (1) { /* as may dev portion of any element */
1147 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1148 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1149 cando_by_name(S_IWUSR,0,elt) ) {
1150 MgTAINTEDDIR_on(mg);
1154 if ((cp = strchr(elt, ':')) != NULL)
1156 if (my_trnlnm(elt, eltbuf, j++))
1162 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1165 if (s && klen == 4 && strEQ(key,"PATH")) {
1166 const char * const strend = s + len;
1168 while (s < strend) {
1172 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1173 const char path_sep = '|';
1175 const char path_sep = ':';
1177 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1178 s, strend, path_sep, &i);
1180 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1182 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1184 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1186 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1187 MgTAINTEDDIR_on(mg);
1193 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1199 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1201 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1202 PERL_UNUSED_ARG(sv);
1203 my_setenv(MgPV_nolen_const(mg),NULL);
1208 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1211 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1212 PERL_UNUSED_ARG(mg);
1214 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1216 if (PL_localizing) {
1219 hv_iterinit(MUTABLE_HV(sv));
1220 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1222 my_setenv(hv_iterkey(entry, &keylen),
1223 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1231 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1234 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1235 PERL_UNUSED_ARG(sv);
1236 PERL_UNUSED_ARG(mg);
1238 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1246 #ifdef HAS_SIGPROCMASK
1248 restore_sigmask(pTHX_ SV *save_sv)
1250 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1251 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1255 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1258 /* Are we fetching a signal entry? */
1259 int i = (I16)mg->mg_private;
1261 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1265 const char * sig = MgPV_const(mg, siglen);
1266 mg->mg_private = i = whichsig_pvn(sig, siglen);
1271 sv_setsv(sv,PL_psig_ptr[i]);
1273 Sighandler_t sigstate = rsignal_state(i);
1274 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1275 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1278 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1279 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1282 /* cache state so we don't fetch it again */
1283 if(sigstate == (Sighandler_t) SIG_IGN)
1284 sv_setpvs(sv,"IGNORE");
1286 sv_setsv(sv,&PL_sv_undef);
1287 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1294 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1296 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1298 magic_setsig(NULL, mg);
1299 return sv_unmagic(sv, mg->mg_type);
1303 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1304 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1306 Perl_csighandler(int sig)
1309 #ifdef PERL_GET_SIG_CONTEXT
1310 dTHXa(PERL_GET_SIG_CONTEXT);
1314 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1315 (void) rsignal(sig, PL_csighandlerp);
1316 if (PL_sig_ignoring[sig]) return;
1318 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319 if (PL_sig_defaulting[sig])
1320 #ifdef KILL_BY_SIGPRC
1321 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1336 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1337 /* Call the perl level handler now--
1338 * with risk we may be in malloc() or being destructed etc. */
1339 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1340 (*PL_sighandlerp)(sig, NULL, NULL);
1342 (*PL_sighandlerp)(sig);
1345 if (!PL_psig_pend) return;
1346 /* Set a flag to say this signal is pending, that is awaiting delivery after
1347 * the current Perl opcode completes */
1348 PL_psig_pend[sig]++;
1350 #ifndef SIG_PENDING_DIE_COUNT
1351 # define SIG_PENDING_DIE_COUNT 120
1353 /* Add one to say _a_ signal is pending */
1354 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1355 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1356 (unsigned long)SIG_PENDING_DIE_COUNT);
1360 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1362 Perl_csighandler_init(void)
1365 if (PL_sig_handlers_initted) return;
1367 for (sig = 1; sig < SIG_SIZE; sig++) {
1368 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1370 PL_sig_defaulting[sig] = 1;
1371 (void) rsignal(sig, PL_csighandlerp);
1373 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1374 PL_sig_ignoring[sig] = 0;
1377 PL_sig_handlers_initted = 1;
1381 #if defined HAS_SIGPROCMASK
1383 unblock_sigmask(pTHX_ void* newset)
1385 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1390 Perl_despatch_signals(pTHX)
1395 for (sig = 1; sig < SIG_SIZE; sig++) {
1396 if (PL_psig_pend[sig]) {
1398 #ifdef HAS_SIGPROCMASK
1399 /* From sigaction(2) (FreeBSD man page):
1400 * | Signal routines normally execute with the signal that
1401 * | caused their invocation blocked, but other signals may
1403 * Emulation of this behavior (from within Perl) is enabled
1407 sigset_t newset, oldset;
1409 sigemptyset(&newset);
1410 sigaddset(&newset, sig);
1411 sigprocmask(SIG_BLOCK, &newset, &oldset);
1412 was_blocked = sigismember(&oldset, sig);
1414 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1416 SAVEFREESV(save_sv);
1417 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1420 PL_psig_pend[sig] = 0;
1421 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1422 (*PL_sighandlerp)(sig, NULL, NULL);
1424 (*PL_sighandlerp)(sig);
1426 #ifdef HAS_SIGPROCMASK
1435 /* sv of NULL signifies that we're acting as magic_clearsig. */
1437 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1442 /* Need to be careful with SvREFCNT_dec(), because that can have side
1443 * effects (due to closures). We must make sure that the new disposition
1444 * is in place before it is called.
1448 #ifdef HAS_SIGPROCMASK
1452 const char *s = MgPV_const(mg,len);
1454 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1457 if (memEQs(s, len, "__DIE__"))
1459 else if (memEQs(s, len, "__WARN__")
1460 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1461 /* Merge the existing behaviours, which are as follows:
1462 magic_setsig, we always set svp to &PL_warnhook
1463 (hence we always change the warnings handler)
1464 For magic_clearsig, we don't change the warnings handler if it's
1465 set to the &PL_warnhook. */
1468 SV *tmp = sv_newmortal();
1469 Perl_croak(aTHX_ "No such hook: %s",
1470 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1474 if (*svp != PERL_WARNHOOK_FATAL)
1480 i = (I16)mg->mg_private;
1482 i = whichsig_pvn(s, len); /* ...no, a brick */
1483 mg->mg_private = (U16)i;
1487 SV *tmp = sv_newmortal();
1488 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1489 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1493 #ifdef HAS_SIGPROCMASK
1494 /* Avoid having the signal arrive at a bad time, if possible. */
1497 sigprocmask(SIG_BLOCK, &set, &save);
1499 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1500 SAVEFREESV(save_sv);
1501 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1504 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1505 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1507 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1508 PL_sig_ignoring[i] = 0;
1510 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1511 PL_sig_defaulting[i] = 0;
1513 to_dec = PL_psig_ptr[i];
1515 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1516 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1518 /* Signals don't change name during the program's execution, so once
1519 they're cached in the appropriate slot of PL_psig_name, they can
1522 Ideally we'd find some way of making SVs at (C) compile time, or
1523 at least, doing most of the work. */
1524 if (!PL_psig_name[i]) {
1525 PL_psig_name[i] = newSVpvn(s, len);
1526 SvREADONLY_on(PL_psig_name[i]);
1529 SvREFCNT_dec(PL_psig_name[i]);
1530 PL_psig_name[i] = NULL;
1531 PL_psig_ptr[i] = NULL;
1534 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1536 (void)rsignal(i, PL_csighandlerp);
1539 *svp = SvREFCNT_inc_simple_NN(sv);
1541 if (sv && SvOK(sv)) {
1542 s = SvPV_force(sv, len);
1546 if (sv && memEQs(s, len,"IGNORE")) {
1548 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1549 PL_sig_ignoring[i] = 1;
1550 (void)rsignal(i, PL_csighandlerp);
1552 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1556 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1558 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1559 PL_sig_defaulting[i] = 1;
1560 (void)rsignal(i, PL_csighandlerp);
1562 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1568 * We should warn if HINT_STRICT_REFS, but without
1569 * access to a known hint bit in a known OP, we can't
1570 * tell whether HINT_STRICT_REFS is in force or not.
1572 if (!strchr(s,':') && !strchr(s,'\''))
1573 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1576 (void)rsignal(i, PL_csighandlerp);
1578 *svp = SvREFCNT_inc_simple_NN(sv);
1582 #ifdef HAS_SIGPROCMASK
1586 SvREFCNT_dec(to_dec);
1589 #endif /* !PERL_MICRO */
1592 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1595 PERL_ARGS_ASSERT_MAGIC_SETISA;
1596 PERL_UNUSED_ARG(sv);
1598 /* Skip _isaelem because _isa will handle it shortly */
1599 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1602 return magic_clearisa(NULL, mg);
1605 /* sv of NULL signifies that we're acting as magic_setisa. */
1607 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1612 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1614 /* Bail out if destruction is going on */
1615 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1618 av_clear(MUTABLE_AV(sv));
1620 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1621 /* This occurs with setisa_elem magic, which calls this
1623 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1625 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1626 SV **svp = AvARRAY((AV *)mg->mg_obj);
1627 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1629 stash = GvSTASH((GV *)*svp++);
1630 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1637 (const GV *)mg->mg_obj
1640 /* The stash may have been detached from the symbol table, so check its
1641 name before doing anything. */
1642 if (stash && HvENAME_get(stash))
1643 mro_isa_changed_in(stash);
1649 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1651 HV * const hv = MUTABLE_HV(LvTARG(sv));
1654 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1655 PERL_UNUSED_ARG(mg);
1658 (void) hv_iterinit(hv);
1659 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1662 while (hv_iternext(hv))
1667 sv_setiv(sv, (IV)i);
1672 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1674 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1675 PERL_UNUSED_ARG(mg);
1677 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1683 =for apidoc magic_methcall
1685 Invoke a magic method (like FETCH).
1687 C<sv> and C<mg> are the tied thingy and the tie magic.
1689 C<meth> is the name of the method to call.
1691 C<argc> is the number of args (in addition to $self) to pass to the method.
1693 The C<flags> can be:
1695 G_DISCARD invoke method with G_DISCARD flag and don't
1697 G_UNDEF_FILL fill the stack with argc pointers to
1700 The arguments themselves are any values following the C<flags> argument.
1702 Returns the SV (if any) returned by the method, or NULL on failure.
1709 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1716 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1720 if (flags & G_WRITING_TO_STDERR) {
1724 SAVESPTR(PL_stderrgv);
1728 PUSHSTACKi(PERLSI_MAGIC);
1732 PUSHs(SvTIED_obj(sv, mg));
1733 if (flags & G_UNDEF_FILL) {
1735 PUSHs(&PL_sv_undef);
1737 } else if (argc > 0) {
1739 va_start(args, argc);
1742 SV *const sv = va_arg(args, SV *);
1749 if (flags & G_DISCARD) {
1750 call_method(meth, G_SCALAR|G_DISCARD);
1753 if (call_method(meth, G_SCALAR))
1754 ret = *PL_stack_sp--;
1757 if (flags & G_WRITING_TO_STDERR)
1764 /* wrapper for magic_methcall that creates the first arg */
1767 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1773 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1776 if (mg->mg_len >= 0) {
1777 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1779 else if (mg->mg_len == HEf_SVKEY)
1780 arg1 = MUTABLE_SV(mg->mg_ptr);
1782 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1783 arg1 = newSViv((IV)(mg->mg_len));
1787 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1789 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1793 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1798 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1800 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1807 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1809 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1811 if (mg->mg_type == PERL_MAGIC_tiedelem)
1812 mg->mg_flags |= MGf_GSKIP;
1813 magic_methpack(sv,mg,"FETCH");
1818 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1824 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1826 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1827 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1828 * public flags indicate its value based on copying from $val. Doing
1829 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1830 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1831 * wrong if $val happened to be tainted, as sv hasn't got magic
1832 * enabled, even though taint magic is in the chain. In which case,
1833 * fake up a temporary tainted value (this is easier than temporarily
1834 * re-enabling magic on sv). */
1836 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1837 && (tmg->mg_len & 1))
1839 val = sv_mortalcopy(sv);
1845 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1850 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1852 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1854 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1855 return magic_methpack(sv,mg,"DELETE");
1860 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1866 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1868 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1870 retval = SvIV(retsv)-1;
1872 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1874 return (U32) retval;
1878 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1882 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1884 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1889 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1894 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1896 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1897 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1904 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1906 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1908 return magic_methpack(sv,mg,"EXISTS");
1912 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1916 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1917 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1919 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1921 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1923 if (HvEITER_get(hv))
1924 /* we are in an iteration so the hash cannot be empty */
1926 /* no xhv_eiter so now use FIRSTKEY */
1927 key = sv_newmortal();
1928 magic_nextpack(MUTABLE_SV(hv), mg, key);
1929 HvEITER_set(hv, NULL); /* need to reset iterator */
1930 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1933 /* there is a SCALAR method that we can call */
1934 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1936 retval = &PL_sv_undef;
1941 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1944 GV * const gv = PL_DBline;
1945 const I32 i = SvTRUE(sv);
1946 SV ** const svp = av_fetch(GvAV(gv),
1947 atoi(MgPV_nolen_const(mg)), FALSE);
1949 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1951 if (svp && SvIOKp(*svp)) {
1952 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1954 #ifdef PERL_DEBUG_READONLY_OPS
1955 Slab_to_rw(OpSLAB(o));
1957 /* set or clear breakpoint in the relevant control op */
1959 o->op_flags |= OPf_SPECIAL;
1961 o->op_flags &= ~OPf_SPECIAL;
1962 #ifdef PERL_DEBUG_READONLY_OPS
1963 Slab_to_ro(OpSLAB(o));
1971 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1974 AV * const obj = MUTABLE_AV(mg->mg_obj);
1976 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1979 sv_setiv(sv, AvFILL(obj));
1987 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1990 AV * const obj = MUTABLE_AV(mg->mg_obj);
1992 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1995 av_fill(obj, SvIV(sv));
1997 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1998 "Attempt to set length of freed array");
2004 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2008 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2009 PERL_UNUSED_ARG(sv);
2011 /* Reset the iterator when the array is cleared */
2012 #if IVSIZE == I32SIZE
2013 *((IV *) &(mg->mg_len)) = 0;
2016 *((IV *) mg->mg_ptr) = 0;
2023 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2027 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2028 PERL_UNUSED_ARG(sv);
2030 /* during global destruction, mg_obj may already have been freed */
2031 if (PL_in_clean_all)
2034 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2037 /* arylen scalar holds a pointer back to the array, but doesn't own a
2038 reference. Hence the we (the array) are about to go away with it
2039 still pointing at us. Clear its pointer, else it would be pointing
2040 at free memory. See the comment in sv_magic about reference loops,
2041 and why it can't own a reference to us. */
2048 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2051 SV* const lsv = LvTARG(sv);
2053 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2054 PERL_UNUSED_ARG(mg);
2056 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2057 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2058 if (found && found->mg_len >= 0) {
2059 I32 i = found->mg_len;
2061 sv_pos_b2u(lsv, &i);
2071 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2074 SV* const lsv = LvTARG(sv);
2081 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2082 PERL_UNUSED_ARG(mg);
2084 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2085 found = mg_find(lsv, PERL_MAGIC_regex_global);
2091 #ifdef PERL_OLD_COPY_ON_WRITE
2093 sv_force_normal_flags(lsv, 0);
2095 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2098 else if (!SvOK(sv)) {
2102 s = SvPV_const(lsv, len);
2107 ulen = sv_or_pv_len_utf8(lsv, s, len);
2117 else if (pos > (SSize_t)len)
2121 pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
2124 found->mg_len = pos;
2125 found->mg_flags &= ~MGf_MINMATCH;
2131 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2134 SV * const lsv = LvTARG(sv);
2135 const char * const tmps = SvPV_const(lsv,len);
2136 STRLEN offs = LvTARGOFF(sv);
2137 STRLEN rem = LvTARGLEN(sv);
2138 const bool negoff = LvFLAGS(sv) & 1;
2139 const bool negrem = LvFLAGS(sv) & 2;
2141 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2142 PERL_UNUSED_ARG(mg);
2144 if (!translate_substr_offsets(
2145 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2146 negoff ? -(IV)offs : (IV)offs, !negoff,
2147 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2149 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2150 sv_setsv_nomg(sv, &PL_sv_undef);
2155 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2156 sv_setpvn(sv, tmps + offs, rem);
2163 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2166 STRLEN len, lsv_len, oldtarglen, newtarglen;
2167 const char * const tmps = SvPV_const(sv, len);
2168 SV * const lsv = LvTARG(sv);
2169 STRLEN lvoff = LvTARGOFF(sv);
2170 STRLEN lvlen = LvTARGLEN(sv);
2171 const bool negoff = LvFLAGS(sv) & 1;
2172 const bool neglen = LvFLAGS(sv) & 2;
2174 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2175 PERL_UNUSED_ARG(mg);
2179 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2180 "Attempt to use reference as lvalue in substr"
2182 SvPV_force_nomg(lsv,lsv_len);
2183 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2184 if (!translate_substr_offsets(
2186 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2187 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2189 Perl_croak(aTHX_ "substr outside of string");
2192 sv_utf8_upgrade_nomg(lsv);
2193 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2194 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2195 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2198 else if (SvUTF8(lsv)) {
2200 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2202 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2203 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2207 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2210 if (!neglen) LvTARGLEN(sv) = newtarglen;
2211 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2217 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2221 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2222 PERL_UNUSED_ARG(sv);
2224 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2229 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2233 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2234 PERL_UNUSED_ARG(sv);
2236 /* update taint status */
2245 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2247 SV * const lsv = LvTARG(sv);
2249 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2250 PERL_UNUSED_ARG(mg);
2253 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2261 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2263 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2264 PERL_UNUSED_ARG(mg);
2265 do_vecset(sv); /* XXX slurp this routine */
2270 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2275 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2277 if (LvTARGLEN(sv)) {
2279 SV * const ahv = LvTARG(sv);
2280 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2285 AV *const av = MUTABLE_AV(LvTARG(sv));
2286 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2287 targ = AvARRAY(av)[LvTARGOFF(sv)];
2289 if (targ && (targ != &PL_sv_undef)) {
2290 /* somebody else defined it for us */
2291 SvREFCNT_dec(LvTARG(sv));
2292 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2294 SvREFCNT_dec(mg->mg_obj);
2296 mg->mg_flags &= ~MGf_REFCOUNTED;
2301 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2306 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2308 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2309 PERL_UNUSED_ARG(mg);
2313 sv_setsv(LvTARG(sv), sv);
2314 SvSETMAGIC(LvTARG(sv));
2320 Perl_vivify_defelem(pTHX_ SV *sv)
2326 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2328 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2331 SV * const ahv = LvTARG(sv);
2332 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2335 if (!value || value == &PL_sv_undef)
2336 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2339 AV *const av = MUTABLE_AV(LvTARG(sv));
2340 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2341 LvTARG(sv) = NULL; /* array can't be extended */
2343 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2344 if (!svp || (value = *svp) == &PL_sv_undef)
2345 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2348 SvREFCNT_inc_simple_void(value);
2349 SvREFCNT_dec(LvTARG(sv));
2352 SvREFCNT_dec(mg->mg_obj);
2354 mg->mg_flags &= ~MGf_REFCOUNTED;
2358 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2360 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2361 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2366 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2368 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2369 PERL_UNUSED_CONTEXT;
2370 PERL_UNUSED_ARG(sv);
2376 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2378 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2380 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2382 if (uf && uf->uf_set)
2383 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2388 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2390 const char type = mg->mg_type;
2392 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2394 if (type == PERL_MAGIC_qr) {
2395 } else if (type == PERL_MAGIC_bm) {
2399 assert(type == PERL_MAGIC_fm);
2401 return sv_unmagic(sv, type);
2404 #ifdef USE_LOCALE_COLLATE
2406 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2408 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2411 * RenE<eacute> Descartes said "I think not."
2412 * and vanished with a faint plop.
2414 PERL_UNUSED_CONTEXT;
2415 PERL_UNUSED_ARG(sv);
2417 Safefree(mg->mg_ptr);
2423 #endif /* USE_LOCALE_COLLATE */
2425 /* Just clear the UTF-8 cache data. */
2427 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2429 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2430 PERL_UNUSED_CONTEXT;
2431 PERL_UNUSED_ARG(sv);
2432 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2434 mg->mg_len = -1; /* The mg_len holds the len cache. */
2439 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2445 const char * const remaining = mg->mg_ptr + 1;
2450 PERL_ARGS_ASSERT_MAGIC_SET;
2452 switch (*mg->mg_ptr) {
2453 case '\015': /* $^MATCH */
2454 if (strEQ(remaining, "ATCH"))
2456 case '`': /* ${^PREMATCH} caught below */
2458 paren = RX_BUFF_IDX_PREMATCH;
2460 case '\'': /* ${^POSTMATCH} caught below */
2462 paren = RX_BUFF_IDX_POSTMATCH;
2466 paren = RX_BUFF_IDX_FULLMATCH;
2468 case '1': case '2': case '3': case '4':
2469 case '5': case '6': case '7': case '8': case '9':
2470 paren = atoi(mg->mg_ptr);
2472 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2474 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2476 /* Croak with a READONLY error when a numbered match var is
2477 * set without a previous pattern match. Unless it's C<local $1>
2480 if (!PL_localizing) {
2481 Perl_croak_no_modify();
2485 case '\001': /* ^A */
2486 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2487 else SvOK_off(PL_bodytarget);
2488 FmLINES(PL_bodytarget) = 0;
2489 if (SvPOK(PL_bodytarget)) {
2490 char *s = SvPVX(PL_bodytarget);
2491 while ( ((s = strchr(s, '\n'))) ) {
2492 FmLINES(PL_bodytarget)++;
2496 /* mg_set() has temporarily made sv non-magical */
2498 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2499 SvTAINTED_on(PL_bodytarget);
2501 SvTAINTED_off(PL_bodytarget);
2504 case '\003': /* ^C */
2505 PL_minus_c = cBOOL(SvIV(sv));
2508 case '\004': /* ^D */
2510 s = SvPV_nolen_const(sv);
2511 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2512 if (DEBUG_x_TEST || DEBUG_B_TEST)
2513 dump_all_perl(!DEBUG_B_TEST);
2515 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2518 case '\005': /* ^E */
2519 if (*(mg->mg_ptr+1) == '\0') {
2521 set_vaxc_errno(SvIV(sv));
2524 SetLastError( SvIV(sv) );
2527 os2_setsyserrno(SvIV(sv));
2529 /* will anyone ever use this? */
2530 SETERRNO(SvIV(sv), 4);
2535 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2536 SvREFCNT_dec(PL_encoding);
2537 if (SvOK(sv) || SvGMAGICAL(sv)) {
2538 PL_encoding = newSVsv(sv);
2545 case '\006': /* ^F */
2546 PL_maxsysfd = SvIV(sv);
2548 case '\010': /* ^H */
2549 PL_hints = SvIV(sv);
2551 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2552 Safefree(PL_inplace);
2553 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2555 case '\016': /* ^N */
2556 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2557 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2559 case '\017': /* ^O */
2560 if (*(mg->mg_ptr+1) == '\0') {
2561 Safefree(PL_osname);
2564 TAINT_PROPER("assigning to $^O");
2565 PL_osname = savesvpv(sv);
2568 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2570 const char *const start = SvPV(sv, len);
2571 const char *out = (const char*)memchr(start, '\0', len);
2575 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2576 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2578 /* Opening for input is more common than opening for output, so
2579 ensure that hints for input are sooner on linked list. */
2580 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2582 : newSVpvs_flags("", SvUTF8(sv));
2583 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2586 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2588 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2592 case '\020': /* ^P */
2593 if (*remaining == '\0') { /* ^P */
2594 PL_perldb = SvIV(sv);
2595 if (PL_perldb && !PL_DBsingle)
2598 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2600 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2604 case '\024': /* ^T */
2606 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2608 PL_basetime = (Time_t)SvIV(sv);
2611 case '\025': /* ^UTF8CACHE */
2612 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2613 PL_utf8cache = (signed char) sv_2iv(sv);
2616 case '\027': /* ^W & $^WARNING_BITS */
2617 if (*(mg->mg_ptr+1) == '\0') {
2618 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2620 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2621 | (i ? G_WARN_ON : G_WARN_OFF) ;
2624 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2625 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2627 PL_compiling.cop_warnings = pWARN_STD;
2632 int accumulate = 0 ;
2633 int any_fatals = 0 ;
2634 const char * const ptr = SvPV_const(sv, len) ;
2635 for (i = 0 ; i < len ; ++i) {
2636 accumulate |= ptr[i] ;
2637 any_fatals |= (ptr[i] & 0xAA) ;
2640 if (!specialWARN(PL_compiling.cop_warnings))
2641 PerlMemShared_free(PL_compiling.cop_warnings);
2642 PL_compiling.cop_warnings = pWARN_NONE;
2644 /* Yuck. I can't see how to abstract this: */
2645 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2646 WARN_ALL) && !any_fatals) {
2647 if (!specialWARN(PL_compiling.cop_warnings))
2648 PerlMemShared_free(PL_compiling.cop_warnings);
2649 PL_compiling.cop_warnings = pWARN_ALL;
2650 PL_dowarn |= G_WARN_ONCE ;
2654 const char *const p = SvPV_const(sv, len);
2656 PL_compiling.cop_warnings
2657 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2660 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2661 PL_dowarn |= G_WARN_ONCE ;
2669 if (PL_localizing) {
2670 if (PL_localizing == 1)
2671 SAVESPTR(PL_last_in_gv);
2673 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2674 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2677 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2678 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2679 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2682 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2683 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2684 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2687 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2690 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2691 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2692 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2695 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2699 IO * const io = GvIO(PL_defoutgv);
2702 if ((SvIV(sv)) == 0)
2703 IoFLAGS(io) &= ~IOf_FLUSH;
2705 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2706 PerlIO *ofp = IoOFP(io);
2708 (void)PerlIO_flush(ofp);
2709 IoFLAGS(io) |= IOf_FLUSH;
2715 SvREFCNT_dec(PL_rs);
2716 PL_rs = newSVsv(sv);
2719 SvREFCNT_dec(PL_ors_sv);
2721 PL_ors_sv = newSVsv(sv);
2729 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2732 #ifdef COMPLEX_STATUS
2733 if (PL_localizing == 2) {
2734 SvUPGRADE(sv, SVt_PVLV);
2735 PL_statusvalue = LvTARGOFF(sv);
2736 PL_statusvalue_vms = LvTARGLEN(sv);
2740 #ifdef VMSISH_STATUS
2742 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2745 STATUS_UNIX_EXIT_SET(SvIV(sv));
2750 # define PERL_VMS_BANG vaxc$errno
2752 # define PERL_VMS_BANG 0
2754 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2755 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2760 const IV new_uid = SvIV(sv);
2761 PL_delaymagic_uid = new_uid;
2762 if (PL_delaymagic) {
2763 PL_delaymagic |= DM_RUID;
2764 break; /* don't do magic till later */
2767 (void)setruid((Uid_t)new_uid);
2770 (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2772 #ifdef HAS_SETRESUID
2773 (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2775 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2777 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2778 if (new_uid != 0 && PerlProc_getuid() == 0)
2779 (void)PerlProc_setuid(0);
2781 (void)PerlProc_setuid(new_uid);
2783 Perl_croak(aTHX_ "setruid() not implemented");
2792 const UV new_euid = SvIV(sv);
2793 PL_delaymagic_euid = new_euid;
2794 if (PL_delaymagic) {
2795 PL_delaymagic |= DM_EUID;
2796 break; /* don't do magic till later */
2799 (void)seteuid((Uid_t)new_euid);
2802 (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2804 #ifdef HAS_SETRESUID
2805 (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2807 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2808 PerlProc_setuid(new_euid);
2810 Perl_croak(aTHX_ "seteuid() not implemented");
2819 const UV new_gid = SvIV(sv);
2820 PL_delaymagic_gid = new_gid;
2821 if (PL_delaymagic) {
2822 PL_delaymagic |= DM_RGID;
2823 break; /* don't do magic till later */
2826 (void)setrgid((Gid_t)new_gid);
2829 (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2831 #ifdef HAS_SETRESGID
2832 (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2834 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2835 (void)PerlProc_setgid(new_gid);
2837 Perl_croak(aTHX_ "setrgid() not implemented");
2847 #ifdef HAS_SETGROUPS
2849 const char *p = SvPV_const(sv, len);
2850 Groups_t *gary = NULL;
2851 #ifdef _SC_NGROUPS_MAX
2852 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2857 int maxgrp = NGROUPS;
2863 for (i = 0; i < maxgrp; ++i) {
2864 while (*p && !isSPACE(*p))
2871 Newx(gary, i + 1, Groups_t);
2873 Renew(gary, i + 1, Groups_t);
2877 (void)setgroups(i, gary);
2880 #else /* HAS_SETGROUPS */
2881 new_egid = SvIV(sv);
2882 #endif /* HAS_SETGROUPS */
2883 PL_delaymagic_egid = new_egid;
2884 if (PL_delaymagic) {
2885 PL_delaymagic |= DM_EGID;
2886 break; /* don't do magic till later */
2889 (void)setegid((Gid_t)new_egid);
2892 (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2894 #ifdef HAS_SETRESGID
2895 (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2897 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2898 (void)PerlProc_setgid(new_egid);
2900 Perl_croak(aTHX_ "setegid() not implemented");
2908 PL_chopset = SvPV_force(sv,len);
2911 /* Store the pid in mg->mg_obj so we can tell when a fork has
2912 occurred. mg->mg_obj points to *$ by default, so clear it. */
2913 if (isGV(mg->mg_obj)) {
2914 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2915 SvREFCNT_dec(mg->mg_obj);
2916 mg->mg_flags |= MGf_REFCOUNTED;
2917 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2919 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2922 LOCK_DOLLARZERO_MUTEX;
2923 #ifdef HAS_SETPROCTITLE
2924 /* The BSDs don't show the argv[] in ps(1) output, they
2925 * show a string from the process struct and provide
2926 * the setproctitle() routine to manipulate that. */
2927 if (PL_origalen != 1) {
2928 s = SvPV_const(sv, len);
2929 # if __FreeBSD_version > 410001
2930 /* The leading "-" removes the "perl: " prefix,
2931 * but not the "(perl) suffix from the ps(1)
2932 * output, because that's what ps(1) shows if the
2933 * argv[] is modified. */
2934 setproctitle("-%s", s);
2935 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2936 /* This doesn't really work if you assume that
2937 * $0 = 'foobar'; will wipe out 'perl' from the $0
2938 * because in ps(1) output the result will be like
2939 * sprintf("perl: %s (perl)", s)
2940 * I guess this is a security feature:
2941 * one (a user process) cannot get rid of the original name.
2943 setproctitle("%s", s);
2946 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2947 if (PL_origalen != 1) {
2949 s = SvPV_const(sv, len);
2950 un.pst_command = (char *)s;
2951 pstat(PSTAT_SETCMD, un, len, 0, 0);
2954 if (PL_origalen > 1) {
2955 /* PL_origalen is set in perl_parse(). */
2956 s = SvPV_force(sv,len);
2957 if (len >= (STRLEN)PL_origalen-1) {
2958 /* Longer than original, will be truncated. We assume that
2959 * PL_origalen bytes are available. */
2960 Copy(s, PL_origargv[0], PL_origalen-1, char);
2963 /* Shorter than original, will be padded. */
2965 /* Special case for Mac OS X: see [perl #38868] */
2968 /* Is the space counterintuitive? Yes.
2969 * (You were expecting \0?)
2970 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2972 const int pad = ' ';
2974 Copy(s, PL_origargv[0], len, char);
2975 PL_origargv[0][len] = 0;
2976 memset(PL_origargv[0] + len + 1,
2977 pad, PL_origalen - len - 1);
2979 PL_origargv[0][PL_origalen-1] = 0;
2980 for (i = 1; i < PL_origargc; i++)
2982 #ifdef HAS_PRCTL_SET_NAME
2983 /* Set the legacy process name in addition to the POSIX name on Linux */
2984 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2985 /* diag_listed_as: SKIPME */
2986 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2991 UNLOCK_DOLLARZERO_MUTEX;
2998 Perl_whichsig_sv(pTHX_ SV *sigsv)
3002 PERL_ARGS_ASSERT_WHICHSIG_SV;
3003 PERL_UNUSED_CONTEXT;
3004 sigpv = SvPV_const(sigsv, siglen);
3005 return whichsig_pvn(sigpv, siglen);
3009 Perl_whichsig_pv(pTHX_ const char *sig)
3011 PERL_ARGS_ASSERT_WHICHSIG_PV;
3012 PERL_UNUSED_CONTEXT;
3013 return whichsig_pvn(sig, strlen(sig));
3017 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3021 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3022 PERL_UNUSED_CONTEXT;
3024 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3025 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3026 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3028 if (memEQs(sig, len, "CHLD"))
3032 if (memEQs(sig, len, "CLD"))
3039 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3040 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3042 Perl_sighandler(int sig)
3045 #ifdef PERL_GET_SIG_CONTEXT
3046 dTHXa(PERL_GET_SIG_CONTEXT);
3053 SV * const tSv = PL_Sv;
3057 XPV * const tXpv = PL_Xpv;
3058 I32 old_ss_ix = PL_savestack_ix;
3059 SV *errsv_save = NULL;
3062 if (!PL_psig_ptr[sig]) {
3063 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3068 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3069 /* Max number of items pushed there is 3*n or 4. We cannot fix
3070 infinity, so we fix 4 (in fact 5): */
3071 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3073 PL_savestack_ix += 5; /* Protect save in progress. */
3074 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3077 /* sv_2cv is too complicated, try a simpler variant first: */
3078 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3079 || SvTYPE(cv) != SVt_PVCV) {
3081 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3084 if (!cv || !CvROOT(cv)) {
3085 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3086 PL_sig_name[sig], (gv ? GvENAME(gv)
3093 sv = PL_psig_name[sig]
3094 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3095 : newSVpv(PL_sig_name[sig],0);
3099 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3100 /* make sure our assumption about the size of the SAVEs are correct:
3101 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3102 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3105 PUSHSTACKi(PERLSI_SIGNAL);
3108 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3110 struct sigaction oact;
3112 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3115 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3116 /* The siginfo fields signo, code, errno, pid, uid,
3117 * addr, status, and band are defined by POSIX/SUSv3. */
3118 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3119 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3120 #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. */
3121 hv_stores(sih, "errno", newSViv(sip->si_errno));
3122 hv_stores(sih, "status", newSViv(sip->si_status));
3123 hv_stores(sih, "uid", newSViv(sip->si_uid));
3124 hv_stores(sih, "pid", newSViv(sip->si_pid));
3125 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3126 hv_stores(sih, "band", newSViv(sip->si_band));
3130 mPUSHp((char *)sip, sizeof(*sip));
3138 errsv_save = newSVsv(ERRSV);
3140 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3144 SV * const errsv = ERRSV;
3145 if (SvTRUE_NN(errsv)) {
3146 SvREFCNT_dec(errsv_save);
3148 /* Handler "died", for example to get out of a restart-able read().
3149 * Before we re-do that on its behalf re-enable the signal which was
3150 * blocked by the system when we entered.
3152 #ifdef HAS_SIGPROCMASK
3153 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3159 sigaddset(&set,sig);
3160 sigprocmask(SIG_UNBLOCK, &set, NULL);
3163 /* Not clear if this will work */
3164 (void)rsignal(sig, SIG_IGN);
3165 (void)rsignal(sig, PL_csighandlerp);
3167 #endif /* !PERL_MICRO */
3171 sv_setsv(errsv, errsv_save);
3172 SvREFCNT_dec(errsv_save);
3177 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3178 PL_savestack_ix = old_ss_ix;
3181 PL_op = myop; /* Apparently not needed... */
3183 PL_Sv = tSv; /* Restore global temporaries. */
3190 S_restore_magic(pTHX_ const void *p)
3193 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3194 SV* const sv = mgs->mgs_sv;
3200 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3201 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3202 #ifdef PERL_OLD_COPY_ON_WRITE
3203 /* While magic was saved (and off) sv_setsv may well have seen
3204 this SV as a prime candidate for COW. */
3206 sv_force_normal_flags(sv, 0);
3208 if (mgs->mgs_readonly)
3210 if (mgs->mgs_magical)
3211 SvFLAGS(sv) |= mgs->mgs_magical;
3216 bumped = mgs->mgs_bumped;
3217 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3219 /* If we're still on top of the stack, pop us off. (That condition
3220 * will be satisfied if restore_magic was called explicitly, but *not*
3221 * if it's being called via leave_scope.)
3222 * The reason for doing this is that otherwise, things like sv_2cv()
3223 * may leave alloc gunk on the savestack, and some code
3224 * (e.g. sighandler) doesn't expect that...
3226 if (PL_savestack_ix == mgs->mgs_ss_ix)
3228 UV popval = SSPOPUV;
3229 assert(popval == SAVEt_DESTRUCTOR_X);
3230 PL_savestack_ix -= 2;
3232 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3233 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3236 if (SvREFCNT(sv) == 1) {
3237 /* We hold the last reference to this SV, which implies that the
3238 SV was deleted as a side effect of the routines we called.
3239 So artificially keep it alive a bit longer.
3240 We avoid turning on the TEMP flag, which can cause the SV's
3241 buffer to get stolen (and maybe other stuff). */
3246 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3250 /* clean up the mess created by Perl_sighandler().
3251 * Note that this is only called during an exit in a signal handler;
3252 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3256 S_unwind_handler_stack(pTHX_ const void *p)
3261 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3265 =for apidoc magic_sethint
3267 Triggered by a store to %^H, records the key/value pair to
3268 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3269 anything that would need a deep copy. Maybe we should warn if we find a
3275 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3278 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3279 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3281 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3283 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3284 an alternative leaf in there, with PL_compiling.cop_hints being used if
3285 it's NULL. If needed for threads, the alternative could lock a mutex,
3286 or take other more complex action. */
3288 /* Something changed in %^H, so it will need to be restored on scope exit.
3289 Doing this here saves a lot of doing it manually in perl code (and
3290 forgetting to do it, and consequent subtle errors. */
3291 PL_hints |= HINT_LOCALIZE_HH;
3292 CopHINTHASH_set(&PL_compiling,
3293 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3298 =for apidoc magic_clearhint
3300 Triggered by a delete from %^H, records the key to
3301 C<PL_compiling.cop_hints_hash>.
3306 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3310 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3311 PERL_UNUSED_ARG(sv);
3313 PL_hints |= HINT_LOCALIZE_HH;
3314 CopHINTHASH_set(&PL_compiling,
3315 mg->mg_len == HEf_SVKEY
3316 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3317 MUTABLE_SV(mg->mg_ptr), 0, 0)
3318 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3319 mg->mg_ptr, mg->mg_len, 0, 0));
3324 =for apidoc magic_clearhints
3326 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3331 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3333 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3334 PERL_UNUSED_ARG(sv);
3335 PERL_UNUSED_ARG(mg);
3336 cophh_free(CopHINTHASH_get(&PL_compiling));
3337 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3342 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3343 const char *name, I32 namlen)
3347 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3348 PERL_UNUSED_ARG(sv);
3349 PERL_UNUSED_ARG(name);
3350 PERL_UNUSED_ARG(namlen);
3352 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3353 nmg = mg_find(nsv, mg->mg_type);
3354 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3355 nmg->mg_ptr = mg->mg_ptr;
3356 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3357 nmg->mg_flags |= MGf_REFCOUNTED;
3363 * c-indentation-style: bsd
3365 * indent-tabs-mode: nil
3368 * ex: set ts=8 sts=4 sw=4 et: