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 /* Turning READONLY off for a copy-on-write scalar (including shared
115 hash keys) is a bad idea. */
117 sv_force_normal_flags(sv, 0);
119 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
121 mgs = SSPTR(mgs_ix, MGS*);
123 mgs->mgs_magical = SvMAGICAL(sv);
124 mgs->mgs_readonly = SvREADONLY(sv) != 0;
125 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
126 mgs->mgs_bumped = bumped;
133 =for apidoc mg_magical
135 Turns on the magical status of an SV. See C<sv_magic>.
141 Perl_mg_magical(pTHX_ SV *sv)
144 PERL_ARGS_ASSERT_MG_MAGICAL;
148 if ((mg = SvMAGIC(sv))) {
150 const MGVTBL* const vtbl = mg->mg_virtual;
152 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
159 } while ((mg = mg->mg_moremagic));
160 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
168 Do magic after a value is retrieved from the SV. See C<sv_magic>.
174 Perl_mg_get(pTHX_ SV *sv)
177 const I32 mgs_ix = SSNEW(sizeof(MGS));
180 MAGIC *newmg, *head, *cur, *mg;
182 PERL_ARGS_ASSERT_MG_GET;
184 if (PL_localizing == 1 && sv == DEFSV) return 0;
186 /* We must call svt_get(sv, mg) for each valid entry in the linked
187 list of magic. svt_get() may delete the current entry, add new
188 magic to the head of the list, or upgrade the SV. AMS 20010810 */
190 newmg = cur = head = mg = SvMAGIC(sv);
192 const MGVTBL * const vtbl = mg->mg_virtual;
193 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
195 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
197 /* taint's mg get is so dumb it doesn't need flag saving */
198 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
199 save_magic(mgs_ix, sv);
203 vtbl->svt_get(aTHX_ sv, mg);
205 /* guard against magic having been deleted - eg FETCH calling
208 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
212 /* recalculate flags if this entry was deleted. */
213 if (mg->mg_flags & MGf_GSKIP)
214 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
220 /* Have we finished with the new entries we saw? Start again
221 where we left off (unless there are more new entries). */
229 /* Were any new entries added? */
230 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
234 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
239 restore_magic(INT2PTR(void *, (IV)mgs_ix));
247 Do magic after a value is assigned to the SV. See C<sv_magic>.
253 Perl_mg_set(pTHX_ SV *sv)
256 const I32 mgs_ix = SSNEW(sizeof(MGS));
260 PERL_ARGS_ASSERT_MG_SET;
262 if (PL_localizing == 2 && sv == DEFSV) return 0;
264 save_magic(mgs_ix, sv);
266 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
267 const MGVTBL* vtbl = mg->mg_virtual;
268 nextmg = mg->mg_moremagic; /* it may delete itself */
269 if (mg->mg_flags & MGf_GSKIP) {
270 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
271 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
273 if (PL_localizing == 2
274 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
276 if (vtbl && vtbl->svt_set)
277 vtbl->svt_set(aTHX_ sv, mg);
280 restore_magic(INT2PTR(void*, (IV)mgs_ix));
285 =for apidoc mg_length
287 Report on the SV's length. See C<sv_magic>.
293 Perl_mg_length(pTHX_ SV *sv)
299 PERL_ARGS_ASSERT_MG_LENGTH;
301 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
302 const MGVTBL * const vtbl = mg->mg_virtual;
303 if (vtbl && vtbl->svt_len) {
304 const I32 mgs_ix = SSNEW(sizeof(MGS));
305 save_magic(mgs_ix, sv);
306 /* omit MGf_GSKIP -- not changed here */
307 len = vtbl->svt_len(aTHX_ sv, mg);
308 restore_magic(INT2PTR(void*, (IV)mgs_ix));
314 /* You can't know whether it's UTF-8 until you get the string again...
316 const U8 *s = (U8*)SvPV_const(sv, len);
319 len = utf8_length(s, s + 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 register 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) )
637 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
641 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
644 register const REGEXP * const rx = PM_GETRE(PL_curpm);
646 register const I32 paren = mg->mg_len;
651 if (paren <= (I32)RX_NPARENS(rx) &&
652 (s = RX_OFFS(rx)[paren].start) != -1 &&
653 (t = RX_OFFS(rx)[paren].end) != -1)
656 if (mg->mg_obj) /* @+ */
661 if (i > 0 && RX_MATCH_UTF8(rx)) {
662 const char * const b = RX_SUBBEG(rx);
664 i = utf8_length((U8*)b, (U8*)(b+i));
675 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
677 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
680 Perl_croak_no_modify(aTHX);
681 NORETURN_FUNCTION_END;
685 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
690 register const REGEXP * rx;
691 const char * const remaining = mg->mg_ptr + 1;
693 PERL_ARGS_ASSERT_MAGIC_LEN;
695 switch (*mg->mg_ptr) {
697 if (*remaining == '\0') { /* ^P */
699 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
701 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
705 case '\015': /* $^MATCH */
706 if (strEQ(remaining, "ATCH")) {
713 paren = RX_BUFF_IDX_PREMATCH;
717 paren = RX_BUFF_IDX_POSTMATCH;
721 paren = RX_BUFF_IDX_FULLMATCH;
723 case '1': case '2': case '3': case '4':
724 case '5': case '6': case '7': case '8': case '9':
725 paren = atoi(mg->mg_ptr);
727 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
729 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
732 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
735 if (ckWARN(WARN_UNINITIALIZED))
740 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
741 paren = RX_LASTPAREN(rx);
746 case '\016': /* ^N */
747 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
748 paren = RX_LASTCLOSEPAREN(rx);
755 if (!SvPOK(sv) && SvNIOK(sv)) {
763 #define SvRTRIM(sv) STMT_START { \
765 STRLEN len = SvCUR(sv); \
766 char * const p = SvPVX(sv); \
767 while (len > 0 && isSPACE(p[len-1])) \
769 SvCUR_set(sv, len); \
775 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
777 PERL_ARGS_ASSERT_EMULATE_COP_IO;
779 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
780 sv_setsv(sv, &PL_sv_undef);
784 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
785 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
790 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
791 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
804 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
808 register const char *s = NULL;
810 const char * const remaining = mg->mg_ptr + 1;
811 const char nextchar = *remaining;
813 PERL_ARGS_ASSERT_MAGIC_GET;
815 switch (*mg->mg_ptr) {
816 case '\001': /* ^A */
817 sv_setsv(sv, PL_bodytarget);
818 if (SvTAINTED(PL_bodytarget))
821 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
822 if (nextchar == '\0') {
823 sv_setiv(sv, (IV)PL_minus_c);
825 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
826 sv_setiv(sv, (IV)STATUS_NATIVE);
830 case '\004': /* ^D */
831 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
833 case '\005': /* ^E */
834 if (nextchar == '\0') {
838 $DESCRIPTOR(msgdsc,msg);
839 sv_setnv(sv,(NV) vaxc$errno);
840 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
841 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
846 if (!(_emx_env & 0x200)) { /* Under DOS */
847 sv_setnv(sv, (NV)errno);
848 sv_setpv(sv, errno ? Strerror(errno) : "");
850 if (errno != errno_isOS2) {
851 const int tmp = _syserrno();
852 if (tmp) /* 2nd call to _syserrno() makes it 0 */
855 sv_setnv(sv, (NV)Perl_rc);
856 sv_setpv(sv, os2error(Perl_rc));
860 const DWORD dwErr = GetLastError();
861 sv_setnv(sv, (NV)dwErr);
863 PerlProc_GetOSError(sv, dwErr);
872 sv_setnv(sv, (NV)errno);
873 sv_setpv(sv, errno ? Strerror(errno) : "");
878 SvNOK_on(sv); /* what a wonderful hack! */
880 else if (strEQ(remaining, "NCODING"))
881 sv_setsv(sv, PL_encoding);
883 case '\006': /* ^F */
884 sv_setiv(sv, (IV)PL_maxsysfd);
886 case '\007': /* ^GLOBAL_PHASE */
887 if (strEQ(remaining, "LOBAL_PHASE")) {
888 sv_setpvn(sv, PL_phase_names[PL_phase],
889 strlen(PL_phase_names[PL_phase]));
892 case '\010': /* ^H */
893 sv_setiv(sv, (IV)PL_hints);
895 case '\011': /* ^I */ /* NOT \t in EBCDIC */
896 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
898 case '\017': /* ^O & ^OPEN */
899 if (nextchar == '\0') {
900 sv_setpv(sv, PL_osname);
903 else if (strEQ(remaining, "PEN")) {
904 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
908 if (nextchar == '\0') { /* ^P */
909 sv_setiv(sv, (IV)PL_perldb);
910 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
911 goto do_prematch_fetch;
912 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
913 goto do_postmatch_fetch;
916 case '\023': /* ^S */
917 if (nextchar == '\0') {
918 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
921 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
926 case '\024': /* ^T */
927 if (nextchar == '\0') {
929 sv_setnv(sv, PL_basetime);
931 sv_setiv(sv, (IV)PL_basetime);
934 else if (strEQ(remaining, "AINT"))
935 sv_setiv(sv, PL_tainting
936 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
939 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
940 if (strEQ(remaining, "NICODE"))
941 sv_setuv(sv, (UV) PL_unicode);
942 else if (strEQ(remaining, "TF8LOCALE"))
943 sv_setuv(sv, (UV) PL_utf8locale);
944 else if (strEQ(remaining, "TF8CACHE"))
945 sv_setiv(sv, (IV) PL_utf8cache);
947 case '\027': /* ^W & $^WARNING_BITS */
948 if (nextchar == '\0')
949 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
950 else if (strEQ(remaining, "ARNING_BITS")) {
951 if (PL_compiling.cop_warnings == pWARN_NONE) {
952 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
954 else if (PL_compiling.cop_warnings == pWARN_STD) {
955 sv_setsv(sv, &PL_sv_undef);
958 else if (PL_compiling.cop_warnings == pWARN_ALL) {
959 /* Get the bit mask for $warnings::Bits{all}, because
960 * it could have been extended by warnings::register */
961 HV * const bits = get_hv("warnings::Bits", 0);
962 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
964 sv_copypv(sv, *bits_all);
966 sv_setpvn(sv, WARN_ALLstring, WARNsize);
969 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
970 *PL_compiling.cop_warnings);
974 case '\015': /* $^MATCH */
975 if (strEQ(remaining, "ATCH")) {
976 case '1': case '2': case '3': case '4':
977 case '5': case '6': case '7': case '8': case '9': case '&':
978 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
980 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
981 * XXX Does the new way break anything?
983 paren = atoi(mg->mg_ptr); /* $& is in [0] */
984 CALLREG_NUMBUF_FETCH(rx,paren,sv);
987 sv_setsv(sv,&PL_sv_undef);
991 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
992 if (RX_LASTPAREN(rx)) {
993 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
997 sv_setsv(sv,&PL_sv_undef);
999 case '\016': /* ^N */
1000 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1001 if (RX_LASTCLOSEPAREN(rx)) {
1002 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1007 sv_setsv(sv,&PL_sv_undef);
1011 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1012 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1015 sv_setsv(sv,&PL_sv_undef);
1019 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1020 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1023 sv_setsv(sv,&PL_sv_undef);
1026 if (GvIO(PL_last_in_gv)) {
1027 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1032 sv_setiv(sv, (IV)STATUS_CURRENT);
1033 #ifdef COMPLEX_STATUS
1034 SvUPGRADE(sv, SVt_PVLV);
1035 LvTARGOFF(sv) = PL_statusvalue;
1036 LvTARGLEN(sv) = PL_statusvalue_vms;
1041 if (GvIOp(PL_defoutgv))
1042 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1046 sv_setpv(sv,GvENAME(PL_defoutgv));
1047 sv_catpvs(sv,"_TOP");
1051 if (GvIOp(PL_defoutgv))
1052 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1054 s = GvENAME(PL_defoutgv);
1058 if (GvIO(PL_defoutgv))
1059 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1062 if (GvIO(PL_defoutgv))
1063 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1066 if (GvIO(PL_defoutgv))
1067 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1077 if (GvIO(PL_defoutgv))
1078 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1082 sv_copypv(sv, PL_ors_sv);
1084 sv_setsv(sv, &PL_sv_undef);
1088 IV const pid = (IV)PerlProc_getpid();
1089 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1090 /* never set manually, or at least not since last fork */
1092 /* never unsafe, even if reading in a tainted expression */
1095 /* else a value has been assigned manually, so do nothing */
1103 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1105 sv_setnv(sv, (NV)errno);
1108 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1109 sv_setpv(sv, os2error(Perl_rc));
1112 sv_setpv(sv, errno ? Strerror(errno) : "");
1117 SvNOK_on(sv); /* what a wonderful hack! */
1120 sv_setiv(sv, (IV)PerlProc_getuid());
1123 sv_setiv(sv, (IV)PerlProc_geteuid());
1126 sv_setiv(sv, (IV)PerlProc_getgid());
1129 sv_setiv(sv, (IV)PerlProc_getegid());
1131 #ifdef HAS_GETGROUPS
1133 Groups_t *gary = NULL;
1134 I32 i, num_groups = getgroups(0, gary);
1135 Newx(gary, num_groups, Groups_t);
1136 num_groups = getgroups(num_groups, gary);
1137 for (i = 0; i < num_groups; i++)
1138 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1141 (void)SvIOK_on(sv); /* what a wonderful hack! */
1151 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1153 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1155 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1157 if (uf && uf->uf_val)
1158 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1163 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1166 STRLEN len = 0, klen;
1167 const char * const key = MgPV_const(mg,klen);
1170 PERL_ARGS_ASSERT_MAGIC_SETENV;
1173 s = SvPV_const(sv,len);
1174 SvPOK_only(sv); /* environment variables are strings, period */
1176 my_setenv(key, s); /* does the deed */
1178 #ifdef DYNAMIC_ENV_FETCH
1179 /* We just undefd an environment var. Is a replacement */
1180 /* waiting in the wings? */
1182 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1184 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1188 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1189 /* And you'll never guess what the dog had */
1190 /* in its mouth... */
1192 MgTAINTEDDIR_off(mg);
1194 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1195 char pathbuf[256], eltbuf[256], *cp, *elt;
1198 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1200 do { /* DCL$PATH may be a search list */
1201 while (1) { /* as may dev portion of any element */
1202 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1203 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1204 cando_by_name(S_IWUSR,0,elt) ) {
1205 MgTAINTEDDIR_on(mg);
1209 if ((cp = strchr(elt, ':')) != NULL)
1211 if (my_trnlnm(elt, eltbuf, j++))
1217 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1220 if (s && klen == 4 && strEQ(key,"PATH")) {
1221 const char * const strend = s + len;
1223 while (s < strend) {
1227 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1228 const char path_sep = '|';
1230 const char path_sep = ':';
1232 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1233 s, strend, path_sep, &i);
1235 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1237 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1239 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1241 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1242 MgTAINTEDDIR_on(mg);
1248 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1254 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1256 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1257 PERL_UNUSED_ARG(sv);
1258 my_setenv(MgPV_nolen_const(mg),NULL);
1263 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1266 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1267 PERL_UNUSED_ARG(mg);
1269 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1271 if (PL_localizing) {
1274 hv_iterinit(MUTABLE_HV(sv));
1275 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1277 my_setenv(hv_iterkey(entry, &keylen),
1278 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1286 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1289 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1290 PERL_UNUSED_ARG(sv);
1291 PERL_UNUSED_ARG(mg);
1293 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1301 #ifdef HAS_SIGPROCMASK
1303 restore_sigmask(pTHX_ SV *save_sv)
1305 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1306 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1310 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1313 /* Are we fetching a signal entry? */
1314 int i = (I16)mg->mg_private;
1316 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1320 const char * sig = MgPV_const(mg, siglen);
1321 mg->mg_private = i = whichsig_pvn(sig, siglen);
1326 sv_setsv(sv,PL_psig_ptr[i]);
1328 Sighandler_t sigstate = rsignal_state(i);
1329 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1330 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1333 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1334 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1337 /* cache state so we don't fetch it again */
1338 if(sigstate == (Sighandler_t) SIG_IGN)
1339 sv_setpvs(sv,"IGNORE");
1341 sv_setsv(sv,&PL_sv_undef);
1342 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1349 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1351 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1353 magic_setsig(NULL, mg);
1354 return sv_unmagic(sv, mg->mg_type);
1358 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1359 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1361 Perl_csighandler(int sig)
1364 #ifdef PERL_GET_SIG_CONTEXT
1365 dTHXa(PERL_GET_SIG_CONTEXT);
1369 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1370 (void) rsignal(sig, PL_csighandlerp);
1371 if (PL_sig_ignoring[sig]) return;
1373 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1374 if (PL_sig_defaulting[sig])
1375 #ifdef KILL_BY_SIGPRC
1376 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1391 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1392 /* Call the perl level handler now--
1393 * with risk we may be in malloc() or being destructed etc. */
1394 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1395 (*PL_sighandlerp)(sig, NULL, NULL);
1397 (*PL_sighandlerp)(sig);
1400 if (!PL_psig_pend) return;
1401 /* Set a flag to say this signal is pending, that is awaiting delivery after
1402 * the current Perl opcode completes */
1403 PL_psig_pend[sig]++;
1405 #ifndef SIG_PENDING_DIE_COUNT
1406 # define SIG_PENDING_DIE_COUNT 120
1408 /* Add one to say _a_ signal is pending */
1409 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1410 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1411 (unsigned long)SIG_PENDING_DIE_COUNT);
1415 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1417 Perl_csighandler_init(void)
1420 if (PL_sig_handlers_initted) return;
1422 for (sig = 1; sig < SIG_SIZE; sig++) {
1423 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1425 PL_sig_defaulting[sig] = 1;
1426 (void) rsignal(sig, PL_csighandlerp);
1428 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1429 PL_sig_ignoring[sig] = 0;
1432 PL_sig_handlers_initted = 1;
1436 #if defined HAS_SIGPROCMASK
1438 unblock_sigmask(pTHX_ void* newset)
1440 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1445 Perl_despatch_signals(pTHX)
1450 for (sig = 1; sig < SIG_SIZE; sig++) {
1451 if (PL_psig_pend[sig]) {
1453 #ifdef HAS_SIGPROCMASK
1454 /* From sigaction(2) (FreeBSD man page):
1455 * | Signal routines normally execute with the signal that
1456 * | caused their invocation blocked, but other signals may
1458 * Emulation of this behavior (from within Perl) is enabled
1462 sigset_t newset, oldset;
1464 sigemptyset(&newset);
1465 sigaddset(&newset, sig);
1466 sigprocmask(SIG_BLOCK, &newset, &oldset);
1467 was_blocked = sigismember(&oldset, sig);
1469 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1471 SAVEFREESV(save_sv);
1472 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1475 PL_psig_pend[sig] = 0;
1476 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1477 (*PL_sighandlerp)(sig, NULL, NULL);
1479 (*PL_sighandlerp)(sig);
1481 #ifdef HAS_SIGPROCMASK
1490 /* sv of NULL signifies that we're acting as magic_clearsig. */
1492 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1497 /* Need to be careful with SvREFCNT_dec(), because that can have side
1498 * effects (due to closures). We must make sure that the new disposition
1499 * is in place before it is called.
1503 #ifdef HAS_SIGPROCMASK
1507 register const char *s = MgPV_const(mg,len);
1509 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1512 if (memEQs(s, len, "__DIE__"))
1514 else if (memEQs(s, len, "__WARN__")
1515 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1516 /* Merge the existing behaviours, which are as follows:
1517 magic_setsig, we always set svp to &PL_warnhook
1518 (hence we always change the warnings handler)
1519 For magic_clearsig, we don't change the warnings handler if it's
1520 set to the &PL_warnhook. */
1523 SV *tmp = sv_newmortal();
1524 Perl_croak(aTHX_ "No such hook: %s",
1525 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1529 if (*svp != PERL_WARNHOOK_FATAL)
1535 i = (I16)mg->mg_private;
1537 i = whichsig_pvn(s, len); /* ...no, a brick */
1538 mg->mg_private = (U16)i;
1542 SV *tmp = sv_newmortal();
1543 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1544 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1548 #ifdef HAS_SIGPROCMASK
1549 /* Avoid having the signal arrive at a bad time, if possible. */
1552 sigprocmask(SIG_BLOCK, &set, &save);
1554 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1555 SAVEFREESV(save_sv);
1556 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1559 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1560 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1562 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1563 PL_sig_ignoring[i] = 0;
1565 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1566 PL_sig_defaulting[i] = 0;
1568 to_dec = PL_psig_ptr[i];
1570 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1571 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1573 /* Signals don't change name during the program's execution, so once
1574 they're cached in the appropriate slot of PL_psig_name, they can
1577 Ideally we'd find some way of making SVs at (C) compile time, or
1578 at least, doing most of the work. */
1579 if (!PL_psig_name[i]) {
1580 PL_psig_name[i] = newSVpvn(s, len);
1581 SvREADONLY_on(PL_psig_name[i]);
1584 SvREFCNT_dec(PL_psig_name[i]);
1585 PL_psig_name[i] = NULL;
1586 PL_psig_ptr[i] = NULL;
1589 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1591 (void)rsignal(i, PL_csighandlerp);
1594 *svp = SvREFCNT_inc_simple_NN(sv);
1596 if (sv && SvOK(sv)) {
1597 s = SvPV_force(sv, len);
1601 if (sv && memEQs(s, len,"IGNORE")) {
1603 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1604 PL_sig_ignoring[i] = 1;
1605 (void)rsignal(i, PL_csighandlerp);
1607 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1611 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1613 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1614 PL_sig_defaulting[i] = 1;
1615 (void)rsignal(i, PL_csighandlerp);
1617 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1623 * We should warn if HINT_STRICT_REFS, but without
1624 * access to a known hint bit in a known OP, we can't
1625 * tell whether HINT_STRICT_REFS is in force or not.
1627 if (!strchr(s,':') && !strchr(s,'\''))
1628 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1631 (void)rsignal(i, PL_csighandlerp);
1633 *svp = SvREFCNT_inc_simple_NN(sv);
1637 #ifdef HAS_SIGPROCMASK
1641 SvREFCNT_dec(to_dec);
1644 #endif /* !PERL_MICRO */
1647 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1650 PERL_ARGS_ASSERT_MAGIC_SETISA;
1651 PERL_UNUSED_ARG(sv);
1653 /* Skip _isaelem because _isa will handle it shortly */
1654 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1657 return magic_clearisa(NULL, mg);
1660 /* sv of NULL signifies that we're acting as magic_setisa. */
1662 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1667 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1669 /* Bail out if destruction is going on */
1670 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1673 av_clear(MUTABLE_AV(sv));
1675 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1676 /* This occurs with setisa_elem magic, which calls this
1678 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1680 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1681 SV **svp = AvARRAY((AV *)mg->mg_obj);
1682 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1684 stash = GvSTASH((GV *)*svp++);
1685 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1692 (const GV *)mg->mg_obj
1695 /* The stash may have been detached from the symbol table, so check its
1696 name before doing anything. */
1697 if (stash && HvENAME_get(stash))
1698 mro_isa_changed_in(stash);
1704 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1706 HV * const hv = MUTABLE_HV(LvTARG(sv));
1709 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1710 PERL_UNUSED_ARG(mg);
1713 (void) hv_iterinit(hv);
1714 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1717 while (hv_iternext(hv))
1722 sv_setiv(sv, (IV)i);
1727 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1729 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1730 PERL_UNUSED_ARG(mg);
1732 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1738 =for apidoc magic_methcall
1740 Invoke a magic method (like FETCH).
1742 C<sv> and C<mg> are the tied thingy and the tie magic.
1744 C<meth> is the name of the method to call.
1746 C<argc> is the number of args (in addition to $self) to pass to the method.
1748 The C<flags> can be:
1750 G_DISCARD invoke method with G_DISCARD flag and don't
1752 G_UNDEF_FILL fill the stack with argc pointers to
1755 The arguments themselves are any values following the C<flags> argument.
1757 Returns the SV (if any) returned by the method, or NULL on failure.
1764 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1771 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1775 if (flags & G_WRITING_TO_STDERR) {
1779 SAVESPTR(PL_stderrgv);
1783 PUSHSTACKi(PERLSI_MAGIC);
1787 PUSHs(SvTIED_obj(sv, mg));
1788 if (flags & G_UNDEF_FILL) {
1790 PUSHs(&PL_sv_undef);
1792 } else if (argc > 0) {
1794 va_start(args, argc);
1797 SV *const sv = va_arg(args, SV *);
1804 if (flags & G_DISCARD) {
1805 call_method(meth, G_SCALAR|G_DISCARD);
1808 if (call_method(meth, G_SCALAR))
1809 ret = *PL_stack_sp--;
1812 if (flags & G_WRITING_TO_STDERR)
1819 /* wrapper for magic_methcall that creates the first arg */
1822 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1828 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1831 if (mg->mg_len >= 0) {
1832 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1834 else if (mg->mg_len == HEf_SVKEY)
1835 arg1 = MUTABLE_SV(mg->mg_ptr);
1837 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1838 arg1 = newSViv((IV)(mg->mg_len));
1842 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1844 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1848 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1853 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1855 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1862 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1864 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1866 if (mg->mg_type == PERL_MAGIC_tiedelem)
1867 mg->mg_flags |= MGf_GSKIP;
1868 magic_methpack(sv,mg,"FETCH");
1873 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1879 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1881 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1882 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1883 * public flags indicate its value based on copying from $val. Doing
1884 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1885 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1886 * wrong if $val happened to be tainted, as sv hasn't got magic
1887 * enabled, even though taint magic is in the chain. In which case,
1888 * fake up a temporary tainted value (this is easier than temporarily
1889 * re-enabling magic on sv). */
1891 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1892 && (tmg->mg_len & 1))
1894 val = sv_mortalcopy(sv);
1900 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1905 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1907 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1909 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1910 return magic_methpack(sv,mg,"DELETE");
1915 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1921 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1923 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1925 retval = SvIV(retsv)-1;
1927 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1929 return (U32) retval;
1933 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1937 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1939 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1944 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1949 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1951 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1952 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1959 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1961 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1963 return magic_methpack(sv,mg,"EXISTS");
1967 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1971 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1972 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1974 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1976 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1978 if (HvEITER_get(hv))
1979 /* we are in an iteration so the hash cannot be empty */
1981 /* no xhv_eiter so now use FIRSTKEY */
1982 key = sv_newmortal();
1983 magic_nextpack(MUTABLE_SV(hv), mg, key);
1984 HvEITER_set(hv, NULL); /* need to reset iterator */
1985 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1988 /* there is a SCALAR method that we can call */
1989 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1991 retval = &PL_sv_undef;
1996 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1999 GV * const gv = PL_DBline;
2000 const I32 i = SvTRUE(sv);
2001 SV ** const svp = av_fetch(GvAV(gv),
2002 atoi(MgPV_nolen_const(mg)), FALSE);
2004 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2006 if (svp && SvIOKp(*svp)) {
2007 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2009 /* set or clear breakpoint in the relevant control op */
2011 o->op_flags |= OPf_SPECIAL;
2013 o->op_flags &= ~OPf_SPECIAL;
2020 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2023 AV * const obj = MUTABLE_AV(mg->mg_obj);
2025 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2028 sv_setiv(sv, AvFILL(obj));
2036 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2039 AV * const obj = MUTABLE_AV(mg->mg_obj);
2041 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2044 av_fill(obj, SvIV(sv));
2046 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2047 "Attempt to set length of freed array");
2053 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2057 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2058 PERL_UNUSED_ARG(sv);
2060 /* Reset the iterator when the array is cleared */
2061 #if IVSIZE == I32SIZE
2062 *((IV *) &(mg->mg_len)) = 0;
2065 *((IV *) mg->mg_ptr) = 0;
2072 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2076 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2077 PERL_UNUSED_ARG(sv);
2079 /* during global destruction, mg_obj may already have been freed */
2080 if (PL_in_clean_all)
2083 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2086 /* arylen scalar holds a pointer back to the array, but doesn't own a
2087 reference. Hence the we (the array) are about to go away with it
2088 still pointing at us. Clear its pointer, else it would be pointing
2089 at free memory. See the comment in sv_magic about reference loops,
2090 and why it can't own a reference to us. */
2097 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2100 SV* const lsv = LvTARG(sv);
2102 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2103 PERL_UNUSED_ARG(mg);
2105 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2106 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2107 if (found && found->mg_len >= 0) {
2108 I32 i = found->mg_len;
2110 sv_pos_b2u(lsv, &i);
2120 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2123 SV* const lsv = LvTARG(sv);
2129 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2130 PERL_UNUSED_ARG(mg);
2132 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2133 found = mg_find(lsv, PERL_MAGIC_regex_global);
2139 #ifdef PERL_OLD_COPY_ON_WRITE
2141 sv_force_normal_flags(lsv, 0);
2143 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2146 else if (!SvOK(sv)) {
2150 len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv);
2155 ulen = sv_len_utf8(lsv);
2165 else if (pos > (SSize_t)len)
2170 sv_pos_u2b(lsv, &p, 0);
2174 found->mg_len = pos;
2175 found->mg_flags &= ~MGf_MINMATCH;
2181 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2184 SV * const lsv = LvTARG(sv);
2185 const char * const tmps = SvPV_const(lsv,len);
2186 STRLEN offs = LvTARGOFF(sv);
2187 STRLEN rem = LvTARGLEN(sv);
2188 const bool negoff = LvFLAGS(sv) & 1;
2189 const bool negrem = LvFLAGS(sv) & 2;
2191 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2192 PERL_UNUSED_ARG(mg);
2194 if (!translate_substr_offsets(
2195 SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
2196 negoff ? -(IV)offs : (IV)offs, !negoff,
2197 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2199 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2200 sv_setsv_nomg(sv, &PL_sv_undef);
2205 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2206 sv_setpvn(sv, tmps + offs, rem);
2213 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2216 STRLEN len, lsv_len, oldtarglen, newtarglen;
2217 const char * const tmps = SvPV_const(sv, len);
2218 SV * const lsv = LvTARG(sv);
2219 STRLEN lvoff = LvTARGOFF(sv);
2220 STRLEN lvlen = LvTARGLEN(sv);
2221 const bool negoff = LvFLAGS(sv) & 1;
2222 const bool neglen = LvFLAGS(sv) & 2;
2224 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2225 PERL_UNUSED_ARG(mg);
2229 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2230 "Attempt to use reference as lvalue in substr"
2232 if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
2233 else (void)SvPV_nomg(lsv,lsv_len);
2234 if (!translate_substr_offsets(
2236 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2237 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2239 Perl_croak(aTHX_ "substr outside of string");
2242 sv_utf8_upgrade(lsv);
2243 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2244 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2245 newtarglen = sv_len_utf8(sv);
2248 else if (lsv && SvUTF8(lsv)) {
2250 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2252 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2253 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2257 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2260 if (!neglen) LvTARGLEN(sv) = newtarglen;
2261 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2267 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2271 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2272 PERL_UNUSED_ARG(sv);
2274 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2279 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2283 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2284 PERL_UNUSED_ARG(sv);
2286 /* update taint status */
2295 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2297 SV * const lsv = LvTARG(sv);
2299 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2300 PERL_UNUSED_ARG(mg);
2303 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2311 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2313 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2314 PERL_UNUSED_ARG(mg);
2315 do_vecset(sv); /* XXX slurp this routine */
2320 Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
2322 PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
2325 SV * const vecsv = sv_newmortal();
2326 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
2327 if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
2329 return sv_unmagic(sv, mg->mg_type);
2333 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2338 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2340 if (LvTARGLEN(sv)) {
2342 SV * const ahv = LvTARG(sv);
2343 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2348 AV *const av = MUTABLE_AV(LvTARG(sv));
2349 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2350 targ = AvARRAY(av)[LvTARGOFF(sv)];
2352 if (targ && (targ != &PL_sv_undef)) {
2353 /* somebody else defined it for us */
2354 SvREFCNT_dec(LvTARG(sv));
2355 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2357 SvREFCNT_dec(mg->mg_obj);
2359 mg->mg_flags &= ~MGf_REFCOUNTED;
2364 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2369 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2371 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2372 PERL_UNUSED_ARG(mg);
2376 sv_setsv(LvTARG(sv), sv);
2377 SvSETMAGIC(LvTARG(sv));
2383 Perl_vivify_defelem(pTHX_ SV *sv)
2389 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2391 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2394 SV * const ahv = LvTARG(sv);
2395 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2398 if (!value || value == &PL_sv_undef)
2399 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2402 AV *const av = MUTABLE_AV(LvTARG(sv));
2403 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2404 LvTARG(sv) = NULL; /* array can't be extended */
2406 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2407 if (!svp || (value = *svp) == &PL_sv_undef)
2408 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2411 SvREFCNT_inc_simple_void(value);
2412 SvREFCNT_dec(LvTARG(sv));
2415 SvREFCNT_dec(mg->mg_obj);
2417 mg->mg_flags &= ~MGf_REFCOUNTED;
2421 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2423 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2424 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2429 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2431 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2432 PERL_UNUSED_CONTEXT;
2433 PERL_UNUSED_ARG(sv);
2439 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2441 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2443 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2445 if (uf && uf->uf_set)
2446 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2451 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2453 const char type = mg->mg_type;
2455 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2457 if (type == PERL_MAGIC_qr) {
2458 } else if (type == PERL_MAGIC_bm) {
2462 assert(type == PERL_MAGIC_fm);
2464 return sv_unmagic(sv, type);
2467 #ifdef USE_LOCALE_COLLATE
2469 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2471 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2474 * RenE<eacute> Descartes said "I think not."
2475 * and vanished with a faint plop.
2477 PERL_UNUSED_CONTEXT;
2478 PERL_UNUSED_ARG(sv);
2480 Safefree(mg->mg_ptr);
2486 #endif /* USE_LOCALE_COLLATE */
2488 /* Just clear the UTF-8 cache data. */
2490 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2492 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2493 PERL_UNUSED_CONTEXT;
2494 PERL_UNUSED_ARG(sv);
2495 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2497 mg->mg_len = -1; /* The mg_len holds the len cache. */
2502 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2505 register const char *s;
2507 register const REGEXP * rx;
2508 const char * const remaining = mg->mg_ptr + 1;
2513 PERL_ARGS_ASSERT_MAGIC_SET;
2515 switch (*mg->mg_ptr) {
2516 case '\015': /* $^MATCH */
2517 if (strEQ(remaining, "ATCH"))
2519 case '`': /* ${^PREMATCH} caught below */
2521 paren = RX_BUFF_IDX_PREMATCH;
2523 case '\'': /* ${^POSTMATCH} caught below */
2525 paren = RX_BUFF_IDX_POSTMATCH;
2529 paren = RX_BUFF_IDX_FULLMATCH;
2531 case '1': case '2': case '3': case '4':
2532 case '5': case '6': case '7': case '8': case '9':
2533 paren = atoi(mg->mg_ptr);
2535 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2537 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2539 /* Croak with a READONLY error when a numbered match var is
2540 * set without a previous pattern match. Unless it's C<local $1>
2543 if (!PL_localizing) {
2544 Perl_croak_no_modify(aTHX);
2548 case '\001': /* ^A */
2549 sv_setsv(PL_bodytarget, sv);
2550 FmLINES(PL_bodytarget) = 0;
2551 if (SvPOK(PL_bodytarget)) {
2552 char *s = SvPVX(PL_bodytarget);
2553 while ( ((s = strchr(s, '\n'))) ) {
2554 FmLINES(PL_bodytarget)++;
2558 /* mg_set() has temporarily made sv non-magical */
2560 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2561 SvTAINTED_on(PL_bodytarget);
2563 SvTAINTED_off(PL_bodytarget);
2566 case '\003': /* ^C */
2567 PL_minus_c = cBOOL(SvIV(sv));
2570 case '\004': /* ^D */
2572 s = SvPV_nolen_const(sv);
2573 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2574 if (DEBUG_x_TEST || DEBUG_B_TEST)
2575 dump_all_perl(!DEBUG_B_TEST);
2577 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2580 case '\005': /* ^E */
2581 if (*(mg->mg_ptr+1) == '\0') {
2583 set_vaxc_errno(SvIV(sv));
2586 SetLastError( SvIV(sv) );
2589 os2_setsyserrno(SvIV(sv));
2591 /* will anyone ever use this? */
2592 SETERRNO(SvIV(sv), 4);
2597 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2598 SvREFCNT_dec(PL_encoding);
2599 if (SvOK(sv) || SvGMAGICAL(sv)) {
2600 PL_encoding = newSVsv(sv);
2607 case '\006': /* ^F */
2608 PL_maxsysfd = SvIV(sv);
2610 case '\010': /* ^H */
2611 PL_hints = SvIV(sv);
2613 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2614 Safefree(PL_inplace);
2615 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2617 case '\016': /* ^N */
2618 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2619 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2621 case '\017': /* ^O */
2622 if (*(mg->mg_ptr+1) == '\0') {
2623 Safefree(PL_osname);
2626 TAINT_PROPER("assigning to $^O");
2627 PL_osname = savesvpv(sv);
2630 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2632 const char *const start = SvPV(sv, len);
2633 const char *out = (const char*)memchr(start, '\0', len);
2637 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2638 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2640 /* Opening for input is more common than opening for output, so
2641 ensure that hints for input are sooner on linked list. */
2642 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2644 : newSVpvs_flags("", SvUTF8(sv));
2645 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2648 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2650 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2654 case '\020': /* ^P */
2655 if (*remaining == '\0') { /* ^P */
2656 PL_perldb = SvIV(sv);
2657 if (PL_perldb && !PL_DBsingle)
2660 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2662 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2666 case '\024': /* ^T */
2668 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2670 PL_basetime = (Time_t)SvIV(sv);
2673 case '\025': /* ^UTF8CACHE */
2674 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2675 PL_utf8cache = (signed char) sv_2iv(sv);
2678 case '\027': /* ^W & $^WARNING_BITS */
2679 if (*(mg->mg_ptr+1) == '\0') {
2680 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2682 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2683 | (i ? G_WARN_ON : G_WARN_OFF) ;
2686 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2687 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2689 PL_compiling.cop_warnings = pWARN_STD;
2694 int accumulate = 0 ;
2695 int any_fatals = 0 ;
2696 const char * const ptr = SvPV_const(sv, len) ;
2697 for (i = 0 ; i < len ; ++i) {
2698 accumulate |= ptr[i] ;
2699 any_fatals |= (ptr[i] & 0xAA) ;
2702 if (!specialWARN(PL_compiling.cop_warnings))
2703 PerlMemShared_free(PL_compiling.cop_warnings);
2704 PL_compiling.cop_warnings = pWARN_NONE;
2706 /* Yuck. I can't see how to abstract this: */
2707 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2708 WARN_ALL) && !any_fatals) {
2709 if (!specialWARN(PL_compiling.cop_warnings))
2710 PerlMemShared_free(PL_compiling.cop_warnings);
2711 PL_compiling.cop_warnings = pWARN_ALL;
2712 PL_dowarn |= G_WARN_ONCE ;
2716 const char *const p = SvPV_const(sv, len);
2718 PL_compiling.cop_warnings
2719 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2722 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2723 PL_dowarn |= G_WARN_ONCE ;
2731 if (PL_localizing) {
2732 if (PL_localizing == 1)
2733 SAVESPTR(PL_last_in_gv);
2735 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2736 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2739 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2740 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2741 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2744 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2745 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2746 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2749 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2752 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2753 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2754 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2757 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2761 IO * const io = GvIO(PL_defoutgv);
2764 if ((SvIV(sv)) == 0)
2765 IoFLAGS(io) &= ~IOf_FLUSH;
2767 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2768 PerlIO *ofp = IoOFP(io);
2770 (void)PerlIO_flush(ofp);
2771 IoFLAGS(io) |= IOf_FLUSH;
2777 SvREFCNT_dec(PL_rs);
2778 PL_rs = newSVsv(sv);
2781 SvREFCNT_dec(PL_ors_sv);
2783 PL_ors_sv = newSVsv(sv);
2791 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2794 #ifdef COMPLEX_STATUS
2795 if (PL_localizing == 2) {
2796 SvUPGRADE(sv, SVt_PVLV);
2797 PL_statusvalue = LvTARGOFF(sv);
2798 PL_statusvalue_vms = LvTARGLEN(sv);
2802 #ifdef VMSISH_STATUS
2804 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2807 STATUS_UNIX_EXIT_SET(SvIV(sv));
2812 # define PERL_VMS_BANG vaxc$errno
2814 # define PERL_VMS_BANG 0
2816 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2817 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2822 const IV new_uid = SvIV(sv);
2823 PL_delaymagic_uid = new_uid;
2824 if (PL_delaymagic) {
2825 PL_delaymagic |= DM_RUID;
2826 break; /* don't do magic till later */
2829 (void)setruid((Uid_t)new_uid);
2832 (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2834 #ifdef HAS_SETRESUID
2835 (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2837 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2839 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2840 if (new_uid != 0 && PerlProc_getuid() == 0)
2841 (void)PerlProc_setuid(0);
2843 (void)PerlProc_setuid(new_uid);
2845 Perl_croak(aTHX_ "setruid() not implemented");
2854 const UV new_euid = SvIV(sv);
2855 PL_delaymagic_euid = new_euid;
2856 if (PL_delaymagic) {
2857 PL_delaymagic |= DM_EUID;
2858 break; /* don't do magic till later */
2861 (void)seteuid((Uid_t)new_euid);
2864 (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2866 #ifdef HAS_SETRESUID
2867 (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2869 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2870 PerlProc_setuid(new_euid);
2872 Perl_croak(aTHX_ "seteuid() not implemented");
2881 const UV new_gid = SvIV(sv);
2882 PL_delaymagic_gid = new_gid;
2883 if (PL_delaymagic) {
2884 PL_delaymagic |= DM_RGID;
2885 break; /* don't do magic till later */
2888 (void)setrgid((Gid_t)new_gid);
2891 (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2893 #ifdef HAS_SETRESGID
2894 (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2896 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2897 (void)PerlProc_setgid(new_gid);
2899 Perl_croak(aTHX_ "setrgid() not implemented");
2909 #ifdef HAS_SETGROUPS
2911 const char *p = SvPV_const(sv, len);
2912 Groups_t *gary = NULL;
2913 #ifdef _SC_NGROUPS_MAX
2914 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2919 int maxgrp = NGROUPS;
2925 for (i = 0; i < maxgrp; ++i) {
2926 while (*p && !isSPACE(*p))
2933 Newx(gary, i + 1, Groups_t);
2935 Renew(gary, i + 1, Groups_t);
2939 (void)setgroups(i, gary);
2942 #else /* HAS_SETGROUPS */
2943 new_egid = SvIV(sv);
2944 #endif /* HAS_SETGROUPS */
2945 PL_delaymagic_egid = new_egid;
2946 if (PL_delaymagic) {
2947 PL_delaymagic |= DM_EGID;
2948 break; /* don't do magic till later */
2951 (void)setegid((Gid_t)new_egid);
2954 (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2956 #ifdef HAS_SETRESGID
2957 (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2959 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2960 (void)PerlProc_setgid(new_egid);
2962 Perl_croak(aTHX_ "setegid() not implemented");
2970 PL_chopset = SvPV_force(sv,len);
2973 /* Store the pid in mg->mg_obj so we can tell when a fork has
2974 occurred. mg->mg_obj points to *$ by default, so clear it. */
2975 if (isGV(mg->mg_obj)) {
2976 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2977 SvREFCNT_dec(mg->mg_obj);
2978 mg->mg_flags |= MGf_REFCOUNTED;
2979 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2981 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2984 LOCK_DOLLARZERO_MUTEX;
2985 #ifdef HAS_SETPROCTITLE
2986 /* The BSDs don't show the argv[] in ps(1) output, they
2987 * show a string from the process struct and provide
2988 * the setproctitle() routine to manipulate that. */
2989 if (PL_origalen != 1) {
2990 s = SvPV_const(sv, len);
2991 # if __FreeBSD_version > 410001
2992 /* The leading "-" removes the "perl: " prefix,
2993 * but not the "(perl) suffix from the ps(1)
2994 * output, because that's what ps(1) shows if the
2995 * argv[] is modified. */
2996 setproctitle("-%s", s);
2997 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2998 /* This doesn't really work if you assume that
2999 * $0 = 'foobar'; will wipe out 'perl' from the $0
3000 * because in ps(1) output the result will be like
3001 * sprintf("perl: %s (perl)", s)
3002 * I guess this is a security feature:
3003 * one (a user process) cannot get rid of the original name.
3005 setproctitle("%s", s);
3008 #elif defined(__hpux) && defined(PSTAT_SETCMD)
3009 if (PL_origalen != 1) {
3011 s = SvPV_const(sv, len);
3012 un.pst_command = (char *)s;
3013 pstat(PSTAT_SETCMD, un, len, 0, 0);
3016 if (PL_origalen > 1) {
3017 /* PL_origalen is set in perl_parse(). */
3018 s = SvPV_force(sv,len);
3019 if (len >= (STRLEN)PL_origalen-1) {
3020 /* Longer than original, will be truncated. We assume that
3021 * PL_origalen bytes are available. */
3022 Copy(s, PL_origargv[0], PL_origalen-1, char);
3025 /* Shorter than original, will be padded. */
3027 /* Special case for Mac OS X: see [perl #38868] */
3030 /* Is the space counterintuitive? Yes.
3031 * (You were expecting \0?)
3032 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3034 const int pad = ' ';
3036 Copy(s, PL_origargv[0], len, char);
3037 PL_origargv[0][len] = 0;
3038 memset(PL_origargv[0] + len + 1,
3039 pad, PL_origalen - len - 1);
3041 PL_origargv[0][PL_origalen-1] = 0;
3042 for (i = 1; i < PL_origargc; i++)
3044 #ifdef HAS_PRCTL_SET_NAME
3045 /* Set the legacy process name in addition to the POSIX name on Linux */
3046 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3047 /* diag_listed_as: SKIPME */
3048 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3053 UNLOCK_DOLLARZERO_MUTEX;
3060 Perl_whichsig_sv(pTHX_ SV *sigsv)
3064 PERL_ARGS_ASSERT_WHICHSIG_SV;
3065 PERL_UNUSED_CONTEXT;
3066 sigpv = SvPV_const(sigsv, siglen);
3067 return whichsig_pvn(sigpv, siglen);
3071 Perl_whichsig_pv(pTHX_ const char *sig)
3073 PERL_ARGS_ASSERT_WHICHSIG_PV;
3074 PERL_UNUSED_CONTEXT;
3075 return whichsig_pvn(sig, strlen(sig));
3079 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3081 register char* const* sigv;
3083 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3084 PERL_UNUSED_CONTEXT;
3086 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3087 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3088 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3090 if (memEQs(sig, len, "CHLD"))
3094 if (memEQs(sig, len, "CLD"))
3101 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3102 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3104 Perl_sighandler(int sig)
3107 #ifdef PERL_GET_SIG_CONTEXT
3108 dTHXa(PERL_GET_SIG_CONTEXT);
3115 SV * const tSv = PL_Sv;
3119 XPV * const tXpv = PL_Xpv;
3120 I32 old_ss_ix = PL_savestack_ix;
3121 SV *errsv_save = NULL;
3124 if (!PL_psig_ptr[sig]) {
3125 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3130 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3131 /* Max number of items pushed there is 3*n or 4. We cannot fix
3132 infinity, so we fix 4 (in fact 5): */
3133 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3135 PL_savestack_ix += 5; /* Protect save in progress. */
3136 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3139 /* sv_2cv is too complicated, try a simpler variant first: */
3140 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3141 || SvTYPE(cv) != SVt_PVCV) {
3143 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3146 if (!cv || !CvROOT(cv)) {
3147 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3148 PL_sig_name[sig], (gv ? GvENAME(gv)
3155 sv = PL_psig_name[sig]
3156 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3157 : newSVpv(PL_sig_name[sig],0);
3161 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3162 /* make sure our assumption about the size of the SAVEs are correct:
3163 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3164 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3167 PUSHSTACKi(PERLSI_SIGNAL);
3170 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3172 struct sigaction oact;
3174 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3177 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3178 /* The siginfo fields signo, code, errno, pid, uid,
3179 * addr, status, and band are defined by POSIX/SUSv3. */
3180 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3181 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3182 #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. */
3183 hv_stores(sih, "errno", newSViv(sip->si_errno));
3184 hv_stores(sih, "status", newSViv(sip->si_status));
3185 hv_stores(sih, "uid", newSViv(sip->si_uid));
3186 hv_stores(sih, "pid", newSViv(sip->si_pid));
3187 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3188 hv_stores(sih, "band", newSViv(sip->si_band));
3192 mPUSHp((char *)sip, sizeof(*sip));
3200 errsv_save = newSVsv(ERRSV);
3202 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3205 if (SvTRUE(ERRSV)) {
3206 SvREFCNT_dec(errsv_save);
3208 /* Handler "died", for example to get out of a restart-able read().
3209 * Before we re-do that on its behalf re-enable the signal which was
3210 * blocked by the system when we entered.
3212 #ifdef HAS_SIGPROCMASK
3213 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3219 sigaddset(&set,sig);
3220 sigprocmask(SIG_UNBLOCK, &set, NULL);
3223 /* Not clear if this will work */
3224 (void)rsignal(sig, SIG_IGN);
3225 (void)rsignal(sig, PL_csighandlerp);
3227 #endif /* !PERL_MICRO */
3231 sv_setsv(ERRSV, errsv_save);
3232 SvREFCNT_dec(errsv_save);
3236 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3237 PL_savestack_ix = old_ss_ix;
3240 PL_op = myop; /* Apparently not needed... */
3242 PL_Sv = tSv; /* Restore global temporaries. */
3249 S_restore_magic(pTHX_ const void *p)
3252 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3253 SV* const sv = mgs->mgs_sv;
3259 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3260 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3261 #ifdef PERL_OLD_COPY_ON_WRITE
3262 /* While magic was saved (and off) sv_setsv may well have seen
3263 this SV as a prime candidate for COW. */
3265 sv_force_normal_flags(sv, 0);
3267 if (mgs->mgs_readonly)
3269 if (mgs->mgs_magical)
3270 SvFLAGS(sv) |= mgs->mgs_magical;
3275 bumped = mgs->mgs_bumped;
3276 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3278 /* If we're still on top of the stack, pop us off. (That condition
3279 * will be satisfied if restore_magic was called explicitly, but *not*
3280 * if it's being called via leave_scope.)
3281 * The reason for doing this is that otherwise, things like sv_2cv()
3282 * may leave alloc gunk on the savestack, and some code
3283 * (e.g. sighandler) doesn't expect that...
3285 if (PL_savestack_ix == mgs->mgs_ss_ix)
3287 UV popval = SSPOPUV;
3288 assert(popval == SAVEt_DESTRUCTOR_X);
3289 PL_savestack_ix -= 2;
3291 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3292 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3295 if (SvREFCNT(sv) == 1) {
3296 /* We hold the last reference to this SV, which implies that the
3297 SV was deleted as a side effect of the routines we called.
3298 So artificially keep it alive a bit longer.
3299 We avoid turning on the TEMP flag, which can cause the SV's
3300 buffer to get stolen (and maybe other stuff). */
3305 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3309 /* clean up the mess created by Perl_sighandler().
3310 * Note that this is only called during an exit in a signal handler;
3311 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3315 S_unwind_handler_stack(pTHX_ const void *p)
3320 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3324 =for apidoc magic_sethint
3326 Triggered by a store to %^H, records the key/value pair to
3327 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3328 anything that would need a deep copy. Maybe we should warn if we find a
3334 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3337 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3338 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3340 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3342 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3343 an alternative leaf in there, with PL_compiling.cop_hints being used if
3344 it's NULL. If needed for threads, the alternative could lock a mutex,
3345 or take other more complex action. */
3347 /* Something changed in %^H, so it will need to be restored on scope exit.
3348 Doing this here saves a lot of doing it manually in perl code (and
3349 forgetting to do it, and consequent subtle errors. */
3350 PL_hints |= HINT_LOCALIZE_HH;
3351 CopHINTHASH_set(&PL_compiling,
3352 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3357 =for apidoc magic_clearhint
3359 Triggered by a delete from %^H, records the key to
3360 C<PL_compiling.cop_hints_hash>.
3365 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3369 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3370 PERL_UNUSED_ARG(sv);
3372 PL_hints |= HINT_LOCALIZE_HH;
3373 CopHINTHASH_set(&PL_compiling,
3374 mg->mg_len == HEf_SVKEY
3375 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3376 MUTABLE_SV(mg->mg_ptr), 0, 0)
3377 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3378 mg->mg_ptr, mg->mg_len, 0, 0));
3383 =for apidoc magic_clearhints
3385 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3390 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3392 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3393 PERL_UNUSED_ARG(sv);
3394 PERL_UNUSED_ARG(mg);
3395 cophh_free(CopHINTHASH_get(&PL_compiling));
3396 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3401 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3402 const char *name, I32 namlen)
3406 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3407 PERL_UNUSED_ARG(sv);
3408 PERL_UNUSED_ARG(name);
3409 PERL_UNUSED_ARG(namlen);
3411 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3412 nmg = mg_find(nsv, mg->mg_type);
3413 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3414 nmg->mg_ptr = mg->mg_ptr;
3415 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3416 nmg->mg_flags |= MGf_REFCOUNTED;
3422 * c-indentation-style: bsd
3424 * indent-tabs-mode: nil
3427 * ex: set ts=8 sts=4 sw=4 et: