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);
798 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
802 register const char *s = NULL;
804 const char * const remaining = mg->mg_ptr + 1;
805 const char nextchar = *remaining;
807 PERL_ARGS_ASSERT_MAGIC_GET;
809 switch (*mg->mg_ptr) {
810 case '\001': /* ^A */
811 sv_setsv(sv, PL_bodytarget);
812 if (SvTAINTED(PL_bodytarget))
815 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
816 if (nextchar == '\0') {
817 sv_setiv(sv, (IV)PL_minus_c);
819 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
820 sv_setiv(sv, (IV)STATUS_NATIVE);
824 case '\004': /* ^D */
825 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
827 case '\005': /* ^E */
828 if (nextchar == '\0') {
832 $DESCRIPTOR(msgdsc,msg);
833 sv_setnv(sv,(NV) vaxc$errno);
834 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
835 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
840 if (!(_emx_env & 0x200)) { /* Under DOS */
841 sv_setnv(sv, (NV)errno);
842 sv_setpv(sv, errno ? Strerror(errno) : "");
844 if (errno != errno_isOS2) {
845 const int tmp = _syserrno();
846 if (tmp) /* 2nd call to _syserrno() makes it 0 */
849 sv_setnv(sv, (NV)Perl_rc);
850 sv_setpv(sv, os2error(Perl_rc));
854 const DWORD dwErr = GetLastError();
855 sv_setnv(sv, (NV)dwErr);
857 PerlProc_GetOSError(sv, dwErr);
866 sv_setnv(sv, (NV)errno);
867 sv_setpv(sv, errno ? Strerror(errno) : "");
872 SvNOK_on(sv); /* what a wonderful hack! */
874 else if (strEQ(remaining, "NCODING"))
875 sv_setsv(sv, PL_encoding);
877 case '\006': /* ^F */
878 sv_setiv(sv, (IV)PL_maxsysfd);
880 case '\007': /* ^GLOBAL_PHASE */
881 if (strEQ(remaining, "LOBAL_PHASE")) {
882 sv_setpvn(sv, PL_phase_names[PL_phase],
883 strlen(PL_phase_names[PL_phase]));
886 case '\010': /* ^H */
887 sv_setiv(sv, (IV)PL_hints);
889 case '\011': /* ^I */ /* NOT \t in EBCDIC */
890 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
892 case '\017': /* ^O & ^OPEN */
893 if (nextchar == '\0') {
894 sv_setpv(sv, PL_osname);
897 else if (strEQ(remaining, "PEN")) {
898 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
902 if (nextchar == '\0') { /* ^P */
903 sv_setiv(sv, (IV)PL_perldb);
904 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
905 goto do_prematch_fetch;
906 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
907 goto do_postmatch_fetch;
910 case '\023': /* ^S */
911 if (nextchar == '\0') {
912 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
915 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
920 case '\024': /* ^T */
921 if (nextchar == '\0') {
923 sv_setnv(sv, PL_basetime);
925 sv_setiv(sv, (IV)PL_basetime);
928 else if (strEQ(remaining, "AINT"))
929 sv_setiv(sv, PL_tainting
930 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
933 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
934 if (strEQ(remaining, "NICODE"))
935 sv_setuv(sv, (UV) PL_unicode);
936 else if (strEQ(remaining, "TF8LOCALE"))
937 sv_setuv(sv, (UV) PL_utf8locale);
938 else if (strEQ(remaining, "TF8CACHE"))
939 sv_setiv(sv, (IV) PL_utf8cache);
941 case '\027': /* ^W & $^WARNING_BITS */
942 if (nextchar == '\0')
943 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
944 else if (strEQ(remaining, "ARNING_BITS")) {
945 if (PL_compiling.cop_warnings == pWARN_NONE) {
946 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
948 else if (PL_compiling.cop_warnings == pWARN_STD) {
949 sv_setsv(sv, &PL_sv_undef);
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 /* never unsafe, even if reading in a tainted expression */
1091 /* else a value has been assigned manually, so do nothing */
1099 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1101 sv_setnv(sv, (NV)errno);
1104 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1105 sv_setpv(sv, os2error(Perl_rc));
1108 sv_setpv(sv, errno ? Strerror(errno) : "");
1110 SvPOK_on(sv); /* may have got removed during taint processing */
1115 SvNOK_on(sv); /* what a wonderful hack! */
1118 sv_setiv(sv, (IV)PerlProc_getuid());
1121 sv_setiv(sv, (IV)PerlProc_geteuid());
1124 sv_setiv(sv, (IV)PerlProc_getgid());
1127 sv_setiv(sv, (IV)PerlProc_getegid());
1129 #ifdef HAS_GETGROUPS
1131 Groups_t *gary = NULL;
1132 I32 i, num_groups = getgroups(0, gary);
1133 Newx(gary, num_groups, Groups_t);
1134 num_groups = getgroups(num_groups, gary);
1135 for (i = 0; i < num_groups; i++)
1136 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1139 (void)SvIOK_on(sv); /* what a wonderful hack! */
1149 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1151 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1153 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1155 if (uf && uf->uf_val)
1156 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1161 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1164 STRLEN len = 0, klen;
1165 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1166 const char * const ptr = MgPV_const(mg,klen);
1169 PERL_ARGS_ASSERT_MAGIC_SETENV;
1171 #ifdef DYNAMIC_ENV_FETCH
1172 /* We just undefd an environment var. Is a replacement */
1173 /* waiting in the wings? */
1175 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1177 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1181 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1182 /* And you'll never guess what the dog had */
1183 /* in its mouth... */
1185 MgTAINTEDDIR_off(mg);
1187 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1188 char pathbuf[256], eltbuf[256], *cp, *elt;
1191 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1193 do { /* DCL$PATH may be a search list */
1194 while (1) { /* as may dev portion of any element */
1195 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1196 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1197 cando_by_name(S_IWUSR,0,elt) ) {
1198 MgTAINTEDDIR_on(mg);
1202 if ((cp = strchr(elt, ':')) != NULL)
1204 if (my_trnlnm(elt, eltbuf, j++))
1210 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1213 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1214 const char * const strend = s + len;
1216 while (s < strend) {
1220 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1221 const char path_sep = '|';
1223 const char path_sep = ':';
1225 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1226 s, strend, path_sep, &i);
1228 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1230 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1232 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1234 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1235 MgTAINTEDDIR_on(mg);
1241 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1247 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1249 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1250 PERL_UNUSED_ARG(sv);
1251 my_setenv(MgPV_nolen_const(mg),NULL);
1256 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1259 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1260 PERL_UNUSED_ARG(mg);
1262 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1264 if (PL_localizing) {
1267 hv_iterinit(MUTABLE_HV(sv));
1268 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1270 my_setenv(hv_iterkey(entry, &keylen),
1271 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1279 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1282 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1283 PERL_UNUSED_ARG(sv);
1284 PERL_UNUSED_ARG(mg);
1286 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1294 #ifdef HAS_SIGPROCMASK
1296 restore_sigmask(pTHX_ SV *save_sv)
1298 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1299 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1303 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1306 /* Are we fetching a signal entry? */
1307 int i = (I16)mg->mg_private;
1309 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1313 const char * sig = MgPV_const(mg, siglen);
1314 mg->mg_private = i = whichsig_pvn(sig, siglen);
1319 sv_setsv(sv,PL_psig_ptr[i]);
1321 Sighandler_t sigstate = rsignal_state(i);
1322 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1323 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1326 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1327 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1330 /* cache state so we don't fetch it again */
1331 if(sigstate == (Sighandler_t) SIG_IGN)
1332 sv_setpvs(sv,"IGNORE");
1334 sv_setsv(sv,&PL_sv_undef);
1335 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1342 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1344 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1346 magic_setsig(NULL, mg);
1347 return sv_unmagic(sv, mg->mg_type);
1351 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1352 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1354 Perl_csighandler(int sig)
1357 #ifdef PERL_GET_SIG_CONTEXT
1358 dTHXa(PERL_GET_SIG_CONTEXT);
1362 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1363 (void) rsignal(sig, PL_csighandlerp);
1364 if (PL_sig_ignoring[sig]) return;
1366 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1367 if (PL_sig_defaulting[sig])
1368 #ifdef KILL_BY_SIGPRC
1369 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1384 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1385 /* Call the perl level handler now--
1386 * with risk we may be in malloc() or being destructed etc. */
1387 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1388 (*PL_sighandlerp)(sig, NULL, NULL);
1390 (*PL_sighandlerp)(sig);
1393 if (!PL_psig_pend) return;
1394 /* Set a flag to say this signal is pending, that is awaiting delivery after
1395 * the current Perl opcode completes */
1396 PL_psig_pend[sig]++;
1398 #ifndef SIG_PENDING_DIE_COUNT
1399 # define SIG_PENDING_DIE_COUNT 120
1401 /* Add one to say _a_ signal is pending */
1402 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1403 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1404 (unsigned long)SIG_PENDING_DIE_COUNT);
1408 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1410 Perl_csighandler_init(void)
1413 if (PL_sig_handlers_initted) return;
1415 for (sig = 1; sig < SIG_SIZE; sig++) {
1416 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1418 PL_sig_defaulting[sig] = 1;
1419 (void) rsignal(sig, PL_csighandlerp);
1421 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1422 PL_sig_ignoring[sig] = 0;
1425 PL_sig_handlers_initted = 1;
1429 #if defined HAS_SIGPROCMASK
1431 unblock_sigmask(pTHX_ void* newset)
1433 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1438 Perl_despatch_signals(pTHX)
1443 for (sig = 1; sig < SIG_SIZE; sig++) {
1444 if (PL_psig_pend[sig]) {
1446 #ifdef HAS_SIGPROCMASK
1447 /* From sigaction(2) (FreeBSD man page):
1448 * | Signal routines normally execute with the signal that
1449 * | caused their invocation blocked, but other signals may
1451 * Emulation of this behavior (from within Perl) is enabled
1455 sigset_t newset, oldset;
1457 sigemptyset(&newset);
1458 sigaddset(&newset, sig);
1459 sigprocmask(SIG_BLOCK, &newset, &oldset);
1460 was_blocked = sigismember(&oldset, sig);
1462 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1464 SAVEFREESV(save_sv);
1465 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1468 PL_psig_pend[sig] = 0;
1469 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1470 (*PL_sighandlerp)(sig, NULL, NULL);
1472 (*PL_sighandlerp)(sig);
1474 #ifdef HAS_SIGPROCMASK
1483 /* sv of NULL signifies that we're acting as magic_clearsig. */
1485 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1490 /* Need to be careful with SvREFCNT_dec(), because that can have side
1491 * effects (due to closures). We must make sure that the new disposition
1492 * is in place before it is called.
1496 #ifdef HAS_SIGPROCMASK
1500 register const char *s = MgPV_const(mg,len);
1502 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1505 if (memEQs(s, len, "__DIE__"))
1507 else if (memEQs(s, len, "__WARN__")
1508 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1509 /* Merge the existing behaviours, which are as follows:
1510 magic_setsig, we always set svp to &PL_warnhook
1511 (hence we always change the warnings handler)
1512 For magic_clearsig, we don't change the warnings handler if it's
1513 set to the &PL_warnhook. */
1516 SV *tmp = sv_newmortal();
1517 Perl_croak(aTHX_ "No such hook: %s",
1518 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1522 if (*svp != PERL_WARNHOOK_FATAL)
1528 i = (I16)mg->mg_private;
1530 i = whichsig_pvn(s, len); /* ...no, a brick */
1531 mg->mg_private = (U16)i;
1535 SV *tmp = sv_newmortal();
1536 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1537 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1541 #ifdef HAS_SIGPROCMASK
1542 /* Avoid having the signal arrive at a bad time, if possible. */
1545 sigprocmask(SIG_BLOCK, &set, &save);
1547 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1548 SAVEFREESV(save_sv);
1549 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1552 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1553 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1555 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1556 PL_sig_ignoring[i] = 0;
1558 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1559 PL_sig_defaulting[i] = 0;
1561 to_dec = PL_psig_ptr[i];
1563 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1564 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1566 /* Signals don't change name during the program's execution, so once
1567 they're cached in the appropriate slot of PL_psig_name, they can
1570 Ideally we'd find some way of making SVs at (C) compile time, or
1571 at least, doing most of the work. */
1572 if (!PL_psig_name[i]) {
1573 PL_psig_name[i] = newSVpvn(s, len);
1574 SvREADONLY_on(PL_psig_name[i]);
1577 SvREFCNT_dec(PL_psig_name[i]);
1578 PL_psig_name[i] = NULL;
1579 PL_psig_ptr[i] = NULL;
1582 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1584 (void)rsignal(i, PL_csighandlerp);
1587 *svp = SvREFCNT_inc_simple_NN(sv);
1589 if (sv && SvOK(sv)) {
1590 s = SvPV_force(sv, len);
1594 if (sv && memEQs(s, len,"IGNORE")) {
1596 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1597 PL_sig_ignoring[i] = 1;
1598 (void)rsignal(i, PL_csighandlerp);
1600 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1604 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1606 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1607 PL_sig_defaulting[i] = 1;
1608 (void)rsignal(i, PL_csighandlerp);
1610 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1616 * We should warn if HINT_STRICT_REFS, but without
1617 * access to a known hint bit in a known OP, we can't
1618 * tell whether HINT_STRICT_REFS is in force or not.
1620 if (!strchr(s,':') && !strchr(s,'\''))
1621 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1624 (void)rsignal(i, PL_csighandlerp);
1626 *svp = SvREFCNT_inc_simple_NN(sv);
1630 #ifdef HAS_SIGPROCMASK
1634 SvREFCNT_dec(to_dec);
1637 #endif /* !PERL_MICRO */
1640 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1643 PERL_ARGS_ASSERT_MAGIC_SETISA;
1644 PERL_UNUSED_ARG(sv);
1646 /* Skip _isaelem because _isa will handle it shortly */
1647 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1650 return magic_clearisa(NULL, mg);
1653 /* sv of NULL signifies that we're acting as magic_setisa. */
1655 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1660 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1662 /* Bail out if destruction is going on */
1663 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1666 av_clear(MUTABLE_AV(sv));
1668 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1669 /* This occurs with setisa_elem magic, which calls this
1671 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1673 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1674 SV **svp = AvARRAY((AV *)mg->mg_obj);
1675 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1677 stash = GvSTASH((GV *)*svp++);
1678 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1685 (const GV *)mg->mg_obj
1688 /* The stash may have been detached from the symbol table, so check its
1689 name before doing anything. */
1690 if (stash && HvENAME_get(stash))
1691 mro_isa_changed_in(stash);
1697 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1699 HV * const hv = MUTABLE_HV(LvTARG(sv));
1702 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1703 PERL_UNUSED_ARG(mg);
1706 (void) hv_iterinit(hv);
1707 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1710 while (hv_iternext(hv))
1715 sv_setiv(sv, (IV)i);
1720 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1722 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1723 PERL_UNUSED_ARG(mg);
1725 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1731 =for apidoc magic_methcall
1733 Invoke a magic method (like FETCH).
1735 C<sv> and C<mg> are the tied thingy and the tie magic.
1737 C<meth> is the name of the method to call.
1739 C<argc> is the number of args (in addition to $self) to pass to the method.
1741 The C<flags> can be:
1743 G_DISCARD invoke method with G_DISCARD flag and don't
1745 G_UNDEF_FILL fill the stack with argc pointers to
1748 The arguments themselves are any values following the C<flags> argument.
1750 Returns the SV (if any) returned by the method, or NULL on failure.
1757 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1764 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1768 if (flags & G_WRITING_TO_STDERR) {
1772 SAVESPTR(PL_stderrgv);
1776 PUSHSTACKi(PERLSI_MAGIC);
1780 PUSHs(SvTIED_obj(sv, mg));
1781 if (flags & G_UNDEF_FILL) {
1783 PUSHs(&PL_sv_undef);
1785 } else if (argc > 0) {
1787 va_start(args, argc);
1790 SV *const sv = va_arg(args, SV *);
1797 if (flags & G_DISCARD) {
1798 call_method(meth, G_SCALAR|G_DISCARD);
1801 if (call_method(meth, G_SCALAR))
1802 ret = *PL_stack_sp--;
1805 if (flags & G_WRITING_TO_STDERR)
1812 /* wrapper for magic_methcall that creates the first arg */
1815 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1821 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1824 if (mg->mg_len >= 0) {
1825 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1827 else if (mg->mg_len == HEf_SVKEY)
1828 arg1 = MUTABLE_SV(mg->mg_ptr);
1830 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1831 arg1 = newSViv((IV)(mg->mg_len));
1835 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1837 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1841 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1846 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1848 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1855 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1857 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1859 if (mg->mg_type == PERL_MAGIC_tiedelem)
1860 mg->mg_flags |= MGf_GSKIP;
1861 magic_methpack(sv,mg,"FETCH");
1866 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1872 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1874 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1875 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1876 * public flags indicate its value based on copying from $val. Doing
1877 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1878 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1879 * wrong if $val happened to be tainted, as sv hasn't got magic
1880 * enabled, even though taint magic is in the chain. In which case,
1881 * fake up a temporary tainted value (this is easier than temporarily
1882 * re-enabling magic on sv). */
1884 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1885 && (tmg->mg_len & 1))
1887 val = sv_mortalcopy(sv);
1893 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1898 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1900 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1902 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1903 return magic_methpack(sv,mg,"DELETE");
1908 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1914 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1916 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1918 retval = SvIV(retsv)-1;
1920 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1922 return (U32) retval;
1926 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1930 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1932 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1937 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1942 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1944 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1945 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1952 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1954 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1956 return magic_methpack(sv,mg,"EXISTS");
1960 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1964 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1965 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1967 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1969 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1971 if (HvEITER_get(hv))
1972 /* we are in an iteration so the hash cannot be empty */
1974 /* no xhv_eiter so now use FIRSTKEY */
1975 key = sv_newmortal();
1976 magic_nextpack(MUTABLE_SV(hv), mg, key);
1977 HvEITER_set(hv, NULL); /* need to reset iterator */
1978 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1981 /* there is a SCALAR method that we can call */
1982 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1984 retval = &PL_sv_undef;
1989 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1992 GV * const gv = PL_DBline;
1993 const I32 i = SvTRUE(sv);
1994 SV ** const svp = av_fetch(GvAV(gv),
1995 atoi(MgPV_nolen_const(mg)), FALSE);
1997 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1999 if (svp && SvIOKp(*svp)) {
2000 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2002 /* set or clear breakpoint in the relevant control op */
2004 o->op_flags |= OPf_SPECIAL;
2006 o->op_flags &= ~OPf_SPECIAL;
2013 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2016 AV * const obj = MUTABLE_AV(mg->mg_obj);
2018 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2021 sv_setiv(sv, AvFILL(obj));
2029 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2032 AV * const obj = MUTABLE_AV(mg->mg_obj);
2034 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2037 av_fill(obj, SvIV(sv));
2039 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2040 "Attempt to set length of freed array");
2046 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2050 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2051 PERL_UNUSED_ARG(sv);
2053 /* during global destruction, mg_obj may already have been freed */
2054 if (PL_in_clean_all)
2057 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2060 /* arylen scalar holds a pointer back to the array, but doesn't own a
2061 reference. Hence the we (the array) are about to go away with it
2062 still pointing at us. Clear its pointer, else it would be pointing
2063 at free memory. See the comment in sv_magic about reference loops,
2064 and why it can't own a reference to us. */
2071 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2074 SV* const lsv = LvTARG(sv);
2076 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2077 PERL_UNUSED_ARG(mg);
2079 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2080 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2081 if (found && found->mg_len >= 0) {
2082 I32 i = found->mg_len;
2084 sv_pos_b2u(lsv, &i);
2094 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2097 SV* const lsv = LvTARG(sv);
2103 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2104 PERL_UNUSED_ARG(mg);
2106 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2107 found = mg_find(lsv, PERL_MAGIC_regex_global);
2113 #ifdef PERL_OLD_COPY_ON_WRITE
2115 sv_force_normal_flags(lsv, 0);
2117 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2120 else if (!SvOK(sv)) {
2124 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2129 ulen = sv_len_utf8(lsv);
2139 else if (pos > (SSize_t)len)
2144 sv_pos_u2b(lsv, &p, 0);
2148 found->mg_len = pos;
2149 found->mg_flags &= ~MGf_MINMATCH;
2155 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2158 SV * const lsv = LvTARG(sv);
2159 const char * const tmps = SvPV_const(lsv,len);
2160 STRLEN offs = LvTARGOFF(sv);
2161 STRLEN rem = LvTARGLEN(sv);
2162 const bool negoff = LvFLAGS(sv) & 1;
2163 const bool negrem = LvFLAGS(sv) & 2;
2165 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2166 PERL_UNUSED_ARG(mg);
2168 if (!translate_substr_offsets(
2169 SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
2170 negoff ? -(IV)offs : (IV)offs, !negoff,
2171 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2173 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2174 sv_setsv_nomg(sv, &PL_sv_undef);
2179 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2180 sv_setpvn(sv, tmps + offs, rem);
2187 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2190 STRLEN len, lsv_len, oldtarglen, newtarglen;
2191 const char * const tmps = SvPV_const(sv, len);
2192 SV * const lsv = LvTARG(sv);
2193 STRLEN lvoff = LvTARGOFF(sv);
2194 STRLEN lvlen = LvTARGLEN(sv);
2195 const bool negoff = LvFLAGS(sv) & 1;
2196 const bool neglen = LvFLAGS(sv) & 2;
2198 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2199 PERL_UNUSED_ARG(mg);
2203 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2204 "Attempt to use reference as lvalue in substr"
2206 if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
2207 else (void)SvPV_nomg(lsv,lsv_len);
2208 if (!translate_substr_offsets(
2210 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2211 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2213 Perl_croak(aTHX_ "substr outside of string");
2216 sv_utf8_upgrade(lsv);
2217 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2218 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2219 newtarglen = sv_len_utf8(sv);
2222 else if (lsv && SvUTF8(lsv)) {
2224 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2226 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2227 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2231 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2234 if (!neglen) LvTARGLEN(sv) = newtarglen;
2235 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2241 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2245 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2246 PERL_UNUSED_ARG(sv);
2248 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2253 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2257 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2258 PERL_UNUSED_ARG(sv);
2260 /* update taint status */
2269 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2271 SV * const lsv = LvTARG(sv);
2273 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2274 PERL_UNUSED_ARG(mg);
2277 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2285 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2287 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2288 PERL_UNUSED_ARG(mg);
2289 do_vecset(sv); /* XXX slurp this routine */
2294 Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
2296 PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
2299 SV * const vecsv = sv_newmortal();
2300 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
2301 if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
2303 return sv_unmagic(sv, mg->mg_type);
2307 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2312 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2314 if (LvTARGLEN(sv)) {
2316 SV * const ahv = LvTARG(sv);
2317 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2322 AV *const av = MUTABLE_AV(LvTARG(sv));
2323 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2324 targ = AvARRAY(av)[LvTARGOFF(sv)];
2326 if (targ && (targ != &PL_sv_undef)) {
2327 /* somebody else defined it for us */
2328 SvREFCNT_dec(LvTARG(sv));
2329 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2331 SvREFCNT_dec(mg->mg_obj);
2333 mg->mg_flags &= ~MGf_REFCOUNTED;
2338 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2343 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2345 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2346 PERL_UNUSED_ARG(mg);
2350 sv_setsv(LvTARG(sv), sv);
2351 SvSETMAGIC(LvTARG(sv));
2357 Perl_vivify_defelem(pTHX_ SV *sv)
2363 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2365 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2368 SV * const ahv = LvTARG(sv);
2369 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2372 if (!value || value == &PL_sv_undef)
2373 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2376 AV *const av = MUTABLE_AV(LvTARG(sv));
2377 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2378 LvTARG(sv) = NULL; /* array can't be extended */
2380 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2381 if (!svp || (value = *svp) == &PL_sv_undef)
2382 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2385 SvREFCNT_inc_simple_void(value);
2386 SvREFCNT_dec(LvTARG(sv));
2389 SvREFCNT_dec(mg->mg_obj);
2391 mg->mg_flags &= ~MGf_REFCOUNTED;
2395 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2397 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2398 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2403 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2405 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2406 PERL_UNUSED_CONTEXT;
2407 PERL_UNUSED_ARG(sv);
2413 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2415 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2417 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2419 if (uf && uf->uf_set)
2420 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2425 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2427 const char type = mg->mg_type;
2429 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2431 if (type == PERL_MAGIC_qr) {
2432 } else if (type == PERL_MAGIC_bm) {
2436 assert(type == PERL_MAGIC_fm);
2438 return sv_unmagic(sv, type);
2441 #ifdef USE_LOCALE_COLLATE
2443 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2445 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2448 * RenE<eacute> Descartes said "I think not."
2449 * and vanished with a faint plop.
2451 PERL_UNUSED_CONTEXT;
2452 PERL_UNUSED_ARG(sv);
2454 Safefree(mg->mg_ptr);
2460 #endif /* USE_LOCALE_COLLATE */
2462 /* Just clear the UTF-8 cache data. */
2464 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2466 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2467 PERL_UNUSED_CONTEXT;
2468 PERL_UNUSED_ARG(sv);
2469 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2471 mg->mg_len = -1; /* The mg_len holds the len cache. */
2476 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2479 register const char *s;
2481 register const REGEXP * rx;
2482 const char * const remaining = mg->mg_ptr + 1;
2487 PERL_ARGS_ASSERT_MAGIC_SET;
2489 switch (*mg->mg_ptr) {
2490 case '\015': /* $^MATCH */
2491 if (strEQ(remaining, "ATCH"))
2493 case '`': /* ${^PREMATCH} caught below */
2495 paren = RX_BUFF_IDX_PREMATCH;
2497 case '\'': /* ${^POSTMATCH} caught below */
2499 paren = RX_BUFF_IDX_POSTMATCH;
2503 paren = RX_BUFF_IDX_FULLMATCH;
2505 case '1': case '2': case '3': case '4':
2506 case '5': case '6': case '7': case '8': case '9':
2507 paren = atoi(mg->mg_ptr);
2509 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2511 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2513 /* Croak with a READONLY error when a numbered match var is
2514 * set without a previous pattern match. Unless it's C<local $1>
2517 if (!PL_localizing) {
2518 Perl_croak_no_modify(aTHX);
2522 case '\001': /* ^A */
2523 sv_setsv(PL_bodytarget, sv);
2524 FmLINES(PL_bodytarget) = 0;
2525 if (SvPOK(PL_bodytarget)) {
2526 char *s = SvPVX(PL_bodytarget);
2527 while ( ((s = strchr(s, '\n'))) ) {
2528 FmLINES(PL_bodytarget)++;
2532 /* mg_set() has temporarily made sv non-magical */
2534 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2535 SvTAINTED_on(PL_bodytarget);
2537 SvTAINTED_off(PL_bodytarget);
2540 case '\003': /* ^C */
2541 PL_minus_c = cBOOL(SvIV(sv));
2544 case '\004': /* ^D */
2546 s = SvPV_nolen_const(sv);
2547 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2548 if (DEBUG_x_TEST || DEBUG_B_TEST)
2549 dump_all_perl(!DEBUG_B_TEST);
2551 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2554 case '\005': /* ^E */
2555 if (*(mg->mg_ptr+1) == '\0') {
2557 set_vaxc_errno(SvIV(sv));
2560 SetLastError( SvIV(sv) );
2563 os2_setsyserrno(SvIV(sv));
2565 /* will anyone ever use this? */
2566 SETERRNO(SvIV(sv), 4);
2571 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2572 SvREFCNT_dec(PL_encoding);
2573 if (SvOK(sv) || SvGMAGICAL(sv)) {
2574 PL_encoding = newSVsv(sv);
2581 case '\006': /* ^F */
2582 PL_maxsysfd = SvIV(sv);
2584 case '\010': /* ^H */
2585 PL_hints = SvIV(sv);
2587 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2588 Safefree(PL_inplace);
2589 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2591 case '\016': /* ^N */
2592 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2593 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2595 case '\017': /* ^O */
2596 if (*(mg->mg_ptr+1) == '\0') {
2597 Safefree(PL_osname);
2600 TAINT_PROPER("assigning to $^O");
2601 PL_osname = savesvpv(sv);
2604 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2606 const char *const start = SvPV(sv, len);
2607 const char *out = (const char*)memchr(start, '\0', len);
2611 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2612 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2614 /* Opening for input is more common than opening for output, so
2615 ensure that hints for input are sooner on linked list. */
2616 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2618 : newSVpvs_flags("", SvUTF8(sv));
2619 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2622 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2624 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2628 case '\020': /* ^P */
2629 if (*remaining == '\0') { /* ^P */
2630 PL_perldb = SvIV(sv);
2631 if (PL_perldb && !PL_DBsingle)
2634 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2636 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2640 case '\024': /* ^T */
2642 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2644 PL_basetime = (Time_t)SvIV(sv);
2647 case '\025': /* ^UTF8CACHE */
2648 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2649 PL_utf8cache = (signed char) sv_2iv(sv);
2652 case '\027': /* ^W & $^WARNING_BITS */
2653 if (*(mg->mg_ptr+1) == '\0') {
2654 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2656 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2657 | (i ? G_WARN_ON : G_WARN_OFF) ;
2660 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2661 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2663 PL_compiling.cop_warnings = pWARN_STD;
2668 int accumulate = 0 ;
2669 int any_fatals = 0 ;
2670 const char * const ptr = SvPV_const(sv, len) ;
2671 for (i = 0 ; i < len ; ++i) {
2672 accumulate |= ptr[i] ;
2673 any_fatals |= (ptr[i] & 0xAA) ;
2676 if (!specialWARN(PL_compiling.cop_warnings))
2677 PerlMemShared_free(PL_compiling.cop_warnings);
2678 PL_compiling.cop_warnings = pWARN_NONE;
2680 /* Yuck. I can't see how to abstract this: */
2681 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2682 WARN_ALL) && !any_fatals) {
2683 if (!specialWARN(PL_compiling.cop_warnings))
2684 PerlMemShared_free(PL_compiling.cop_warnings);
2685 PL_compiling.cop_warnings = pWARN_ALL;
2686 PL_dowarn |= G_WARN_ONCE ;
2690 const char *const p = SvPV_const(sv, len);
2692 PL_compiling.cop_warnings
2693 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2696 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2697 PL_dowarn |= G_WARN_ONCE ;
2705 if (PL_localizing) {
2706 if (PL_localizing == 1)
2707 SAVESPTR(PL_last_in_gv);
2709 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2710 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2713 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2714 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2715 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2718 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2719 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2720 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2723 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2726 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2727 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2728 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2731 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2735 IO * const io = GvIO(PL_defoutgv);
2738 if ((SvIV(sv)) == 0)
2739 IoFLAGS(io) &= ~IOf_FLUSH;
2741 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2742 PerlIO *ofp = IoOFP(io);
2744 (void)PerlIO_flush(ofp);
2745 IoFLAGS(io) |= IOf_FLUSH;
2751 SvREFCNT_dec(PL_rs);
2752 PL_rs = newSVsv(sv);
2755 SvREFCNT_dec(PL_ors_sv);
2756 if (SvOK(sv) || SvGMAGICAL(sv)) {
2757 PL_ors_sv = newSVsv(sv);
2765 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2768 #ifdef COMPLEX_STATUS
2769 if (PL_localizing == 2) {
2770 SvUPGRADE(sv, SVt_PVLV);
2771 PL_statusvalue = LvTARGOFF(sv);
2772 PL_statusvalue_vms = LvTARGLEN(sv);
2776 #ifdef VMSISH_STATUS
2778 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2781 STATUS_UNIX_EXIT_SET(SvIV(sv));
2786 # define PERL_VMS_BANG vaxc$errno
2788 # define PERL_VMS_BANG 0
2790 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2791 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2796 const IV new_uid = SvIV(sv);
2797 PL_delaymagic_uid = new_uid;
2798 if (PL_delaymagic) {
2799 PL_delaymagic |= DM_RUID;
2800 break; /* don't do magic till later */
2803 (void)setruid((Uid_t)new_uid);
2806 (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2808 #ifdef HAS_SETRESUID
2809 (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2811 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2813 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2814 if (new_uid != 0 && PerlProc_getuid() == 0)
2815 (void)PerlProc_setuid(0);
2817 (void)PerlProc_setuid(new_uid);
2819 Perl_croak(aTHX_ "setruid() not implemented");
2828 const UV new_euid = SvIV(sv);
2829 PL_delaymagic_euid = new_euid;
2830 if (PL_delaymagic) {
2831 PL_delaymagic |= DM_EUID;
2832 break; /* don't do magic till later */
2835 (void)seteuid((Uid_t)new_euid);
2838 (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2840 #ifdef HAS_SETRESUID
2841 (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2843 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2844 PerlProc_setuid(new_euid);
2846 Perl_croak(aTHX_ "seteuid() not implemented");
2855 const UV new_gid = SvIV(sv);
2856 PL_delaymagic_gid = new_gid;
2857 if (PL_delaymagic) {
2858 PL_delaymagic |= DM_RGID;
2859 break; /* don't do magic till later */
2862 (void)setrgid((Gid_t)new_gid);
2865 (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2867 #ifdef HAS_SETRESGID
2868 (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2870 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2871 (void)PerlProc_setgid(new_gid);
2873 Perl_croak(aTHX_ "setrgid() not implemented");
2883 #ifdef HAS_SETGROUPS
2885 const char *p = SvPV_const(sv, len);
2886 Groups_t *gary = NULL;
2887 #ifdef _SC_NGROUPS_MAX
2888 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2893 int maxgrp = NGROUPS;
2899 for (i = 0; i < maxgrp; ++i) {
2900 while (*p && !isSPACE(*p))
2907 Newx(gary, i + 1, Groups_t);
2909 Renew(gary, i + 1, Groups_t);
2913 (void)setgroups(i, gary);
2916 #else /* HAS_SETGROUPS */
2917 new_egid = SvIV(sv);
2918 #endif /* HAS_SETGROUPS */
2919 PL_delaymagic_egid = new_egid;
2920 if (PL_delaymagic) {
2921 PL_delaymagic |= DM_EGID;
2922 break; /* don't do magic till later */
2925 (void)setegid((Gid_t)new_egid);
2928 (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2930 #ifdef HAS_SETRESGID
2931 (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2933 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2934 (void)PerlProc_setgid(new_egid);
2936 Perl_croak(aTHX_ "setegid() not implemented");
2944 PL_chopset = SvPV_force(sv,len);
2947 /* Store the pid in mg->mg_obj so we can tell when a fork has
2948 occurred. mg->mg_obj points to *$ by default, so clear it. */
2949 if (isGV(mg->mg_obj)) {
2950 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2951 SvREFCNT_dec(mg->mg_obj);
2952 mg->mg_flags |= MGf_REFCOUNTED;
2953 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2955 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2958 LOCK_DOLLARZERO_MUTEX;
2959 #ifdef HAS_SETPROCTITLE
2960 /* The BSDs don't show the argv[] in ps(1) output, they
2961 * show a string from the process struct and provide
2962 * the setproctitle() routine to manipulate that. */
2963 if (PL_origalen != 1) {
2964 s = SvPV_const(sv, len);
2965 # if __FreeBSD_version > 410001
2966 /* The leading "-" removes the "perl: " prefix,
2967 * but not the "(perl) suffix from the ps(1)
2968 * output, because that's what ps(1) shows if the
2969 * argv[] is modified. */
2970 setproctitle("-%s", s);
2971 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2972 /* This doesn't really work if you assume that
2973 * $0 = 'foobar'; will wipe out 'perl' from the $0
2974 * because in ps(1) output the result will be like
2975 * sprintf("perl: %s (perl)", s)
2976 * I guess this is a security feature:
2977 * one (a user process) cannot get rid of the original name.
2979 setproctitle("%s", s);
2982 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2983 if (PL_origalen != 1) {
2985 s = SvPV_const(sv, len);
2986 un.pst_command = (char *)s;
2987 pstat(PSTAT_SETCMD, un, len, 0, 0);
2990 if (PL_origalen > 1) {
2991 /* PL_origalen is set in perl_parse(). */
2992 s = SvPV_force(sv,len);
2993 if (len >= (STRLEN)PL_origalen-1) {
2994 /* Longer than original, will be truncated. We assume that
2995 * PL_origalen bytes are available. */
2996 Copy(s, PL_origargv[0], PL_origalen-1, char);
2999 /* Shorter than original, will be padded. */
3001 /* Special case for Mac OS X: see [perl #38868] */
3004 /* Is the space counterintuitive? Yes.
3005 * (You were expecting \0?)
3006 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3008 const int pad = ' ';
3010 Copy(s, PL_origargv[0], len, char);
3011 PL_origargv[0][len] = 0;
3012 memset(PL_origargv[0] + len + 1,
3013 pad, PL_origalen - len - 1);
3015 PL_origargv[0][PL_origalen-1] = 0;
3016 for (i = 1; i < PL_origargc; i++)
3018 #ifdef HAS_PRCTL_SET_NAME
3019 /* Set the legacy process name in addition to the POSIX name on Linux */
3020 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3021 /* diag_listed_as: SKIPME */
3022 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3027 UNLOCK_DOLLARZERO_MUTEX;
3034 Perl_whichsig_sv(pTHX_ SV *sigsv)
3038 PERL_ARGS_ASSERT_WHICHSIG_SV;
3039 PERL_UNUSED_CONTEXT;
3040 sigpv = SvPV_const(sigsv, siglen);
3041 return whichsig_pvn(sigpv, siglen);
3045 Perl_whichsig_pv(pTHX_ const char *sig)
3047 PERL_ARGS_ASSERT_WHICHSIG_PV;
3048 PERL_UNUSED_CONTEXT;
3049 return whichsig_pvn(sig, strlen(sig));
3053 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3055 register char* const* sigv;
3057 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3058 PERL_UNUSED_CONTEXT;
3060 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3061 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3062 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3064 if (memEQs(sig, len, "CHLD"))
3068 if (memEQs(sig, len, "CLD"))
3075 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3076 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3078 Perl_sighandler(int sig)
3081 #ifdef PERL_GET_SIG_CONTEXT
3082 dTHXa(PERL_GET_SIG_CONTEXT);
3089 SV * const tSv = PL_Sv;
3093 XPV * const tXpv = PL_Xpv;
3094 I32 old_ss_ix = PL_savestack_ix;
3097 if (!PL_psig_ptr[sig]) {
3098 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3103 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3104 /* Max number of items pushed there is 3*n or 4. We cannot fix
3105 infinity, so we fix 4 (in fact 5): */
3106 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3108 PL_savestack_ix += 5; /* Protect save in progress. */
3109 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3112 /* sv_2cv is too complicated, try a simpler variant first: */
3113 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3114 || SvTYPE(cv) != SVt_PVCV) {
3116 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3119 if (!cv || !CvROOT(cv)) {
3120 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3121 PL_sig_name[sig], (gv ? GvENAME(gv)
3128 sv = PL_psig_name[sig]
3129 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3130 : newSVpv(PL_sig_name[sig],0);
3134 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3135 /* make sure our assumption about the size of the SAVEs are correct:
3136 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3137 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3140 PUSHSTACKi(PERLSI_SIGNAL);
3143 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3145 struct sigaction oact;
3147 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3150 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3151 /* The siginfo fields signo, code, errno, pid, uid,
3152 * addr, status, and band are defined by POSIX/SUSv3. */
3153 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3154 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3155 #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. */
3156 hv_stores(sih, "errno", newSViv(sip->si_errno));
3157 hv_stores(sih, "status", newSViv(sip->si_status));
3158 hv_stores(sih, "uid", newSViv(sip->si_uid));
3159 hv_stores(sih, "pid", newSViv(sip->si_pid));
3160 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3161 hv_stores(sih, "band", newSViv(sip->si_band));
3165 mPUSHp((char *)sip, sizeof(*sip));
3173 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3176 if (SvTRUE(ERRSV)) {
3178 /* Handler "died", for example to get out of a restart-able read().
3179 * Before we re-do that on its behalf re-enable the signal which was
3180 * blocked by the system when we entered.
3182 #ifdef HAS_SIGPROCMASK
3183 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3189 sigaddset(&set,sig);
3190 sigprocmask(SIG_UNBLOCK, &set, NULL);
3193 /* Not clear if this will work */
3194 (void)rsignal(sig, SIG_IGN);
3195 (void)rsignal(sig, PL_csighandlerp);
3197 #endif /* !PERL_MICRO */
3201 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3202 PL_savestack_ix = old_ss_ix;
3205 PL_op = myop; /* Apparently not needed... */
3207 PL_Sv = tSv; /* Restore global temporaries. */
3214 S_restore_magic(pTHX_ const void *p)
3217 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3218 SV* const sv = mgs->mgs_sv;
3224 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3226 #ifdef PERL_OLD_COPY_ON_WRITE
3227 /* While magic was saved (and off) sv_setsv may well have seen
3228 this SV as a prime candidate for COW. */
3230 sv_force_normal_flags(sv, 0);
3233 if (mgs->mgs_readonly)
3235 if (mgs->mgs_magical)
3236 SvFLAGS(sv) |= mgs->mgs_magical;
3239 if (SvGMAGICAL(sv)) {
3240 /* downgrade public flags to private,
3241 and discard any other private flags */
3243 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3245 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3246 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3251 bumped = mgs->mgs_bumped;
3252 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3254 /* If we're still on top of the stack, pop us off. (That condition
3255 * will be satisfied if restore_magic was called explicitly, but *not*
3256 * if it's being called via leave_scope.)
3257 * The reason for doing this is that otherwise, things like sv_2cv()
3258 * may leave alloc gunk on the savestack, and some code
3259 * (e.g. sighandler) doesn't expect that...
3261 if (PL_savestack_ix == mgs->mgs_ss_ix)
3263 UV popval = SSPOPUV;
3264 assert(popval == SAVEt_DESTRUCTOR_X);
3265 PL_savestack_ix -= 2;
3267 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3268 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3271 if (SvREFCNT(sv) == 1) {
3272 /* We hold the last reference to this SV, which implies that the
3273 SV was deleted as a side effect of the routines we called.
3274 So artificially keep it alive a bit longer.
3275 We avoid turning on the TEMP flag, which can cause the SV's
3276 buffer to get stolen (and maybe other stuff). */
3277 int was_temp = SvTEMP(sv);
3285 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3289 /* clean up the mess created by Perl_sighandler().
3290 * Note that this is only called during an exit in a signal handler;
3291 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3295 S_unwind_handler_stack(pTHX_ const void *p)
3300 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3304 =for apidoc magic_sethint
3306 Triggered by a store to %^H, records the key/value pair to
3307 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3308 anything that would need a deep copy. Maybe we should warn if we find a
3314 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3317 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3318 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3320 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3322 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3323 an alternative leaf in there, with PL_compiling.cop_hints being used if
3324 it's NULL. If needed for threads, the alternative could lock a mutex,
3325 or take other more complex action. */
3327 /* Something changed in %^H, so it will need to be restored on scope exit.
3328 Doing this here saves a lot of doing it manually in perl code (and
3329 forgetting to do it, and consequent subtle errors. */
3330 PL_hints |= HINT_LOCALIZE_HH;
3331 CopHINTHASH_set(&PL_compiling,
3332 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3337 =for apidoc magic_clearhint
3339 Triggered by a delete from %^H, records the key to
3340 C<PL_compiling.cop_hints_hash>.
3345 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3349 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3350 PERL_UNUSED_ARG(sv);
3352 PL_hints |= HINT_LOCALIZE_HH;
3353 CopHINTHASH_set(&PL_compiling,
3354 mg->mg_len == HEf_SVKEY
3355 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3356 MUTABLE_SV(mg->mg_ptr), 0, 0)
3357 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3358 mg->mg_ptr, mg->mg_len, 0, 0));
3363 =for apidoc magic_clearhints
3365 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3370 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3372 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3373 PERL_UNUSED_ARG(sv);
3374 PERL_UNUSED_ARG(mg);
3375 cophh_free(CopHINTHASH_get(&PL_compiling));
3376 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3381 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3382 const char *name, I32 namlen)
3386 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3387 PERL_UNUSED_ARG(name);
3388 PERL_UNUSED_ARG(namlen);
3390 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3391 nmg = mg_find(nsv, mg->mg_type);
3392 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3393 nmg->mg_ptr = mg->mg_ptr;
3394 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3395 nmg->mg_flags |= MGf_REFCOUNTED;
3401 * c-indentation-style: bsd
3403 * indent-tabs-mode: nil
3406 * ex: set ts=8 sts=4 sw=4 et: