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 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
89 /* MGS is typedef'ed to struct magic_state in perl.h */
92 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
98 PERL_ARGS_ASSERT_SAVE_MAGIC;
100 /* we shouldn't really be called here with RC==0, but it can sometimes
101 * happen via mg_clear() (which also shouldn't be called when RC==0,
102 * but it can happen). Handle this case gracefully(ish) by not RC++
103 * and thus avoiding the resultant double free */
104 if (SvREFCNT(sv) > 0) {
105 /* guard against sv getting freed midway through the mg clearing,
106 * by holding a private reference for the duration. */
107 SvREFCNT_inc_simple_void_NN(sv);
111 assert(SvMAGICAL(sv));
112 /* Turning READONLY off for a copy-on-write scalar (including shared
113 hash keys) is a bad idea. */
115 sv_force_normal_flags(sv, 0);
117 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
119 mgs = SSPTR(mgs_ix, MGS*);
121 mgs->mgs_magical = SvMAGICAL(sv);
122 mgs->mgs_readonly = SvREADONLY(sv) != 0;
123 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
124 mgs->mgs_bumped = bumped;
128 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
129 /* No public flags are set, so promote any private flags to public. */
130 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
135 =for apidoc mg_magical
137 Turns on the magical status of an SV. See C<sv_magic>.
143 Perl_mg_magical(pTHX_ SV *sv)
146 PERL_ARGS_ASSERT_MG_MAGICAL;
150 if ((mg = SvMAGIC(sv))) {
152 const MGVTBL* const vtbl = mg->mg_virtual;
154 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
161 } while ((mg = mg->mg_moremagic));
162 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
170 Do magic after a value is retrieved from the SV. See C<sv_magic>.
176 Perl_mg_get(pTHX_ SV *sv)
179 const I32 mgs_ix = SSNEW(sizeof(MGS));
181 MAGIC *newmg, *head, *cur, *mg;
183 PERL_ARGS_ASSERT_MG_GET;
185 if (PL_localizing == 1 && sv == DEFSV) return 0;
187 save_magic(mgs_ix, sv);
189 /* We must call svt_get(sv, mg) for each valid entry in the linked
190 list of magic. svt_get() may delete the current entry, add new
191 magic to the head of the list, or upgrade the SV. AMS 20010810 */
193 newmg = cur = head = mg = SvMAGIC(sv);
195 const MGVTBL * const vtbl = mg->mg_virtual;
196 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
198 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
199 vtbl->svt_get(aTHX_ sv, mg);
201 /* guard against magic having been deleted - eg FETCH calling
204 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
208 /* recalculate flags if this entry was deleted. */
209 if (mg->mg_flags & MGf_GSKIP)
210 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
216 /* Have we finished with the new entries we saw? Start again
217 where we left off (unless there are more new entries). */
225 /* Were any new entries added? */
226 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
230 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
234 restore_magic(INT2PTR(void *, (IV)mgs_ix));
241 Do magic after a value is assigned to the SV. See C<sv_magic>.
247 Perl_mg_set(pTHX_ SV *sv)
250 const I32 mgs_ix = SSNEW(sizeof(MGS));
254 PERL_ARGS_ASSERT_MG_SET;
256 if (PL_localizing == 2 && sv == DEFSV) return 0;
258 save_magic(mgs_ix, sv);
260 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
261 const MGVTBL* vtbl = mg->mg_virtual;
262 nextmg = mg->mg_moremagic; /* it may delete itself */
263 if (mg->mg_flags & MGf_GSKIP) {
264 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
265 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
267 if (PL_localizing == 2
268 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
270 if (vtbl && vtbl->svt_set)
271 vtbl->svt_set(aTHX_ sv, mg);
274 restore_magic(INT2PTR(void*, (IV)mgs_ix));
279 =for apidoc mg_length
281 Report on the SV's length. See C<sv_magic>.
287 Perl_mg_length(pTHX_ SV *sv)
293 PERL_ARGS_ASSERT_MG_LENGTH;
295 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
296 const MGVTBL * const vtbl = mg->mg_virtual;
297 if (vtbl && vtbl->svt_len) {
298 const I32 mgs_ix = SSNEW(sizeof(MGS));
299 save_magic(mgs_ix, sv);
300 /* omit MGf_GSKIP -- not changed here */
301 len = vtbl->svt_len(aTHX_ sv, mg);
302 restore_magic(INT2PTR(void*, (IV)mgs_ix));
308 /* You can't know whether it's UTF-8 until you get the string again...
310 const U8 *s = (U8*)SvPV_const(sv, len);
313 len = utf8_length(s, s + len);
320 Perl_mg_size(pTHX_ SV *sv)
324 PERL_ARGS_ASSERT_MG_SIZE;
326 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
327 const MGVTBL* const vtbl = mg->mg_virtual;
328 if (vtbl && vtbl->svt_len) {
329 const I32 mgs_ix = SSNEW(sizeof(MGS));
331 save_magic(mgs_ix, sv);
332 /* omit MGf_GSKIP -- not changed here */
333 len = vtbl->svt_len(aTHX_ sv, mg);
334 restore_magic(INT2PTR(void*, (IV)mgs_ix));
341 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
345 Perl_croak(aTHX_ "Size magic not implemented");
354 Clear something magical that the SV represents. See C<sv_magic>.
360 Perl_mg_clear(pTHX_ SV *sv)
362 const I32 mgs_ix = SSNEW(sizeof(MGS));
366 PERL_ARGS_ASSERT_MG_CLEAR;
368 save_magic(mgs_ix, sv);
370 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
371 const MGVTBL* const vtbl = mg->mg_virtual;
372 /* omit GSKIP -- never set here */
374 nextmg = mg->mg_moremagic; /* it may delete itself */
376 if (vtbl && vtbl->svt_clear)
377 vtbl->svt_clear(aTHX_ sv, mg);
380 restore_magic(INT2PTR(void*, (IV)mgs_ix));
385 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
394 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
395 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
407 Finds the magic pointer for type matching the SV. See C<sv_magic>.
413 Perl_mg_find(pTHX_ const SV *sv, int type)
415 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
419 =for apidoc mg_findext
421 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
428 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
430 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
436 Copies the magic from one SV to another. See C<sv_magic>.
442 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
447 PERL_ARGS_ASSERT_MG_COPY;
449 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
450 const MGVTBL* const vtbl = mg->mg_virtual;
451 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
452 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
455 const char type = mg->mg_type;
456 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
458 (type == PERL_MAGIC_tied)
460 : (type == PERL_MAGIC_regdata && mg->mg_obj)
463 toLOWER(type), key, klen);
472 =for apidoc mg_localize
474 Copy some of the magic from an existing SV to new localized version of that
475 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
478 If setmagic is false then no set magic will be called on the new (empty) SV.
479 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
480 and that will handle the magic.
486 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
491 PERL_ARGS_ASSERT_MG_LOCALIZE;
496 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
497 const MGVTBL* const vtbl = mg->mg_virtual;
498 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
501 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
502 (void)vtbl->svt_local(aTHX_ nsv, mg);
504 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
505 mg->mg_ptr, mg->mg_len);
507 /* container types should remain read-only across localization */
508 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
511 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
512 SvFLAGS(nsv) |= SvMAGICAL(sv);
521 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
523 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
525 const MGVTBL* const vtbl = mg->mg_virtual;
526 if (vtbl && vtbl->svt_free)
527 vtbl->svt_free(aTHX_ sv, mg);
528 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
529 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
530 Safefree(mg->mg_ptr);
531 else if (mg->mg_len == HEf_SVKEY)
532 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
534 if (mg->mg_flags & MGf_REFCOUNTED)
535 SvREFCNT_dec(mg->mg_obj);
542 Free any magic storage used by the SV. See C<sv_magic>.
548 Perl_mg_free(pTHX_ SV *sv)
553 PERL_ARGS_ASSERT_MG_FREE;
555 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
556 moremagic = mg->mg_moremagic;
557 mg_free_struct(sv, mg);
558 SvMAGIC_set(sv, moremagic);
560 SvMAGIC_set(sv, NULL);
566 =for apidoc Am|void|mg_free_type|SV *sv|int how
568 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
574 Perl_mg_free_type(pTHX_ SV *sv, int how)
576 MAGIC *mg, *prevmg, *moremg;
577 PERL_ARGS_ASSERT_MG_FREE_TYPE;
578 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
580 moremg = mg->mg_moremagic;
581 if (mg->mg_type == how) {
582 /* temporarily move to the head of the magic chain, in case
583 custom free code relies on this historical aspect of mg_free */
585 prevmg->mg_moremagic = moremg;
586 mg->mg_moremagic = SvMAGIC(sv);
589 newhead = mg->mg_moremagic;
590 mg_free_struct(sv, mg);
591 SvMAGIC_set(sv, newhead);
601 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
606 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
609 register const REGEXP * const rx = PM_GETRE(PL_curpm);
611 if (mg->mg_obj) { /* @+ */
612 /* return the number possible */
613 return RX_NPARENS(rx);
615 I32 paren = RX_LASTPAREN(rx);
617 /* return the last filled */
619 && (RX_OFFS(rx)[paren].start == -1
620 || RX_OFFS(rx)[paren].end == -1) )
631 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
635 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
638 register const REGEXP * const rx = PM_GETRE(PL_curpm);
640 register const I32 paren = mg->mg_len;
645 if (paren <= (I32)RX_NPARENS(rx) &&
646 (s = RX_OFFS(rx)[paren].start) != -1 &&
647 (t = RX_OFFS(rx)[paren].end) != -1)
650 if (mg->mg_obj) /* @+ */
655 if (i > 0 && RX_MATCH_UTF8(rx)) {
656 const char * const b = RX_SUBBEG(rx);
658 i = utf8_length((U8*)b, (U8*)(b+i));
669 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
671 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
674 Perl_croak_no_modify(aTHX);
675 NORETURN_FUNCTION_END;
679 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
684 register const REGEXP * rx;
685 const char * const remaining = mg->mg_ptr + 1;
687 PERL_ARGS_ASSERT_MAGIC_LEN;
689 switch (*mg->mg_ptr) {
691 if (*remaining == '\0') { /* ^P */
693 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
695 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
699 case '\015': /* $^MATCH */
700 if (strEQ(remaining, "ATCH")) {
707 paren = RX_BUFF_IDX_PREMATCH;
711 paren = RX_BUFF_IDX_POSTMATCH;
715 paren = RX_BUFF_IDX_FULLMATCH;
717 case '1': case '2': case '3': case '4':
718 case '5': case '6': case '7': case '8': case '9':
719 paren = atoi(mg->mg_ptr);
721 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
723 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
726 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
729 if (ckWARN(WARN_UNINITIALIZED))
734 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
735 paren = RX_LASTPAREN(rx);
740 case '\016': /* ^N */
741 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
742 paren = RX_LASTCLOSEPAREN(rx);
749 if (!SvPOK(sv) && SvNIOK(sv)) {
757 #define SvRTRIM(sv) STMT_START { \
759 STRLEN len = SvCUR(sv); \
760 char * const p = SvPVX(sv); \
761 while (len > 0 && isSPACE(p[len-1])) \
763 SvCUR_set(sv, len); \
769 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
771 PERL_ARGS_ASSERT_EMULATE_COP_IO;
773 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
774 sv_setsv(sv, &PL_sv_undef);
778 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
779 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
784 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
785 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
793 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
797 register const char *s = NULL;
799 const char * const remaining = mg->mg_ptr + 1;
800 const char nextchar = *remaining;
802 PERL_ARGS_ASSERT_MAGIC_GET;
804 switch (*mg->mg_ptr) {
805 case '\001': /* ^A */
806 sv_setsv(sv, PL_bodytarget);
807 if (SvTAINTED(PL_bodytarget))
810 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
811 if (nextchar == '\0') {
812 sv_setiv(sv, (IV)PL_minus_c);
814 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
815 sv_setiv(sv, (IV)STATUS_NATIVE);
819 case '\004': /* ^D */
820 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
822 case '\005': /* ^E */
823 if (nextchar == '\0') {
826 # include <descrip.h>
827 # include <starlet.h>
829 $DESCRIPTOR(msgdsc,msg);
830 sv_setnv(sv,(NV) vaxc$errno);
831 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
832 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
837 if (!(_emx_env & 0x200)) { /* Under DOS */
838 sv_setnv(sv, (NV)errno);
839 sv_setpv(sv, errno ? Strerror(errno) : "");
841 if (errno != errno_isOS2) {
842 const int tmp = _syserrno();
843 if (tmp) /* 2nd call to _syserrno() makes it 0 */
846 sv_setnv(sv, (NV)Perl_rc);
847 sv_setpv(sv, os2error(Perl_rc));
851 const DWORD dwErr = GetLastError();
852 sv_setnv(sv, (NV)dwErr);
854 PerlProc_GetOSError(sv, dwErr);
863 sv_setnv(sv, (NV)errno);
864 sv_setpv(sv, errno ? Strerror(errno) : "");
869 SvNOK_on(sv); /* what a wonderful hack! */
871 else if (strEQ(remaining, "NCODING"))
872 sv_setsv(sv, PL_encoding);
874 case '\006': /* ^F */
875 sv_setiv(sv, (IV)PL_maxsysfd);
877 case '\007': /* ^GLOBAL_PHASE */
878 if (strEQ(remaining, "LOBAL_PHASE")) {
879 sv_setpvn(sv, PL_phase_names[PL_phase],
880 strlen(PL_phase_names[PL_phase]));
883 case '\010': /* ^H */
884 sv_setiv(sv, (IV)PL_hints);
886 case '\011': /* ^I */ /* NOT \t in EBCDIC */
887 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
889 case '\017': /* ^O & ^OPEN */
890 if (nextchar == '\0') {
891 sv_setpv(sv, PL_osname);
894 else if (strEQ(remaining, "PEN")) {
895 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
899 if (nextchar == '\0') { /* ^P */
900 sv_setiv(sv, (IV)PL_perldb);
901 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
902 goto do_prematch_fetch;
903 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
904 goto do_postmatch_fetch;
907 case '\023': /* ^S */
908 if (nextchar == '\0') {
909 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
912 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
917 case '\024': /* ^T */
918 if (nextchar == '\0') {
920 sv_setnv(sv, PL_basetime);
922 sv_setiv(sv, (IV)PL_basetime);
925 else if (strEQ(remaining, "AINT"))
926 sv_setiv(sv, PL_tainting
927 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
930 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
931 if (strEQ(remaining, "NICODE"))
932 sv_setuv(sv, (UV) PL_unicode);
933 else if (strEQ(remaining, "TF8LOCALE"))
934 sv_setuv(sv, (UV) PL_utf8locale);
935 else if (strEQ(remaining, "TF8CACHE"))
936 sv_setiv(sv, (IV) PL_utf8cache);
938 case '\027': /* ^W & $^WARNING_BITS */
939 if (nextchar == '\0')
940 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
941 else if (strEQ(remaining, "ARNING_BITS")) {
942 if (PL_compiling.cop_warnings == pWARN_NONE) {
943 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
945 else if (PL_compiling.cop_warnings == pWARN_STD) {
948 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
952 else if (PL_compiling.cop_warnings == pWARN_ALL) {
953 /* Get the bit mask for $warnings::Bits{all}, because
954 * it could have been extended by warnings::register */
955 HV * const bits=get_hv("warnings::Bits", 0);
957 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
959 sv_setsv(sv, *bits_all);
962 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
966 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
967 *PL_compiling.cop_warnings);
972 case '\015': /* $^MATCH */
973 if (strEQ(remaining, "ATCH")) {
974 case '1': case '2': case '3': case '4':
975 case '5': case '6': case '7': case '8': case '9': case '&':
976 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
978 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
979 * XXX Does the new way break anything?
981 paren = atoi(mg->mg_ptr); /* $& is in [0] */
982 CALLREG_NUMBUF_FETCH(rx,paren,sv);
985 sv_setsv(sv,&PL_sv_undef);
989 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
990 if (RX_LASTPAREN(rx)) {
991 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
995 sv_setsv(sv,&PL_sv_undef);
997 case '\016': /* ^N */
998 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
999 if (RX_LASTCLOSEPAREN(rx)) {
1000 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1005 sv_setsv(sv,&PL_sv_undef);
1009 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1010 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1013 sv_setsv(sv,&PL_sv_undef);
1017 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1018 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1021 sv_setsv(sv,&PL_sv_undef);
1024 if (GvIO(PL_last_in_gv)) {
1025 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1030 sv_setiv(sv, (IV)STATUS_CURRENT);
1031 #ifdef COMPLEX_STATUS
1032 SvUPGRADE(sv, SVt_PVLV);
1033 LvTARGOFF(sv) = PL_statusvalue;
1034 LvTARGLEN(sv) = PL_statusvalue_vms;
1039 if (GvIOp(PL_defoutgv))
1040 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1044 sv_setpv(sv,GvENAME(PL_defoutgv));
1045 sv_catpvs(sv,"_TOP");
1049 if (GvIOp(PL_defoutgv))
1050 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1052 s = GvENAME(PL_defoutgv);
1056 if (GvIO(PL_defoutgv))
1057 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1060 if (GvIO(PL_defoutgv))
1061 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1064 if (GvIO(PL_defoutgv))
1065 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1075 if (GvIO(PL_defoutgv))
1076 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1080 sv_copypv(sv, PL_ors_sv);
1084 IV const pid = (IV)PerlProc_getpid();
1085 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid)
1086 /* never set manually, or at least not since last fork */
1088 /* else a value has been assigned manually, so do nothing */
1096 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1098 sv_setnv(sv, (NV)errno);
1101 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1102 sv_setpv(sv, os2error(Perl_rc));
1105 sv_setpv(sv, errno ? Strerror(errno) : "");
1107 SvPOK_on(sv); /* may have got removed during taint processing */
1112 SvNOK_on(sv); /* what a wonderful hack! */
1115 sv_setiv(sv, (IV)PL_uid);
1118 sv_setiv(sv, (IV)PL_euid);
1121 sv_setiv(sv, (IV)PL_gid);
1124 sv_setiv(sv, (IV)PL_egid);
1126 #ifdef HAS_GETGROUPS
1128 Groups_t *gary = NULL;
1129 I32 i, num_groups = getgroups(0, gary);
1130 Newx(gary, num_groups, Groups_t);
1131 num_groups = getgroups(num_groups, gary);
1132 for (i = 0; i < num_groups; i++)
1133 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1136 (void)SvIOK_on(sv); /* what a wonderful hack! */
1146 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1148 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1150 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1152 if (uf && uf->uf_val)
1153 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1158 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1161 STRLEN len = 0, klen;
1162 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1163 const char * const ptr = MgPV_const(mg,klen);
1166 PERL_ARGS_ASSERT_MAGIC_SETENV;
1168 #ifdef DYNAMIC_ENV_FETCH
1169 /* We just undefd an environment var. Is a replacement */
1170 /* waiting in the wings? */
1172 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1174 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1178 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1179 /* And you'll never guess what the dog had */
1180 /* in its mouth... */
1182 MgTAINTEDDIR_off(mg);
1184 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1185 char pathbuf[256], eltbuf[256], *cp, *elt;
1188 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1190 do { /* DCL$PATH may be a search list */
1191 while (1) { /* as may dev portion of any element */
1192 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1193 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1194 cando_by_name(S_IWUSR,0,elt) ) {
1195 MgTAINTEDDIR_on(mg);
1199 if ((cp = strchr(elt, ':')) != NULL)
1201 if (my_trnlnm(elt, eltbuf, j++))
1207 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1210 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1211 const char * const strend = s + len;
1213 while (s < strend) {
1217 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1218 const char path_sep = '|';
1220 const char path_sep = ':';
1222 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1223 s, strend, path_sep, &i);
1225 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1227 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1229 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1231 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1232 MgTAINTEDDIR_on(mg);
1238 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1244 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1246 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1247 PERL_UNUSED_ARG(sv);
1248 my_setenv(MgPV_nolen_const(mg),NULL);
1253 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1256 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1257 PERL_UNUSED_ARG(mg);
1259 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1261 if (PL_localizing) {
1264 hv_iterinit(MUTABLE_HV(sv));
1265 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1267 my_setenv(hv_iterkey(entry, &keylen),
1268 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1276 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1279 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1280 PERL_UNUSED_ARG(sv);
1281 PERL_UNUSED_ARG(mg);
1283 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1291 #ifdef HAS_SIGPROCMASK
1293 restore_sigmask(pTHX_ SV *save_sv)
1295 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1296 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1300 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1303 /* Are we fetching a signal entry? */
1304 int i = (I16)mg->mg_private;
1306 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1310 const char * sig = MgPV_const(mg, siglen);
1311 mg->mg_private = i = whichsig_pvn(sig, siglen);
1316 sv_setsv(sv,PL_psig_ptr[i]);
1318 Sighandler_t sigstate = rsignal_state(i);
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1323 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1324 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1327 /* cache state so we don't fetch it again */
1328 if(sigstate == (Sighandler_t) SIG_IGN)
1329 sv_setpvs(sv,"IGNORE");
1331 sv_setsv(sv,&PL_sv_undef);
1332 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1339 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1341 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1343 magic_setsig(NULL, mg);
1344 return sv_unmagic(sv, mg->mg_type);
1348 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1349 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1351 Perl_csighandler(int sig)
1354 #ifdef PERL_GET_SIG_CONTEXT
1355 dTHXa(PERL_GET_SIG_CONTEXT);
1359 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1360 (void) rsignal(sig, PL_csighandlerp);
1361 if (PL_sig_ignoring[sig]) return;
1363 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364 if (PL_sig_defaulting[sig])
1365 #ifdef KILL_BY_SIGPRC
1366 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1381 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1382 /* Call the perl level handler now--
1383 * with risk we may be in malloc() or being destructed etc. */
1384 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1385 (*PL_sighandlerp)(sig, NULL, NULL);
1387 (*PL_sighandlerp)(sig);
1390 if (!PL_psig_pend) return;
1391 /* Set a flag to say this signal is pending, that is awaiting delivery after
1392 * the current Perl opcode completes */
1393 PL_psig_pend[sig]++;
1395 #ifndef SIG_PENDING_DIE_COUNT
1396 # define SIG_PENDING_DIE_COUNT 120
1398 /* Add one to say _a_ signal is pending */
1399 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1400 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1401 (unsigned long)SIG_PENDING_DIE_COUNT);
1405 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1407 Perl_csighandler_init(void)
1410 if (PL_sig_handlers_initted) return;
1412 for (sig = 1; sig < SIG_SIZE; sig++) {
1413 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1415 PL_sig_defaulting[sig] = 1;
1416 (void) rsignal(sig, PL_csighandlerp);
1418 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1419 PL_sig_ignoring[sig] = 0;
1422 PL_sig_handlers_initted = 1;
1426 #if defined HAS_SIGPROCMASK
1428 unblock_sigmask(pTHX_ void* newset)
1430 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1435 Perl_despatch_signals(pTHX)
1440 for (sig = 1; sig < SIG_SIZE; sig++) {
1441 if (PL_psig_pend[sig]) {
1443 #ifdef HAS_SIGPROCMASK
1444 /* From sigaction(2) (FreeBSD man page):
1445 * | Signal routines normally execute with the signal that
1446 * | caused their invocation blocked, but other signals may
1448 * Emulation of this behavior (from within Perl) is enabled
1452 sigset_t newset, oldset;
1454 sigemptyset(&newset);
1455 sigaddset(&newset, sig);
1456 sigprocmask(SIG_BLOCK, &newset, &oldset);
1457 was_blocked = sigismember(&oldset, sig);
1459 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1461 SAVEFREESV(save_sv);
1462 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1465 PL_psig_pend[sig] = 0;
1466 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1467 (*PL_sighandlerp)(sig, NULL, NULL);
1469 (*PL_sighandlerp)(sig);
1471 #ifdef HAS_SIGPROCMASK
1480 /* sv of NULL signifies that we're acting as magic_clearsig. */
1482 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1487 /* Need to be careful with SvREFCNT_dec(), because that can have side
1488 * effects (due to closures). We must make sure that the new disposition
1489 * is in place before it is called.
1493 #ifdef HAS_SIGPROCMASK
1497 register const char *s = MgPV_const(mg,len);
1499 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1502 if (memEQs(s, len, "__DIE__"))
1504 else if (memEQs(s, len, "__WARN__")
1505 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1506 /* Merge the existing behaviours, which are as follows:
1507 magic_setsig, we always set svp to &PL_warnhook
1508 (hence we always change the warnings handler)
1509 For magic_clearsig, we don't change the warnings handler if it's
1510 set to the &PL_warnhook. */
1513 SV *tmp = sv_newmortal();
1514 Perl_croak(aTHX_ "No such hook: %s",
1515 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1519 if (*svp != PERL_WARNHOOK_FATAL)
1525 i = (I16)mg->mg_private;
1527 i = whichsig_pvn(s, len); /* ...no, a brick */
1528 mg->mg_private = (U16)i;
1532 SV *tmp = sv_newmortal();
1533 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1534 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1538 #ifdef HAS_SIGPROCMASK
1539 /* Avoid having the signal arrive at a bad time, if possible. */
1542 sigprocmask(SIG_BLOCK, &set, &save);
1544 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1545 SAVEFREESV(save_sv);
1546 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1549 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1550 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1552 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1553 PL_sig_ignoring[i] = 0;
1555 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1556 PL_sig_defaulting[i] = 0;
1558 to_dec = PL_psig_ptr[i];
1560 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1561 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1563 /* Signals don't change name during the program's execution, so once
1564 they're cached in the appropriate slot of PL_psig_name, they can
1567 Ideally we'd find some way of making SVs at (C) compile time, or
1568 at least, doing most of the work. */
1569 if (!PL_psig_name[i]) {
1570 PL_psig_name[i] = newSVpvn(s, len);
1571 SvREADONLY_on(PL_psig_name[i]);
1574 SvREFCNT_dec(PL_psig_name[i]);
1575 PL_psig_name[i] = NULL;
1576 PL_psig_ptr[i] = NULL;
1579 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1581 (void)rsignal(i, PL_csighandlerp);
1584 *svp = SvREFCNT_inc_simple_NN(sv);
1586 if (sv && SvOK(sv)) {
1587 s = SvPV_force(sv, len);
1591 if (sv && memEQs(s, len,"IGNORE")) {
1593 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1594 PL_sig_ignoring[i] = 1;
1595 (void)rsignal(i, PL_csighandlerp);
1597 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1601 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1603 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604 PL_sig_defaulting[i] = 1;
1605 (void)rsignal(i, PL_csighandlerp);
1607 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1613 * We should warn if HINT_STRICT_REFS, but without
1614 * access to a known hint bit in a known OP, we can't
1615 * tell whether HINT_STRICT_REFS is in force or not.
1617 if (!strchr(s,':') && !strchr(s,'\''))
1618 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1621 (void)rsignal(i, PL_csighandlerp);
1623 *svp = SvREFCNT_inc_simple_NN(sv);
1627 #ifdef HAS_SIGPROCMASK
1631 SvREFCNT_dec(to_dec);
1634 #endif /* !PERL_MICRO */
1637 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1640 PERL_ARGS_ASSERT_MAGIC_SETISA;
1641 PERL_UNUSED_ARG(sv);
1643 /* Skip _isaelem because _isa will handle it shortly */
1644 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1647 return magic_clearisa(NULL, mg);
1650 /* sv of NULL signifies that we're acting as magic_setisa. */
1652 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1657 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1659 /* Bail out if destruction is going on */
1660 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1663 av_clear(MUTABLE_AV(sv));
1665 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1666 /* This occurs with setisa_elem magic, which calls this
1668 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1670 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1671 SV **svp = AvARRAY((AV *)mg->mg_obj);
1672 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1674 stash = GvSTASH((GV *)*svp++);
1675 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1682 (const GV *)mg->mg_obj
1685 /* The stash may have been detached from the symbol table, so check its
1686 name before doing anything. */
1687 if (stash && HvENAME_get(stash))
1688 mro_isa_changed_in(stash);
1694 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1697 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1698 PERL_UNUSED_ARG(sv);
1699 PERL_UNUSED_ARG(mg);
1700 PL_amagic_generation++;
1706 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1708 HV * const hv = MUTABLE_HV(LvTARG(sv));
1711 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1712 PERL_UNUSED_ARG(mg);
1715 (void) hv_iterinit(hv);
1716 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1719 while (hv_iternext(hv))
1724 sv_setiv(sv, (IV)i);
1729 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1731 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1732 PERL_UNUSED_ARG(mg);
1734 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1740 =for apidoc magic_methcall
1742 Invoke a magic method (like FETCH).
1744 C<sv> and C<mg> are the tied thingy and the tie magic.
1746 C<meth> is the name of the method to call.
1748 C<argc> is the number of args (in addition to $self) to pass to the method.
1750 The C<flags> can be:
1752 G_DISCARD invoke method with G_DISCARD flag and don't
1754 G_UNDEF_FILL fill the stack with argc pointers to
1757 The arguments themselves are any values following the C<flags> argument.
1759 Returns the SV (if any) returned by the method, or NULL on failure.
1766 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1773 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1777 if (flags & G_WRITING_TO_STDERR) {
1781 SAVESPTR(PL_stderrgv);
1785 PUSHSTACKi(PERLSI_MAGIC);
1789 PUSHs(SvTIED_obj(sv, mg));
1790 if (flags & G_UNDEF_FILL) {
1792 PUSHs(&PL_sv_undef);
1794 } else if (argc > 0) {
1796 va_start(args, argc);
1799 SV *const sv = va_arg(args, SV *);
1806 if (flags & G_DISCARD) {
1807 call_method(meth, G_SCALAR|G_DISCARD);
1810 if (call_method(meth, G_SCALAR))
1811 ret = *PL_stack_sp--;
1814 if (flags & G_WRITING_TO_STDERR)
1821 /* wrapper for magic_methcall that creates the first arg */
1824 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1830 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1833 if (mg->mg_len >= 0) {
1834 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1836 else if (mg->mg_len == HEf_SVKEY)
1837 arg1 = MUTABLE_SV(mg->mg_ptr);
1839 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1840 arg1 = newSViv((IV)(mg->mg_len));
1844 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1846 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1850 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1855 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1857 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1864 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1866 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1868 if (mg->mg_type == PERL_MAGIC_tiedelem)
1869 mg->mg_flags |= MGf_GSKIP;
1870 magic_methpack(sv,mg,"FETCH");
1875 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1881 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1883 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1884 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1885 * public flags indicate its value based on copying from $val. Doing
1886 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1887 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1888 * wrong if $val happened to be tainted, as sv hasn't got magic
1889 * enabled, even though taint magic is in the chain. In which case,
1890 * fake up a temporary tainted value (this is easier than temporarily
1891 * re-enabling magic on sv). */
1893 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1894 && (tmg->mg_len & 1))
1896 val = sv_mortalcopy(sv);
1902 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1907 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1909 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1911 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1912 return magic_methpack(sv,mg,"DELETE");
1917 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1923 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1925 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1927 retval = SvIV(retsv)-1;
1929 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1931 return (U32) retval;
1935 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1939 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1941 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1946 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1951 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1953 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1954 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1961 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1963 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1965 return magic_methpack(sv,mg,"EXISTS");
1969 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1973 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1974 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1976 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1978 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1980 if (HvEITER_get(hv))
1981 /* we are in an iteration so the hash cannot be empty */
1983 /* no xhv_eiter so now use FIRSTKEY */
1984 key = sv_newmortal();
1985 magic_nextpack(MUTABLE_SV(hv), mg, key);
1986 HvEITER_set(hv, NULL); /* need to reset iterator */
1987 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1990 /* there is a SCALAR method that we can call */
1991 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1993 retval = &PL_sv_undef;
1998 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2001 GV * const gv = PL_DBline;
2002 const I32 i = SvTRUE(sv);
2003 SV ** const svp = av_fetch(GvAV(gv),
2004 atoi(MgPV_nolen_const(mg)), FALSE);
2006 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2008 if (svp && SvIOKp(*svp)) {
2009 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2011 /* set or clear breakpoint in the relevant control op */
2013 o->op_flags |= OPf_SPECIAL;
2015 o->op_flags &= ~OPf_SPECIAL;
2022 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2025 AV * const obj = MUTABLE_AV(mg->mg_obj);
2027 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2030 sv_setiv(sv, AvFILL(obj));
2038 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2041 AV * const obj = MUTABLE_AV(mg->mg_obj);
2043 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2046 av_fill(obj, SvIV(sv));
2048 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2049 "Attempt to set length of freed array");
2055 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2059 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2060 PERL_UNUSED_ARG(sv);
2062 /* during global destruction, mg_obj may already have been freed */
2063 if (PL_in_clean_all)
2066 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2069 /* arylen scalar holds a pointer back to the array, but doesn't own a
2070 reference. Hence the we (the array) are about to go away with it
2071 still pointing at us. Clear its pointer, else it would be pointing
2072 at free memory. See the comment in sv_magic about reference loops,
2073 and why it can't own a reference to us. */
2080 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2083 SV* const lsv = LvTARG(sv);
2085 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2086 PERL_UNUSED_ARG(mg);
2088 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2089 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2090 if (found && found->mg_len >= 0) {
2091 I32 i = found->mg_len;
2093 sv_pos_b2u(lsv, &i);
2103 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2106 SV* const lsv = LvTARG(sv);
2112 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2113 PERL_UNUSED_ARG(mg);
2115 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2116 found = mg_find(lsv, PERL_MAGIC_regex_global);
2122 #ifdef PERL_OLD_COPY_ON_WRITE
2124 sv_force_normal_flags(lsv, 0);
2126 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2129 else if (!SvOK(sv)) {
2133 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2138 ulen = sv_len_utf8(lsv);
2148 else if (pos > (SSize_t)len)
2153 sv_pos_u2b(lsv, &p, 0);
2157 found->mg_len = pos;
2158 found->mg_flags &= ~MGf_MINMATCH;
2164 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2167 SV * const lsv = LvTARG(sv);
2168 const char * const tmps = SvPV_const(lsv,len);
2169 STRLEN offs = LvTARGOFF(sv);
2170 STRLEN rem = LvTARGLEN(sv);
2171 const bool negoff = LvFLAGS(sv) & 1;
2172 const bool negrem = LvFLAGS(sv) & 2;
2174 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2175 PERL_UNUSED_ARG(mg);
2177 if (!translate_substr_offsets(
2178 SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
2179 negoff ? -(IV)offs : (IV)offs, !negoff,
2180 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2182 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2183 sv_setsv_nomg(sv, &PL_sv_undef);
2188 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2189 sv_setpvn(sv, tmps + offs, rem);
2196 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2199 STRLEN len, lsv_len, oldtarglen, newtarglen;
2200 const char * const tmps = SvPV_const(sv, len);
2201 SV * const lsv = LvTARG(sv);
2202 STRLEN lvoff = LvTARGOFF(sv);
2203 STRLEN lvlen = LvTARGLEN(sv);
2204 const bool negoff = LvFLAGS(sv) & 1;
2205 const bool neglen = LvFLAGS(sv) & 2;
2207 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2208 PERL_UNUSED_ARG(mg);
2212 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2213 "Attempt to use reference as lvalue in substr"
2215 if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
2216 else (void)SvPV_nomg(lsv,lsv_len);
2217 if (!translate_substr_offsets(
2219 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2220 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2222 Perl_croak(aTHX_ "substr outside of string");
2225 sv_utf8_upgrade(lsv);
2226 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2227 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2228 newtarglen = sv_len_utf8(sv);
2231 else if (lsv && SvUTF8(lsv)) {
2233 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2235 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2236 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2240 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2243 if (!neglen) LvTARGLEN(sv) = newtarglen;
2244 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2250 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2254 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2255 PERL_UNUSED_ARG(sv);
2257 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2262 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2266 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2267 PERL_UNUSED_ARG(sv);
2269 /* update taint status */
2278 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2280 SV * const lsv = LvTARG(sv);
2282 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2283 PERL_UNUSED_ARG(mg);
2286 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2294 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2296 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2297 PERL_UNUSED_ARG(mg);
2298 do_vecset(sv); /* XXX slurp this routine */
2303 Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
2305 PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
2308 SV * const vecsv = sv_newmortal();
2309 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
2310 if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
2312 return sv_unmagic(sv, mg->mg_type);
2316 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2321 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2323 if (LvTARGLEN(sv)) {
2325 SV * const ahv = LvTARG(sv);
2326 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2331 AV *const av = MUTABLE_AV(LvTARG(sv));
2332 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2333 targ = AvARRAY(av)[LvTARGOFF(sv)];
2335 if (targ && (targ != &PL_sv_undef)) {
2336 /* somebody else defined it for us */
2337 SvREFCNT_dec(LvTARG(sv));
2338 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2340 SvREFCNT_dec(mg->mg_obj);
2342 mg->mg_flags &= ~MGf_REFCOUNTED;
2347 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2352 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2354 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2355 PERL_UNUSED_ARG(mg);
2359 sv_setsv(LvTARG(sv), sv);
2360 SvSETMAGIC(LvTARG(sv));
2366 Perl_vivify_defelem(pTHX_ SV *sv)
2372 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2374 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2377 SV * const ahv = LvTARG(sv);
2378 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2381 if (!value || value == &PL_sv_undef)
2382 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2385 AV *const av = MUTABLE_AV(LvTARG(sv));
2386 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2387 LvTARG(sv) = NULL; /* array can't be extended */
2389 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2390 if (!svp || (value = *svp) == &PL_sv_undef)
2391 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2394 SvREFCNT_inc_simple_void(value);
2395 SvREFCNT_dec(LvTARG(sv));
2398 SvREFCNT_dec(mg->mg_obj);
2400 mg->mg_flags &= ~MGf_REFCOUNTED;
2404 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2406 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2407 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2412 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2414 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2415 PERL_UNUSED_CONTEXT;
2416 PERL_UNUSED_ARG(sv);
2422 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2424 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2426 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2428 if (uf && uf->uf_set)
2429 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2434 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2436 const char type = mg->mg_type;
2438 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2440 if (type == PERL_MAGIC_qr) {
2441 } else if (type == PERL_MAGIC_bm) {
2444 } else if (type == PERL_MAGIC_study) {
2445 if (!isGV_with_GP(sv))
2448 assert(type == PERL_MAGIC_fm);
2450 return sv_unmagic(sv, type);
2453 #ifdef USE_LOCALE_COLLATE
2455 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2457 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2460 * RenE<eacute> Descartes said "I think not."
2461 * and vanished with a faint plop.
2463 PERL_UNUSED_CONTEXT;
2464 PERL_UNUSED_ARG(sv);
2466 Safefree(mg->mg_ptr);
2472 #endif /* USE_LOCALE_COLLATE */
2474 /* Just clear the UTF-8 cache data. */
2476 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2478 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2479 PERL_UNUSED_CONTEXT;
2480 PERL_UNUSED_ARG(sv);
2481 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2483 mg->mg_len = -1; /* The mg_len holds the len cache. */
2488 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2491 register const char *s;
2493 register const REGEXP * rx;
2494 const char * const remaining = mg->mg_ptr + 1;
2499 PERL_ARGS_ASSERT_MAGIC_SET;
2501 switch (*mg->mg_ptr) {
2502 case '\015': /* $^MATCH */
2503 if (strEQ(remaining, "ATCH"))
2505 case '`': /* ${^PREMATCH} caught below */
2507 paren = RX_BUFF_IDX_PREMATCH;
2509 case '\'': /* ${^POSTMATCH} caught below */
2511 paren = RX_BUFF_IDX_POSTMATCH;
2515 paren = RX_BUFF_IDX_FULLMATCH;
2517 case '1': case '2': case '3': case '4':
2518 case '5': case '6': case '7': case '8': case '9':
2519 paren = atoi(mg->mg_ptr);
2521 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2522 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2524 /* Croak with a READONLY error when a numbered match var is
2525 * set without a previous pattern match. Unless it's C<local $1>
2527 if (!PL_localizing) {
2528 Perl_croak_no_modify(aTHX);
2532 case '\001': /* ^A */
2533 sv_setsv(PL_bodytarget, sv);
2534 FmLINES(PL_bodytarget) = 0;
2535 if (SvPOK(PL_bodytarget)) {
2536 char *s = SvPVX(PL_bodytarget);
2537 while ( ((s = strchr(s, '\n'))) ) {
2538 FmLINES(PL_bodytarget)++;
2542 /* mg_set() has temporarily made sv non-magical */
2544 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2545 SvTAINTED_on(PL_bodytarget);
2547 SvTAINTED_off(PL_bodytarget);
2550 case '\003': /* ^C */
2551 PL_minus_c = cBOOL(SvIV(sv));
2554 case '\004': /* ^D */
2556 s = SvPV_nolen_const(sv);
2557 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2558 if (DEBUG_x_TEST || DEBUG_B_TEST)
2559 dump_all_perl(!DEBUG_B_TEST);
2561 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2564 case '\005': /* ^E */
2565 if (*(mg->mg_ptr+1) == '\0') {
2567 set_vaxc_errno(SvIV(sv));
2570 SetLastError( SvIV(sv) );
2573 os2_setsyserrno(SvIV(sv));
2575 /* will anyone ever use this? */
2576 SETERRNO(SvIV(sv), 4);
2581 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2582 SvREFCNT_dec(PL_encoding);
2583 if (SvOK(sv) || SvGMAGICAL(sv)) {
2584 PL_encoding = newSVsv(sv);
2591 case '\006': /* ^F */
2592 PL_maxsysfd = SvIV(sv);
2594 case '\010': /* ^H */
2595 PL_hints = SvIV(sv);
2597 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2598 Safefree(PL_inplace);
2599 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2601 case '\017': /* ^O */
2602 if (*(mg->mg_ptr+1) == '\0') {
2603 Safefree(PL_osname);
2606 TAINT_PROPER("assigning to $^O");
2607 PL_osname = savesvpv(sv);
2610 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2612 const char *const start = SvPV(sv, len);
2613 const char *out = (const char*)memchr(start, '\0', len);
2617 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2618 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2620 /* Opening for input is more common than opening for output, so
2621 ensure that hints for input are sooner on linked list. */
2622 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2624 : newSVpvs_flags("", SvUTF8(sv));
2625 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2628 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2630 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2634 case '\020': /* ^P */
2635 if (*remaining == '\0') { /* ^P */
2636 PL_perldb = SvIV(sv);
2637 if (PL_perldb && !PL_DBsingle)
2640 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2642 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2646 case '\024': /* ^T */
2648 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2650 PL_basetime = (Time_t)SvIV(sv);
2653 case '\025': /* ^UTF8CACHE */
2654 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2655 PL_utf8cache = (signed char) sv_2iv(sv);
2658 case '\027': /* ^W & $^WARNING_BITS */
2659 if (*(mg->mg_ptr+1) == '\0') {
2660 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2662 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2663 | (i ? G_WARN_ON : G_WARN_OFF) ;
2666 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2667 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2668 if (!SvPOK(sv) && PL_localizing) {
2669 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2670 PL_compiling.cop_warnings = pWARN_NONE;
2675 int accumulate = 0 ;
2676 int any_fatals = 0 ;
2677 const char * const ptr = SvPV_const(sv, len) ;
2678 for (i = 0 ; i < len ; ++i) {
2679 accumulate |= ptr[i] ;
2680 any_fatals |= (ptr[i] & 0xAA) ;
2683 if (!specialWARN(PL_compiling.cop_warnings))
2684 PerlMemShared_free(PL_compiling.cop_warnings);
2685 PL_compiling.cop_warnings = pWARN_NONE;
2687 /* Yuck. I can't see how to abstract this: */
2688 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2689 WARN_ALL) && !any_fatals) {
2690 if (!specialWARN(PL_compiling.cop_warnings))
2691 PerlMemShared_free(PL_compiling.cop_warnings);
2692 PL_compiling.cop_warnings = pWARN_ALL;
2693 PL_dowarn |= G_WARN_ONCE ;
2697 const char *const p = SvPV_const(sv, len);
2699 PL_compiling.cop_warnings
2700 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2703 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2704 PL_dowarn |= G_WARN_ONCE ;
2712 if (PL_localizing) {
2713 if (PL_localizing == 1)
2714 SAVESPTR(PL_last_in_gv);
2716 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2717 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2720 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2721 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2722 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2725 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2726 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2727 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2730 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2733 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2734 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2735 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2738 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2742 IO * const io = GvIO(PL_defoutgv);
2745 if ((SvIV(sv)) == 0)
2746 IoFLAGS(io) &= ~IOf_FLUSH;
2748 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2749 PerlIO *ofp = IoOFP(io);
2751 (void)PerlIO_flush(ofp);
2752 IoFLAGS(io) |= IOf_FLUSH;
2758 SvREFCNT_dec(PL_rs);
2759 PL_rs = newSVsv(sv);
2762 SvREFCNT_dec(PL_ors_sv);
2763 if (SvOK(sv) || SvGMAGICAL(sv)) {
2764 PL_ors_sv = newSVsv(sv);
2772 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2775 #ifdef COMPLEX_STATUS
2776 if (PL_localizing == 2) {
2777 SvUPGRADE(sv, SVt_PVLV);
2778 PL_statusvalue = LvTARGOFF(sv);
2779 PL_statusvalue_vms = LvTARGLEN(sv);
2783 #ifdef VMSISH_STATUS
2785 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2788 STATUS_UNIX_EXIT_SET(SvIV(sv));
2793 # define PERL_VMS_BANG vaxc$errno
2795 # define PERL_VMS_BANG 0
2797 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2798 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2803 if (PL_delaymagic) {
2804 PL_delaymagic |= DM_RUID;
2805 break; /* don't do magic till later */
2808 (void)setruid((Uid_t)PL_uid);
2811 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2813 #ifdef HAS_SETRESUID
2814 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2816 if (PL_uid == PL_euid) { /* special case $< = $> */
2818 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2819 if (PL_uid != 0 && PerlProc_getuid() == 0)
2820 (void)PerlProc_setuid(0);
2822 (void)PerlProc_setuid(PL_uid);
2824 PL_uid = PerlProc_getuid();
2825 Perl_croak(aTHX_ "setruid() not implemented");
2830 PL_uid = PerlProc_getuid();
2834 if (PL_delaymagic) {
2835 PL_delaymagic |= DM_EUID;
2836 break; /* don't do magic till later */
2839 (void)seteuid((Uid_t)PL_euid);
2842 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2844 #ifdef HAS_SETRESUID
2845 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2847 if (PL_euid == PL_uid) /* special case $> = $< */
2848 PerlProc_setuid(PL_euid);
2850 PL_euid = PerlProc_geteuid();
2851 Perl_croak(aTHX_ "seteuid() not implemented");
2856 PL_euid = PerlProc_geteuid();
2860 if (PL_delaymagic) {
2861 PL_delaymagic |= DM_RGID;
2862 break; /* don't do magic till later */
2865 (void)setrgid((Gid_t)PL_gid);
2868 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2870 #ifdef HAS_SETRESGID
2871 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
2873 if (PL_gid == PL_egid) /* special case $( = $) */
2874 (void)PerlProc_setgid(PL_gid);
2876 PL_gid = PerlProc_getgid();
2877 Perl_croak(aTHX_ "setrgid() not implemented");
2882 PL_gid = PerlProc_getgid();
2885 #ifdef HAS_SETGROUPS
2887 const char *p = SvPV_const(sv, len);
2888 Groups_t *gary = NULL;
2889 #ifdef _SC_NGROUPS_MAX
2890 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2895 int maxgrp = NGROUPS;
2901 for (i = 0; i < maxgrp; ++i) {
2902 while (*p && !isSPACE(*p))
2909 Newx(gary, i + 1, Groups_t);
2911 Renew(gary, i + 1, Groups_t);
2915 (void)setgroups(i, gary);
2918 #else /* HAS_SETGROUPS */
2920 #endif /* HAS_SETGROUPS */
2921 if (PL_delaymagic) {
2922 PL_delaymagic |= DM_EGID;
2923 break; /* don't do magic till later */
2926 (void)setegid((Gid_t)PL_egid);
2929 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2931 #ifdef HAS_SETRESGID
2932 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2934 if (PL_egid == PL_gid) /* special case $) = $( */
2935 (void)PerlProc_setgid(PL_egid);
2937 PL_egid = PerlProc_getegid();
2938 Perl_croak(aTHX_ "setegid() not implemented");
2943 PL_egid = PerlProc_getegid();
2946 PL_chopset = SvPV_force(sv,len);
2949 /* Store the pid in mg->mg_obj so we can tell when a fork has
2950 occurred. mg->mg_obj points to *$ by default, so clear it. */
2951 if (isGV(mg->mg_obj)) {
2952 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2953 SvREFCNT_dec(mg->mg_obj);
2954 mg->mg_flags |= MGf_REFCOUNTED;
2955 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2957 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2960 LOCK_DOLLARZERO_MUTEX;
2961 #ifdef HAS_SETPROCTITLE
2962 /* The BSDs don't show the argv[] in ps(1) output, they
2963 * show a string from the process struct and provide
2964 * the setproctitle() routine to manipulate that. */
2965 if (PL_origalen != 1) {
2966 s = SvPV_const(sv, len);
2967 # if __FreeBSD_version > 410001
2968 /* The leading "-" removes the "perl: " prefix,
2969 * but not the "(perl) suffix from the ps(1)
2970 * output, because that's what ps(1) shows if the
2971 * argv[] is modified. */
2972 setproctitle("-%s", s);
2973 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2974 /* This doesn't really work if you assume that
2975 * $0 = 'foobar'; will wipe out 'perl' from the $0
2976 * because in ps(1) output the result will be like
2977 * sprintf("perl: %s (perl)", s)
2978 * I guess this is a security feature:
2979 * one (a user process) cannot get rid of the original name.
2981 setproctitle("%s", s);
2984 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2985 if (PL_origalen != 1) {
2987 s = SvPV_const(sv, len);
2988 un.pst_command = (char *)s;
2989 pstat(PSTAT_SETCMD, un, len, 0, 0);
2992 if (PL_origalen > 1) {
2993 /* PL_origalen is set in perl_parse(). */
2994 s = SvPV_force(sv,len);
2995 if (len >= (STRLEN)PL_origalen-1) {
2996 /* Longer than original, will be truncated. We assume that
2997 * PL_origalen bytes are available. */
2998 Copy(s, PL_origargv[0], PL_origalen-1, char);
3001 /* Shorter than original, will be padded. */
3003 /* Special case for Mac OS X: see [perl #38868] */
3006 /* Is the space counterintuitive? Yes.
3007 * (You were expecting \0?)
3008 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3010 const int pad = ' ';
3012 Copy(s, PL_origargv[0], len, char);
3013 PL_origargv[0][len] = 0;
3014 memset(PL_origargv[0] + len + 1,
3015 pad, PL_origalen - len - 1);
3017 PL_origargv[0][PL_origalen-1] = 0;
3018 for (i = 1; i < PL_origargc; i++)
3020 #ifdef HAS_PRCTL_SET_NAME
3021 /* Set the legacy process name in addition to the POSIX name on Linux */
3022 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3023 /* diag_listed_as: SKIPME */
3024 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3029 UNLOCK_DOLLARZERO_MUTEX;
3036 Perl_whichsig_sv(pTHX_ SV *sigsv)
3040 PERL_ARGS_ASSERT_WHICHSIG_SV;
3041 PERL_UNUSED_CONTEXT;
3042 sigpv = SvPV_const(sigsv, siglen);
3043 return whichsig_pvn(sigpv, siglen);
3047 Perl_whichsig_pv(pTHX_ const char *sig)
3049 PERL_ARGS_ASSERT_WHICHSIG_PV;
3050 PERL_UNUSED_CONTEXT;
3051 return whichsig_pvn(sig, strlen(sig));
3055 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3057 register char* const* sigv;
3059 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3060 PERL_UNUSED_CONTEXT;
3062 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3063 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3064 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3066 if (memEQs(sig, len, "CHLD"))
3070 if (memEQs(sig, len, "CLD"))
3077 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3078 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3080 Perl_sighandler(int sig)
3083 #ifdef PERL_GET_SIG_CONTEXT
3084 dTHXa(PERL_GET_SIG_CONTEXT);
3091 SV * const tSv = PL_Sv;
3095 XPV * const tXpv = PL_Xpv;
3096 I32 old_ss_ix = PL_savestack_ix;
3099 if (!PL_psig_ptr[sig]) {
3100 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3105 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3106 /* Max number of items pushed there is 3*n or 4. We cannot fix
3107 infinity, so we fix 4 (in fact 5): */
3108 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3110 PL_savestack_ix += 5; /* Protect save in progress. */
3111 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3114 /* sv_2cv is too complicated, try a simpler variant first: */
3115 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3116 || SvTYPE(cv) != SVt_PVCV) {
3118 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3121 if (!cv || !CvROOT(cv)) {
3122 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3123 PL_sig_name[sig], (gv ? GvENAME(gv)
3130 sv = PL_psig_name[sig]
3131 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3132 : newSVpv(PL_sig_name[sig],0);
3136 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3137 /* make sure our assumption about the size of the SAVEs are correct:
3138 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3139 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3142 PUSHSTACKi(PERLSI_SIGNAL);
3145 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3147 struct sigaction oact;
3149 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3152 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3153 /* The siginfo fields signo, code, errno, pid, uid,
3154 * addr, status, and band are defined by POSIX/SUSv3. */
3155 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3156 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3157 #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. */
3158 hv_stores(sih, "errno", newSViv(sip->si_errno));
3159 hv_stores(sih, "status", newSViv(sip->si_status));
3160 hv_stores(sih, "uid", newSViv(sip->si_uid));
3161 hv_stores(sih, "pid", newSViv(sip->si_pid));
3162 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3163 hv_stores(sih, "band", newSViv(sip->si_band));
3167 mPUSHp((char *)sip, sizeof(*sip));
3175 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3178 if (SvTRUE(ERRSV)) {
3180 /* Handler "died", for example to get out of a restart-able read().
3181 * Before we re-do that on its behalf re-enable the signal which was
3182 * blocked by the system when we entered.
3184 #ifdef HAS_SIGPROCMASK
3185 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3191 sigaddset(&set,sig);
3192 sigprocmask(SIG_UNBLOCK, &set, NULL);
3195 /* Not clear if this will work */
3196 (void)rsignal(sig, SIG_IGN);
3197 (void)rsignal(sig, PL_csighandlerp);
3199 #endif /* !PERL_MICRO */
3203 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3204 PL_savestack_ix = old_ss_ix;
3207 PL_op = myop; /* Apparently not needed... */
3209 PL_Sv = tSv; /* Restore global temporaries. */
3216 S_restore_magic(pTHX_ const void *p)
3219 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3220 SV* const sv = mgs->mgs_sv;
3226 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3228 #ifdef PERL_OLD_COPY_ON_WRITE
3229 /* While magic was saved (and off) sv_setsv may well have seen
3230 this SV as a prime candidate for COW. */
3232 sv_force_normal_flags(sv, 0);
3235 if (mgs->mgs_readonly)
3237 if (mgs->mgs_magical)
3238 SvFLAGS(sv) |= mgs->mgs_magical;
3241 if (SvGMAGICAL(sv)) {
3242 /* downgrade public flags to private,
3243 and discard any other private flags */
3245 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3247 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3248 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3253 bumped = mgs->mgs_bumped;
3254 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3256 /* If we're still on top of the stack, pop us off. (That condition
3257 * will be satisfied if restore_magic was called explicitly, but *not*
3258 * if it's being called via leave_scope.)
3259 * The reason for doing this is that otherwise, things like sv_2cv()
3260 * may leave alloc gunk on the savestack, and some code
3261 * (e.g. sighandler) doesn't expect that...
3263 if (PL_savestack_ix == mgs->mgs_ss_ix)
3265 UV popval = SSPOPUV;
3266 assert(popval == SAVEt_DESTRUCTOR_X);
3267 PL_savestack_ix -= 2;
3269 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3270 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3273 if (SvREFCNT(sv) == 1) {
3274 /* We hold the last reference to this SV, which implies that the
3275 SV was deleted as a side effect of the routines we called.
3276 So artificially keep it alive a bit longer.
3277 We avoid turning on the TEMP flag, which can cause the SV's
3278 buffer to get stolen (and maybe other stuff). */
3279 int was_temp = SvTEMP(sv);
3287 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3291 /* clean up the mess created by Perl_sighandler().
3292 * Note that this is only called during an exit in a signal handler;
3293 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3297 S_unwind_handler_stack(pTHX_ const void *p)
3302 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3306 =for apidoc magic_sethint
3308 Triggered by a store to %^H, records the key/value pair to
3309 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3310 anything that would need a deep copy. Maybe we should warn if we find a
3316 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3319 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3320 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3322 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3324 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3325 an alternative leaf in there, with PL_compiling.cop_hints being used if
3326 it's NULL. If needed for threads, the alternative could lock a mutex,
3327 or take other more complex action. */
3329 /* Something changed in %^H, so it will need to be restored on scope exit.
3330 Doing this here saves a lot of doing it manually in perl code (and
3331 forgetting to do it, and consequent subtle errors. */
3332 PL_hints |= HINT_LOCALIZE_HH;
3333 CopHINTHASH_set(&PL_compiling,
3334 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3339 =for apidoc magic_clearhint
3341 Triggered by a delete from %^H, records the key to
3342 C<PL_compiling.cop_hints_hash>.
3347 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3351 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3352 PERL_UNUSED_ARG(sv);
3354 assert(mg->mg_len == HEf_SVKEY);
3356 PERL_UNUSED_ARG(sv);
3358 PL_hints |= HINT_LOCALIZE_HH;
3359 CopHINTHASH_set(&PL_compiling,
3360 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3361 MUTABLE_SV(mg->mg_ptr), 0, 0));
3366 =for apidoc magic_clearhints
3368 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3373 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3375 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3376 PERL_UNUSED_ARG(sv);
3377 PERL_UNUSED_ARG(mg);
3378 cophh_free(CopHINTHASH_get(&PL_compiling));
3379 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3385 * c-indentation-style: bsd
3387 * indent-tabs-mode: t
3390 * ex: set ts=8 sts=4 sw=4 noet: