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.
88 /* MGS is typedef'ed to struct magic_state in perl.h */
91 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
96 PERL_ARGS_ASSERT_SAVE_MAGIC;
98 assert(SvMAGICAL(sv));
99 /* Turning READONLY off for a copy-on-write scalar (including shared
100 hash keys) is a bad idea. */
102 sv_force_normal_flags(sv, 0);
104 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
106 mgs = SSPTR(mgs_ix, MGS*);
108 mgs->mgs_magical = SvMAGICAL(sv);
109 mgs->mgs_readonly = SvREADONLY(sv) != 0;
110 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
114 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
115 /* No public flags are set, so promote any private flags to public. */
116 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
121 =for apidoc mg_magical
123 Turns on the magical status of an SV. See C<sv_magic>.
129 Perl_mg_magical(pTHX_ SV *sv)
132 PERL_ARGS_ASSERT_MG_MAGICAL;
136 if ((mg = SvMAGIC(sv))) {
138 const MGVTBL* const vtbl = mg->mg_virtual;
140 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
147 } while ((mg = mg->mg_moremagic));
148 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
154 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
157 S_is_container_magic(const MAGIC *mg)
160 switch (mg->mg_type) {
163 case PERL_MAGIC_regex_global:
164 case PERL_MAGIC_nkeys:
165 #ifdef USE_LOCALE_COLLATE
166 case PERL_MAGIC_collxfrm:
169 case PERL_MAGIC_taint:
171 case PERL_MAGIC_vstring:
172 case PERL_MAGIC_utf8:
173 case PERL_MAGIC_substr:
174 case PERL_MAGIC_defelem:
175 case PERL_MAGIC_arylen:
177 case PERL_MAGIC_backref:
178 case PERL_MAGIC_arylen_p:
179 case PERL_MAGIC_rhash:
180 case PERL_MAGIC_symtab:
181 case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
182 case PERL_MAGIC_checkcall:
192 Do magic after a value is retrieved from the SV. See C<sv_magic>.
198 Perl_mg_get(pTHX_ SV *sv)
201 const I32 mgs_ix = SSNEW(sizeof(MGS));
202 const bool was_temp = cBOOL(SvTEMP(sv));
204 MAGIC *newmg, *head, *cur, *mg;
205 /* guard against sv having being freed midway by holding a private
208 PERL_ARGS_ASSERT_MG_GET;
210 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
211 cause the SV's buffer to get stolen (and maybe other stuff).
214 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
219 save_magic(mgs_ix, sv);
221 /* We must call svt_get(sv, mg) for each valid entry in the linked
222 list of magic. svt_get() may delete the current entry, add new
223 magic to the head of the list, or upgrade the SV. AMS 20010810 */
225 newmg = cur = head = mg = SvMAGIC(sv);
227 const MGVTBL * const vtbl = mg->mg_virtual;
228 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
230 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
231 vtbl->svt_get(aTHX_ sv, mg);
233 /* guard against magic having been deleted - eg FETCH calling
236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
240 /* recalculate flags if this entry was deleted. */
241 if (mg->mg_flags & MGf_GSKIP)
242 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
248 /* Have we finished with the new entries we saw? Start again
249 where we left off (unless there are more new entries). */
257 /* Were any new entries added? */
258 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
262 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
266 restore_magic(INT2PTR(void *, (IV)mgs_ix));
268 if (SvREFCNT(sv) == 1) {
269 /* We hold the last reference to this SV, which implies that the
270 SV was deleted as a side effect of the routines we called. */
279 Do magic after a value is assigned to the SV. See C<sv_magic>.
285 Perl_mg_set(pTHX_ SV *sv)
288 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 PERL_ARGS_ASSERT_MG_SET;
294 save_magic(mgs_ix, sv);
296 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
297 const MGVTBL* vtbl = mg->mg_virtual;
298 nextmg = mg->mg_moremagic; /* it may delete itself */
299 if (mg->mg_flags & MGf_GSKIP) {
300 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
301 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
303 if (PL_localizing == 2 && !S_is_container_magic(mg))
305 if (vtbl && vtbl->svt_set)
306 vtbl->svt_set(aTHX_ sv, mg);
309 restore_magic(INT2PTR(void*, (IV)mgs_ix));
314 =for apidoc mg_length
316 Report on the SV's length. See C<sv_magic>.
322 Perl_mg_length(pTHX_ SV *sv)
328 PERL_ARGS_ASSERT_MG_LENGTH;
330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
331 const MGVTBL * const vtbl = mg->mg_virtual;
332 if (vtbl && vtbl->svt_len) {
333 const I32 mgs_ix = SSNEW(sizeof(MGS));
334 save_magic(mgs_ix, sv);
335 /* omit MGf_GSKIP -- not changed here */
336 len = vtbl->svt_len(aTHX_ sv, mg);
337 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 /* You can't know whether it's UTF-8 until you get the string again...
345 const U8 *s = (U8*)SvPV_const(sv, len);
348 len = utf8_length(s, s + len);
355 Perl_mg_size(pTHX_ SV *sv)
359 PERL_ARGS_ASSERT_MG_SIZE;
361 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
362 const MGVTBL* const vtbl = mg->mg_virtual;
363 if (vtbl && vtbl->svt_len) {
364 const I32 mgs_ix = SSNEW(sizeof(MGS));
366 save_magic(mgs_ix, sv);
367 /* omit MGf_GSKIP -- not changed here */
368 len = vtbl->svt_len(aTHX_ sv, mg);
369 restore_magic(INT2PTR(void*, (IV)mgs_ix));
376 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
380 Perl_croak(aTHX_ "Size magic not implemented");
389 Clear something magical that the SV represents. See C<sv_magic>.
395 Perl_mg_clear(pTHX_ SV *sv)
397 const I32 mgs_ix = SSNEW(sizeof(MGS));
401 PERL_ARGS_ASSERT_MG_CLEAR;
403 save_magic(mgs_ix, sv);
405 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
406 const MGVTBL* const vtbl = mg->mg_virtual;
407 /* omit GSKIP -- never set here */
409 nextmg = mg->mg_moremagic; /* it may delete itself */
411 if (vtbl && vtbl->svt_clear)
412 vtbl->svt_clear(aTHX_ sv, mg);
415 restore_magic(INT2PTR(void*, (IV)mgs_ix));
422 Finds the magic pointer for type matching the SV. See C<sv_magic>.
428 Perl_mg_find(pTHX_ const SV *sv, int type)
433 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
434 if (mg->mg_type == type)
444 Copies the magic from one SV to another. See C<sv_magic>.
450 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
455 PERL_ARGS_ASSERT_MG_COPY;
457 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
458 const MGVTBL* const vtbl = mg->mg_virtual;
459 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
460 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
463 const char type = mg->mg_type;
464 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
466 (type == PERL_MAGIC_tied)
468 : (type == PERL_MAGIC_regdata && mg->mg_obj)
471 toLOWER(type), key, klen);
480 =for apidoc mg_localize
482 Copy some of the magic from an existing SV to new localized version of that
483 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
486 If setmagic is false then no set magic will be called on the new (empty) SV.
487 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
488 and that will handle the magic.
494 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
499 PERL_ARGS_ASSERT_MG_LOCALIZE;
501 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
502 const MGVTBL* const vtbl = mg->mg_virtual;
503 if (!S_is_container_magic(mg))
506 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
507 (void)vtbl->svt_local(aTHX_ nsv, mg);
509 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
510 mg->mg_ptr, mg->mg_len);
512 /* container types should remain read-only across localization */
513 SvFLAGS(nsv) |= SvREADONLY(sv);
516 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
517 SvFLAGS(nsv) |= SvMAGICAL(sv);
526 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
528 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
530 const MGVTBL* const vtbl = mg->mg_virtual;
531 if (vtbl && vtbl->svt_free)
532 vtbl->svt_free(aTHX_ sv, mg);
533 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
534 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
535 Safefree(mg->mg_ptr);
536 else if (mg->mg_len == HEf_SVKEY)
537 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
539 if (mg->mg_flags & MGf_REFCOUNTED)
540 SvREFCNT_dec(mg->mg_obj);
547 Free any magic storage used by the SV. See C<sv_magic>.
553 Perl_mg_free(pTHX_ SV *sv)
558 PERL_ARGS_ASSERT_MG_FREE;
560 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
561 moremagic = mg->mg_moremagic;
562 mg_free_struct(sv, mg);
563 SvMAGIC_set(sv, moremagic);
565 SvMAGIC_set(sv, NULL);
571 =for apidoc Am|void|mg_free_type|SV *sv|int how
573 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
579 Perl_mg_free_type(pTHX_ SV *sv, int how)
581 MAGIC *mg, *prevmg, *moremg;
582 PERL_ARGS_ASSERT_MG_FREE_TYPE;
583 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
585 moremg = mg->mg_moremagic;
586 if (mg->mg_type == how) {
587 /* temporarily move to the head of the magic chain, in case
588 custom free code relies on this historical aspect of mg_free */
590 prevmg->mg_moremagic = moremg;
591 mg->mg_moremagic = SvMAGIC(sv);
594 newhead = mg->mg_moremagic;
595 mg_free_struct(sv, mg);
596 SvMAGIC_set(sv, newhead);
606 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
611 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
614 register const REGEXP * const rx = PM_GETRE(PL_curpm);
616 if (mg->mg_obj) { /* @+ */
617 /* return the number possible */
618 return RX_NPARENS(rx);
620 I32 paren = RX_LASTPAREN(rx);
622 /* return the last filled */
624 && (RX_OFFS(rx)[paren].start == -1
625 || RX_OFFS(rx)[paren].end == -1) )
636 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
640 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
643 register const REGEXP * const rx = PM_GETRE(PL_curpm);
645 register const I32 paren = mg->mg_len;
650 if (paren <= (I32)RX_NPARENS(rx) &&
651 (s = RX_OFFS(rx)[paren].start) != -1 &&
652 (t = RX_OFFS(rx)[paren].end) != -1)
655 if (mg->mg_obj) /* @+ */
660 if (i > 0 && RX_MATCH_UTF8(rx)) {
661 const char * const b = RX_SUBBEG(rx);
663 i = utf8_length((U8*)b, (U8*)(b+i));
674 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
676 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
679 Perl_croak_no_modify(aTHX);
680 NORETURN_FUNCTION_END;
684 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
689 register const REGEXP * rx;
690 const char * const remaining = mg->mg_ptr + 1;
692 PERL_ARGS_ASSERT_MAGIC_LEN;
694 switch (*mg->mg_ptr) {
696 if (*remaining == '\0') { /* ^P */
698 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
700 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
704 case '\015': /* $^MATCH */
705 if (strEQ(remaining, "ATCH")) {
712 paren = RX_BUFF_IDX_PREMATCH;
716 paren = RX_BUFF_IDX_POSTMATCH;
720 paren = RX_BUFF_IDX_FULLMATCH;
722 case '1': case '2': case '3': case '4':
723 case '5': case '6': case '7': case '8': case '9':
724 paren = atoi(mg->mg_ptr);
726 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
728 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
731 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
734 if (ckWARN(WARN_UNINITIALIZED))
739 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
740 paren = RX_LASTPAREN(rx);
745 case '\016': /* ^N */
746 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
747 paren = RX_LASTCLOSEPAREN(rx);
754 if (!SvPOK(sv) && SvNIOK(sv)) {
762 #define SvRTRIM(sv) STMT_START { \
764 STRLEN len = SvCUR(sv); \
765 char * const p = SvPVX(sv); \
766 while (len > 0 && isSPACE(p[len-1])) \
768 SvCUR_set(sv, len); \
774 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
776 PERL_ARGS_ASSERT_EMULATE_COP_IO;
778 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
779 sv_setsv(sv, &PL_sv_undef);
783 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
784 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
789 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
790 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') {
831 # include <descrip.h>
832 # include <starlet.h>
834 $DESCRIPTOR(msgdsc,msg);
835 sv_setnv(sv,(NV) vaxc$errno);
836 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
837 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
842 if (!(_emx_env & 0x200)) { /* Under DOS */
843 sv_setnv(sv, (NV)errno);
844 sv_setpv(sv, errno ? Strerror(errno) : "");
846 if (errno != errno_isOS2) {
847 const int tmp = _syserrno();
848 if (tmp) /* 2nd call to _syserrno() makes it 0 */
851 sv_setnv(sv, (NV)Perl_rc);
852 sv_setpv(sv, os2error(Perl_rc));
856 const DWORD dwErr = GetLastError();
857 sv_setnv(sv, (NV)dwErr);
859 PerlProc_GetOSError(sv, dwErr);
868 sv_setnv(sv, (NV)errno);
869 sv_setpv(sv, errno ? Strerror(errno) : "");
874 SvNOK_on(sv); /* what a wonderful hack! */
876 else if (strEQ(remaining, "NCODING"))
877 sv_setsv(sv, PL_encoding);
879 case '\006': /* ^F */
880 sv_setiv(sv, (IV)PL_maxsysfd);
882 case '\007': /* ^GLOBAL_PHASE */
883 if (strEQ(remaining, "LOBAL_PHASE")) {
884 sv_setpvn(sv, PL_phase_names[PL_phase],
885 strlen(PL_phase_names[PL_phase]));
888 case '\010': /* ^H */
889 sv_setiv(sv, (IV)PL_hints);
891 case '\011': /* ^I */ /* NOT \t in EBCDIC */
892 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
894 case '\017': /* ^O & ^OPEN */
895 if (nextchar == '\0') {
896 sv_setpv(sv, PL_osname);
899 else if (strEQ(remaining, "PEN")) {
900 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
904 if (nextchar == '\0') { /* ^P */
905 sv_setiv(sv, (IV)PL_perldb);
906 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
907 goto do_prematch_fetch;
908 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
909 goto do_postmatch_fetch;
912 case '\023': /* ^S */
913 if (nextchar == '\0') {
914 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
917 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
922 case '\024': /* ^T */
923 if (nextchar == '\0') {
925 sv_setnv(sv, PL_basetime);
927 sv_setiv(sv, (IV)PL_basetime);
930 else if (strEQ(remaining, "AINT"))
931 sv_setiv(sv, PL_tainting
932 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
935 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
936 if (strEQ(remaining, "NICODE"))
937 sv_setuv(sv, (UV) PL_unicode);
938 else if (strEQ(remaining, "TF8LOCALE"))
939 sv_setuv(sv, (UV) PL_utf8locale);
940 else if (strEQ(remaining, "TF8CACHE"))
941 sv_setiv(sv, (IV) PL_utf8cache);
943 case '\027': /* ^W & $^WARNING_BITS */
944 if (nextchar == '\0')
945 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
946 else if (strEQ(remaining, "ARNING_BITS")) {
947 if (PL_compiling.cop_warnings == pWARN_NONE) {
948 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
950 else if (PL_compiling.cop_warnings == pWARN_STD) {
953 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
957 else if (PL_compiling.cop_warnings == pWARN_ALL) {
958 /* Get the bit mask for $warnings::Bits{all}, because
959 * it could have been extended by warnings::register */
960 HV * const bits=get_hv("warnings::Bits", 0);
962 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
964 sv_setsv(sv, *bits_all);
967 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
971 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
972 *PL_compiling.cop_warnings);
977 case '\015': /* $^MATCH */
978 if (strEQ(remaining, "ATCH")) {
979 case '1': case '2': case '3': case '4':
980 case '5': case '6': case '7': case '8': case '9': case '&':
981 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
983 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
984 * XXX Does the new way break anything?
986 paren = atoi(mg->mg_ptr); /* $& is in [0] */
987 CALLREG_NUMBUF_FETCH(rx,paren,sv);
990 sv_setsv(sv,&PL_sv_undef);
994 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
995 if (RX_LASTPAREN(rx)) {
996 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
1000 sv_setsv(sv,&PL_sv_undef);
1002 case '\016': /* ^N */
1003 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1004 if (RX_LASTCLOSEPAREN(rx)) {
1005 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1010 sv_setsv(sv,&PL_sv_undef);
1014 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1015 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1018 sv_setsv(sv,&PL_sv_undef);
1022 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1023 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1026 sv_setsv(sv,&PL_sv_undef);
1029 if (GvIO(PL_last_in_gv)) {
1030 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1035 sv_setiv(sv, (IV)STATUS_CURRENT);
1036 #ifdef COMPLEX_STATUS
1037 SvUPGRADE(sv, SVt_PVLV);
1038 LvTARGOFF(sv) = PL_statusvalue;
1039 LvTARGLEN(sv) = PL_statusvalue_vms;
1044 if (!isGV_with_GP(PL_defoutgv))
1046 else if (GvIOp(PL_defoutgv))
1047 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1051 sv_setpv(sv,GvENAME(PL_defoutgv));
1052 sv_catpvs(sv,"_TOP");
1056 if (!isGV_with_GP(PL_defoutgv))
1058 else if (GvIOp(PL_defoutgv))
1059 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1061 s = GvENAME(PL_defoutgv);
1065 if (GvIO(PL_defoutgv))
1066 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1069 if (GvIO(PL_defoutgv))
1070 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1073 if (GvIO(PL_defoutgv))
1074 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1081 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1084 if (GvIO(PL_defoutgv))
1085 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1089 sv_copypv(sv, PL_ors_sv);
1095 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1097 sv_setnv(sv, (NV)errno);
1100 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1101 sv_setpv(sv, os2error(Perl_rc));
1104 sv_setpv(sv, errno ? Strerror(errno) : "");
1106 SvPOK_on(sv); /* may have got removed during taint processing */
1111 SvNOK_on(sv); /* what a wonderful hack! */
1114 sv_setiv(sv, (IV)PL_uid);
1117 sv_setiv(sv, (IV)PL_euid);
1120 sv_setiv(sv, (IV)PL_gid);
1123 sv_setiv(sv, (IV)PL_egid);
1125 #ifdef HAS_GETGROUPS
1127 Groups_t *gary = NULL;
1128 I32 i, num_groups = getgroups(0, gary);
1129 Newx(gary, num_groups, Groups_t);
1130 num_groups = getgroups(num_groups, gary);
1131 for (i = 0; i < num_groups; i++)
1132 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1135 (void)SvIOK_on(sv); /* what a wonderful hack! */
1145 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1147 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1149 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1151 if (uf && uf->uf_val)
1152 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1157 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1160 STRLEN len = 0, klen;
1161 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1162 const char * const ptr = MgPV_const(mg,klen);
1165 PERL_ARGS_ASSERT_MAGIC_SETENV;
1167 #ifdef DYNAMIC_ENV_FETCH
1168 /* We just undefd an environment var. Is a replacement */
1169 /* waiting in the wings? */
1171 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1173 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1177 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1178 /* And you'll never guess what the dog had */
1179 /* in its mouth... */
1181 MgTAINTEDDIR_off(mg);
1183 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1184 char pathbuf[256], eltbuf[256], *cp, *elt;
1188 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1190 do { /* DCL$PATH may be a search list */
1191 while (1) { /* as may dev portion of any element */
1192 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1193 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1194 cando_by_name(S_IWUSR,0,elt) ) {
1195 MgTAINTEDDIR_on(mg);
1199 if ((cp = strchr(elt, ':')) != NULL)
1201 if (my_trnlnm(elt, eltbuf, j++))
1207 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1210 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1211 const char * const strend = s + len;
1213 while (s < strend) {
1217 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1218 const char path_sep = '|';
1220 const char path_sep = ':';
1222 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1223 s, strend, path_sep, &i);
1225 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1227 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1229 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1231 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1232 MgTAINTEDDIR_on(mg);
1238 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1244 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1246 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1247 PERL_UNUSED_ARG(sv);
1248 my_setenv(MgPV_nolen_const(mg),NULL);
1253 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1256 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1257 PERL_UNUSED_ARG(mg);
1259 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1261 if (PL_localizing) {
1264 hv_iterinit(MUTABLE_HV(sv));
1265 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1267 my_setenv(hv_iterkey(entry, &keylen),
1268 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1276 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1279 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1280 PERL_UNUSED_ARG(sv);
1281 PERL_UNUSED_ARG(mg);
1283 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1291 #ifdef HAS_SIGPROCMASK
1293 restore_sigmask(pTHX_ SV *save_sv)
1295 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1296 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1300 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1303 /* Are we fetching a signal entry? */
1304 int i = (I16)mg->mg_private;
1306 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1309 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1314 sv_setsv(sv,PL_psig_ptr[i]);
1316 Sighandler_t sigstate = rsignal_state(i);
1317 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1318 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1321 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1322 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1325 /* cache state so we don't fetch it again */
1326 if(sigstate == (Sighandler_t) SIG_IGN)
1327 sv_setpvs(sv,"IGNORE");
1329 sv_setsv(sv,&PL_sv_undef);
1330 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1337 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1339 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1340 PERL_UNUSED_ARG(sv);
1342 magic_setsig(NULL, mg);
1343 return sv_unmagic(sv, mg->mg_type);
1347 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1348 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1350 Perl_csighandler(int sig)
1353 #ifdef PERL_GET_SIG_CONTEXT
1354 dTHXa(PERL_GET_SIG_CONTEXT);
1358 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1359 (void) rsignal(sig, PL_csighandlerp);
1360 if (PL_sig_ignoring[sig]) return;
1362 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1363 if (PL_sig_defaulting[sig])
1364 #ifdef KILL_BY_SIGPRC
1365 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1380 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1381 /* Call the perl level handler now--
1382 * with risk we may be in malloc() or being destructed etc. */
1383 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1384 (*PL_sighandlerp)(sig, NULL, NULL);
1386 (*PL_sighandlerp)(sig);
1389 if (!PL_psig_pend) return;
1390 /* Set a flag to say this signal is pending, that is awaiting delivery after
1391 * the current Perl opcode completes */
1392 PL_psig_pend[sig]++;
1394 #ifndef SIG_PENDING_DIE_COUNT
1395 # define SIG_PENDING_DIE_COUNT 120
1397 /* Add one to say _a_ signal is pending */
1398 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1399 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1400 (unsigned long)SIG_PENDING_DIE_COUNT);
1404 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1406 Perl_csighandler_init(void)
1409 if (PL_sig_handlers_initted) return;
1411 for (sig = 1; sig < SIG_SIZE; sig++) {
1412 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1414 PL_sig_defaulting[sig] = 1;
1415 (void) rsignal(sig, PL_csighandlerp);
1417 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1418 PL_sig_ignoring[sig] = 0;
1421 PL_sig_handlers_initted = 1;
1426 Perl_despatch_signals(pTHX)
1431 for (sig = 1; sig < SIG_SIZE; sig++) {
1432 if (PL_psig_pend[sig]) {
1434 PERL_BLOCKSIG_ADD(set, sig);
1435 PL_psig_pend[sig] = 0;
1436 PERL_BLOCKSIG_BLOCK(set);
1437 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1438 (*PL_sighandlerp)(sig, NULL, NULL);
1440 (*PL_sighandlerp)(sig);
1442 PERL_BLOCKSIG_UNBLOCK(set);
1448 /* sv of NULL signifies that we're acting as magic_clearsig. */
1450 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1455 /* Need to be careful with SvREFCNT_dec(), because that can have side
1456 * effects (due to closures). We must make sure that the new disposition
1457 * is in place before it is called.
1461 #ifdef HAS_SIGPROCMASK
1465 register const char *s = MgPV_const(mg,len);
1467 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1470 if (strEQ(s,"__DIE__"))
1472 else if (strEQ(s,"__WARN__")
1473 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1474 /* Merge the existing behaviours, which are as follows:
1475 magic_setsig, we always set svp to &PL_warnhook
1476 (hence we always change the warnings handler)
1477 For magic_clearsig, we don't change the warnings handler if it's
1478 set to the &PL_warnhook. */
1481 Perl_croak(aTHX_ "No such hook: %s", s);
1484 if (*svp != PERL_WARNHOOK_FATAL)
1490 i = (I16)mg->mg_private;
1492 i = whichsig(s); /* ...no, a brick */
1493 mg->mg_private = (U16)i;
1497 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1500 #ifdef HAS_SIGPROCMASK
1501 /* Avoid having the signal arrive at a bad time, if possible. */
1504 sigprocmask(SIG_BLOCK, &set, &save);
1506 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1507 SAVEFREESV(save_sv);
1508 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1511 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1512 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1514 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1515 PL_sig_ignoring[i] = 0;
1517 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1518 PL_sig_defaulting[i] = 0;
1520 to_dec = PL_psig_ptr[i];
1522 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1523 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1525 /* Signals don't change name during the program's execution, so once
1526 they're cached in the appropriate slot of PL_psig_name, they can
1529 Ideally we'd find some way of making SVs at (C) compile time, or
1530 at least, doing most of the work. */
1531 if (!PL_psig_name[i]) {
1532 PL_psig_name[i] = newSVpvn(s, len);
1533 SvREADONLY_on(PL_psig_name[i]);
1536 SvREFCNT_dec(PL_psig_name[i]);
1537 PL_psig_name[i] = NULL;
1538 PL_psig_ptr[i] = NULL;
1541 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1543 (void)rsignal(i, PL_csighandlerp);
1546 *svp = SvREFCNT_inc_simple_NN(sv);
1548 if (sv && SvOK(sv)) {
1549 s = SvPV_force(sv, len);
1553 if (sv && strEQ(s,"IGNORE")) {
1555 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1556 PL_sig_ignoring[i] = 1;
1557 (void)rsignal(i, PL_csighandlerp);
1559 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1563 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1565 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1566 PL_sig_defaulting[i] = 1;
1567 (void)rsignal(i, PL_csighandlerp);
1569 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1575 * We should warn if HINT_STRICT_REFS, but without
1576 * access to a known hint bit in a known OP, we can't
1577 * tell whether HINT_STRICT_REFS is in force or not.
1579 if (!strchr(s,':') && !strchr(s,'\''))
1580 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1583 (void)rsignal(i, PL_csighandlerp);
1585 *svp = SvREFCNT_inc_simple_NN(sv);
1589 #ifdef HAS_SIGPROCMASK
1593 SvREFCNT_dec(to_dec);
1596 #endif /* !PERL_MICRO */
1599 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1602 PERL_ARGS_ASSERT_MAGIC_SETISA;
1603 PERL_UNUSED_ARG(sv);
1605 /* Skip _isaelem because _isa will handle it shortly */
1606 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1609 return magic_clearisa(NULL, mg);
1612 /* sv of NULL signifies that we're acting as magic_setisa. */
1614 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1619 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1621 /* Bail out if destruction is going on */
1622 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1625 av_clear(MUTABLE_AV(sv));
1627 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1628 /* This occurs with setisa_elem magic, which calls this
1630 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1632 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1633 SV **svp = AvARRAY((AV *)mg->mg_obj);
1634 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1636 stash = GvSTASH((GV *)*svp++);
1637 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1644 (const GV *)mg->mg_obj
1647 /* The stash may have been detached from the symbol table, so check its
1648 name before doing anything. */
1649 if (stash && HvENAME_get(stash))
1650 mro_isa_changed_in(stash);
1656 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1659 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1660 PERL_UNUSED_ARG(sv);
1661 PERL_UNUSED_ARG(mg);
1662 PL_amagic_generation++;
1668 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1670 HV * const hv = MUTABLE_HV(LvTARG(sv));
1673 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1674 PERL_UNUSED_ARG(mg);
1677 (void) hv_iterinit(hv);
1678 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1681 while (hv_iternext(hv))
1686 sv_setiv(sv, (IV)i);
1691 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1693 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1694 PERL_UNUSED_ARG(mg);
1696 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1702 =for apidoc magic_methcall
1704 Invoke a magic method (like FETCH).
1706 * sv and mg are the tied thinggy and the tie magic;
1707 * meth is the name of the method to call;
1708 * argc is the number of args (in addition to $self) to pass to the method;
1709 the args themselves are any values following the argc argument.
1711 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1712 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1714 Returns the SV (if any) returned by the method, or NULL on failure.
1721 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1728 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1731 PUSHSTACKi(PERLSI_MAGIC);
1735 PUSHs(SvTIED_obj(sv, mg));
1736 if (flags & G_UNDEF_FILL) {
1738 PUSHs(&PL_sv_undef);
1740 } else if (argc > 0) {
1742 va_start(args, argc);
1745 SV *const sv = va_arg(args, SV *);
1752 if (flags & G_DISCARD) {
1753 call_method(meth, G_SCALAR|G_DISCARD);
1756 if (call_method(meth, G_SCALAR))
1757 ret = *PL_stack_sp--;
1765 /* wrapper for magic_methcall that creates the first arg */
1768 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1774 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1777 if (mg->mg_len >= 0) {
1778 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1780 else if (mg->mg_len == HEf_SVKEY)
1781 arg1 = MUTABLE_SV(mg->mg_ptr);
1783 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1784 arg1 = newSViv((IV)(mg->mg_len));
1788 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1790 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1794 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1799 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1801 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1808 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1810 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1812 if (mg->mg_type == PERL_MAGIC_tiedelem)
1813 mg->mg_flags |= MGf_GSKIP;
1814 magic_methpack(sv,mg,"FETCH");
1819 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1825 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1827 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1828 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1829 * public flags indicate its value based on copying from $val. Doing
1830 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1831 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1832 * wrong if $val happened to be tainted, as sv hasn't got magic
1833 * enabled, even though taint magic is in the chain. In which case,
1834 * fake up a temporary tainted value (this is easier than temporarily
1835 * re-enabling magic on sv). */
1837 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1838 && (tmg->mg_len & 1))
1840 val = sv_mortalcopy(sv);
1846 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1851 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1853 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1855 return magic_methpack(sv,mg,"DELETE");
1860 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1866 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1868 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1870 retval = SvIV(retsv)-1;
1872 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1874 return (U32) retval;
1878 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1882 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1884 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1889 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1894 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1896 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1897 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1904 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1906 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1908 return magic_methpack(sv,mg,"EXISTS");
1912 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1916 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1917 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1919 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1921 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1923 if (HvEITER_get(hv))
1924 /* we are in an iteration so the hash cannot be empty */
1926 /* no xhv_eiter so now use FIRSTKEY */
1927 key = sv_newmortal();
1928 magic_nextpack(MUTABLE_SV(hv), mg, key);
1929 HvEITER_set(hv, NULL); /* need to reset iterator */
1930 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1933 /* there is a SCALAR method that we can call */
1934 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1936 retval = &PL_sv_undef;
1941 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1944 GV * const gv = PL_DBline;
1945 const I32 i = SvTRUE(sv);
1946 SV ** const svp = av_fetch(GvAV(gv),
1947 atoi(MgPV_nolen_const(mg)), FALSE);
1949 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1951 if (svp && SvIOKp(*svp)) {
1952 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1954 /* set or clear breakpoint in the relevant control op */
1956 o->op_flags |= OPf_SPECIAL;
1958 o->op_flags &= ~OPf_SPECIAL;
1965 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1968 AV * const obj = MUTABLE_AV(mg->mg_obj);
1970 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1973 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1981 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1984 AV * const obj = MUTABLE_AV(mg->mg_obj);
1986 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1989 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1991 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1992 "Attempt to set length of freed array");
1998 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2002 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2003 PERL_UNUSED_ARG(sv);
2005 /* during global destruction, mg_obj may already have been freed */
2006 if (PL_in_clean_all)
2009 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2012 /* arylen scalar holds a pointer back to the array, but doesn't own a
2013 reference. Hence the we (the array) are about to go away with it
2014 still pointing at us. Clear its pointer, else it would be pointing
2015 at free memory. See the comment in sv_magic about reference loops,
2016 and why it can't own a reference to us. */
2023 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2026 SV* const lsv = LvTARG(sv);
2028 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2029 PERL_UNUSED_ARG(mg);
2031 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2032 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2033 if (found && found->mg_len >= 0) {
2034 I32 i = found->mg_len;
2036 sv_pos_b2u(lsv, &i);
2037 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2046 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2049 SV* const lsv = LvTARG(sv);
2055 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2056 PERL_UNUSED_ARG(mg);
2058 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2059 found = mg_find(lsv, PERL_MAGIC_regex_global);
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2067 sv_force_normal_flags(lsv, 0);
2069 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2072 else if (!SvOK(sv)) {
2076 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2078 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2081 ulen = sv_len_utf8(lsv);
2091 else if (pos > (SSize_t)len)
2096 sv_pos_u2b(lsv, &p, 0);
2100 found->mg_len = pos;
2101 found->mg_flags &= ~MGf_MINMATCH;
2107 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2110 SV * const lsv = LvTARG(sv);
2111 const char * const tmps = SvPV_const(lsv,len);
2112 STRLEN offs = LvTARGOFF(sv);
2113 STRLEN rem = LvTARGLEN(sv);
2115 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2116 PERL_UNUSED_ARG(mg);
2119 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2122 if (rem > len - offs)
2124 sv_setpvn(sv, tmps + offs, rem);
2131 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2135 const char * const tmps = SvPV_const(sv, len);
2136 SV * const lsv = LvTARG(sv);
2137 STRLEN lvoff = LvTARGOFF(sv);
2138 STRLEN lvlen = LvTARGLEN(sv);
2140 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2141 PERL_UNUSED_ARG(mg);
2144 sv_utf8_upgrade(lsv);
2145 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2146 sv_insert(lsv, lvoff, lvlen, tmps, len);
2147 LvTARGLEN(sv) = sv_len_utf8(sv);
2150 else if (lsv && SvUTF8(lsv)) {
2152 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2153 LvTARGLEN(sv) = len;
2154 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2155 sv_insert(lsv, lvoff, lvlen, utf8, len);
2159 sv_insert(lsv, lvoff, lvlen, tmps, len);
2160 LvTARGLEN(sv) = len;
2167 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2171 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2172 PERL_UNUSED_ARG(sv);
2174 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2179 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2183 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2184 PERL_UNUSED_ARG(sv);
2186 /* update taint status */
2195 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2197 SV * const lsv = LvTARG(sv);
2199 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2200 PERL_UNUSED_ARG(mg);
2203 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2211 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2213 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2214 PERL_UNUSED_ARG(mg);
2215 do_vecset(sv); /* XXX slurp this routine */
2220 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2225 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2227 if (LvTARGLEN(sv)) {
2229 SV * const ahv = LvTARG(sv);
2230 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2235 AV *const av = MUTABLE_AV(LvTARG(sv));
2236 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2237 targ = AvARRAY(av)[LvTARGOFF(sv)];
2239 if (targ && (targ != &PL_sv_undef)) {
2240 /* somebody else defined it for us */
2241 SvREFCNT_dec(LvTARG(sv));
2242 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2244 SvREFCNT_dec(mg->mg_obj);
2246 mg->mg_flags &= ~MGf_REFCOUNTED;
2251 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2256 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2258 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2259 PERL_UNUSED_ARG(mg);
2263 sv_setsv(LvTARG(sv), sv);
2264 SvSETMAGIC(LvTARG(sv));
2270 Perl_vivify_defelem(pTHX_ SV *sv)
2276 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2278 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2281 SV * const ahv = LvTARG(sv);
2282 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2285 if (!value || value == &PL_sv_undef)
2286 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2289 AV *const av = MUTABLE_AV(LvTARG(sv));
2290 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2291 LvTARG(sv) = NULL; /* array can't be extended */
2293 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2294 if (!svp || (value = *svp) == &PL_sv_undef)
2295 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2298 SvREFCNT_inc_simple_void(value);
2299 SvREFCNT_dec(LvTARG(sv));
2302 SvREFCNT_dec(mg->mg_obj);
2304 mg->mg_flags &= ~MGf_REFCOUNTED;
2308 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2310 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2311 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2316 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2318 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2319 PERL_UNUSED_CONTEXT;
2321 if (!isGV_with_GP(sv))
2327 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2329 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2331 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2333 if (uf && uf->uf_set)
2334 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2339 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2341 const char type = mg->mg_type;
2343 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2345 if (type == PERL_MAGIC_qr) {
2346 } else if (type == PERL_MAGIC_bm) {
2350 assert(type == PERL_MAGIC_fm);
2353 return sv_unmagic(sv, type);
2356 #ifdef USE_LOCALE_COLLATE
2358 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2360 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2363 * RenE<eacute> Descartes said "I think not."
2364 * and vanished with a faint plop.
2366 PERL_UNUSED_CONTEXT;
2367 PERL_UNUSED_ARG(sv);
2369 Safefree(mg->mg_ptr);
2375 #endif /* USE_LOCALE_COLLATE */
2377 /* Just clear the UTF-8 cache data. */
2379 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2381 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2382 PERL_UNUSED_CONTEXT;
2383 PERL_UNUSED_ARG(sv);
2384 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2386 mg->mg_len = -1; /* The mg_len holds the len cache. */
2391 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2394 register const char *s;
2396 register const REGEXP * rx;
2397 const char * const remaining = mg->mg_ptr + 1;
2402 PERL_ARGS_ASSERT_MAGIC_SET;
2404 switch (*mg->mg_ptr) {
2405 case '\015': /* $^MATCH */
2406 if (strEQ(remaining, "ATCH"))
2408 case '`': /* ${^PREMATCH} caught below */
2410 paren = RX_BUFF_IDX_PREMATCH;
2412 case '\'': /* ${^POSTMATCH} caught below */
2414 paren = RX_BUFF_IDX_POSTMATCH;
2418 paren = RX_BUFF_IDX_FULLMATCH;
2420 case '1': case '2': case '3': case '4':
2421 case '5': case '6': case '7': case '8': case '9':
2422 paren = atoi(mg->mg_ptr);
2424 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2425 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2427 /* Croak with a READONLY error when a numbered match var is
2428 * set without a previous pattern match. Unless it's C<local $1>
2430 if (!PL_localizing) {
2431 Perl_croak_no_modify(aTHX);
2435 case '\001': /* ^A */
2436 sv_setsv(PL_bodytarget, sv);
2437 /* mg_set() has temporarily made sv non-magical */
2439 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2440 SvTAINTED_on(PL_bodytarget);
2442 SvTAINTED_off(PL_bodytarget);
2445 case '\003': /* ^C */
2446 PL_minus_c = cBOOL(SvIV(sv));
2449 case '\004': /* ^D */
2451 s = SvPV_nolen_const(sv);
2452 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2453 if (DEBUG_x_TEST || DEBUG_B_TEST)
2454 dump_all_perl(!DEBUG_B_TEST);
2456 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2459 case '\005': /* ^E */
2460 if (*(mg->mg_ptr+1) == '\0') {
2462 set_vaxc_errno(SvIV(sv));
2465 SetLastError( SvIV(sv) );
2468 os2_setsyserrno(SvIV(sv));
2470 /* will anyone ever use this? */
2471 SETERRNO(SvIV(sv), 4);
2476 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2477 SvREFCNT_dec(PL_encoding);
2478 if (SvOK(sv) || SvGMAGICAL(sv)) {
2479 PL_encoding = newSVsv(sv);
2486 case '\006': /* ^F */
2487 PL_maxsysfd = SvIV(sv);
2489 case '\010': /* ^H */
2490 PL_hints = SvIV(sv);
2492 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2493 Safefree(PL_inplace);
2494 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2496 case '\017': /* ^O */
2497 if (*(mg->mg_ptr+1) == '\0') {
2498 Safefree(PL_osname);
2501 TAINT_PROPER("assigning to $^O");
2502 PL_osname = savesvpv(sv);
2505 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2507 const char *const start = SvPV(sv, len);
2508 const char *out = (const char*)memchr(start, '\0', len);
2512 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2513 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2515 /* Opening for input is more common than opening for output, so
2516 ensure that hints for input are sooner on linked list. */
2517 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2519 : newSVpvs_flags("", SvUTF8(sv));
2520 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2523 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2525 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2529 case '\020': /* ^P */
2530 if (*remaining == '\0') { /* ^P */
2531 PL_perldb = SvIV(sv);
2532 if (PL_perldb && !PL_DBsingle)
2535 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2537 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2541 case '\024': /* ^T */
2543 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2545 PL_basetime = (Time_t)SvIV(sv);
2548 case '\025': /* ^UTF8CACHE */
2549 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2550 PL_utf8cache = (signed char) sv_2iv(sv);
2553 case '\027': /* ^W & $^WARNING_BITS */
2554 if (*(mg->mg_ptr+1) == '\0') {
2555 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2557 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2558 | (i ? G_WARN_ON : G_WARN_OFF) ;
2561 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2562 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2563 if (!SvPOK(sv) && PL_localizing) {
2564 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2565 PL_compiling.cop_warnings = pWARN_NONE;
2570 int accumulate = 0 ;
2571 int any_fatals = 0 ;
2572 const char * const ptr = SvPV_const(sv, len) ;
2573 for (i = 0 ; i < len ; ++i) {
2574 accumulate |= ptr[i] ;
2575 any_fatals |= (ptr[i] & 0xAA) ;
2578 if (!specialWARN(PL_compiling.cop_warnings))
2579 PerlMemShared_free(PL_compiling.cop_warnings);
2580 PL_compiling.cop_warnings = pWARN_NONE;
2582 /* Yuck. I can't see how to abstract this: */
2583 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2584 WARN_ALL) && !any_fatals) {
2585 if (!specialWARN(PL_compiling.cop_warnings))
2586 PerlMemShared_free(PL_compiling.cop_warnings);
2587 PL_compiling.cop_warnings = pWARN_ALL;
2588 PL_dowarn |= G_WARN_ONCE ;
2592 const char *const p = SvPV_const(sv, len);
2594 PL_compiling.cop_warnings
2595 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2598 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2599 PL_dowarn |= G_WARN_ONCE ;
2607 if (PL_localizing) {
2608 if (PL_localizing == 1)
2609 SAVESPTR(PL_last_in_gv);
2611 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2612 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2615 if (isGV_with_GP(PL_defoutgv)) {
2616 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2617 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2618 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2622 if (isGV_with_GP(PL_defoutgv)) {
2623 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2624 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2625 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2629 if (isGV_with_GP(PL_defoutgv))
2630 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2633 if (isGV_with_GP(PL_defoutgv)) {
2634 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2635 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2636 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2640 if (isGV_with_GP(PL_defoutgv))
2641 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2645 IO * const io = GvIO(PL_defoutgv);
2648 if ((SvIV(sv)) == 0)
2649 IoFLAGS(io) &= ~IOf_FLUSH;
2651 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2652 PerlIO *ofp = IoOFP(io);
2654 (void)PerlIO_flush(ofp);
2655 IoFLAGS(io) |= IOf_FLUSH;
2661 SvREFCNT_dec(PL_rs);
2662 PL_rs = newSVsv(sv);
2665 SvREFCNT_dec(PL_ors_sv);
2666 if (SvOK(sv) || SvGMAGICAL(sv)) {
2667 PL_ors_sv = newSVsv(sv);
2674 CopARYBASE_set(&PL_compiling, SvIV(sv));
2677 #ifdef COMPLEX_STATUS
2678 if (PL_localizing == 2) {
2679 SvUPGRADE(sv, SVt_PVLV);
2680 PL_statusvalue = LvTARGOFF(sv);
2681 PL_statusvalue_vms = LvTARGLEN(sv);
2685 #ifdef VMSISH_STATUS
2687 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2690 STATUS_UNIX_EXIT_SET(SvIV(sv));
2695 # define PERL_VMS_BANG vaxc$errno
2697 # define PERL_VMS_BANG 0
2699 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2700 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2705 if (PL_delaymagic) {
2706 PL_delaymagic |= DM_RUID;
2707 break; /* don't do magic till later */
2710 (void)setruid((Uid_t)PL_uid);
2713 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2715 #ifdef HAS_SETRESUID
2716 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2718 if (PL_uid == PL_euid) { /* special case $< = $> */
2720 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2721 if (PL_uid != 0 && PerlProc_getuid() == 0)
2722 (void)PerlProc_setuid(0);
2724 (void)PerlProc_setuid(PL_uid);
2726 PL_uid = PerlProc_getuid();
2727 Perl_croak(aTHX_ "setruid() not implemented");
2732 PL_uid = PerlProc_getuid();
2736 if (PL_delaymagic) {
2737 PL_delaymagic |= DM_EUID;
2738 break; /* don't do magic till later */
2741 (void)seteuid((Uid_t)PL_euid);
2744 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2746 #ifdef HAS_SETRESUID
2747 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2749 if (PL_euid == PL_uid) /* special case $> = $< */
2750 PerlProc_setuid(PL_euid);
2752 PL_euid = PerlProc_geteuid();
2753 Perl_croak(aTHX_ "seteuid() not implemented");
2758 PL_euid = PerlProc_geteuid();
2762 if (PL_delaymagic) {
2763 PL_delaymagic |= DM_RGID;
2764 break; /* don't do magic till later */
2767 (void)setrgid((Gid_t)PL_gid);
2770 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2772 #ifdef HAS_SETRESGID
2773 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2775 if (PL_gid == PL_egid) /* special case $( = $) */
2776 (void)PerlProc_setgid(PL_gid);
2778 PL_gid = PerlProc_getgid();
2779 Perl_croak(aTHX_ "setrgid() not implemented");
2784 PL_gid = PerlProc_getgid();
2787 #ifdef HAS_SETGROUPS
2789 const char *p = SvPV_const(sv, len);
2790 Groups_t *gary = NULL;
2791 #ifdef _SC_NGROUPS_MAX
2792 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2797 int maxgrp = NGROUPS;
2803 for (i = 0; i < maxgrp; ++i) {
2804 while (*p && !isSPACE(*p))
2811 Newx(gary, i + 1, Groups_t);
2813 Renew(gary, i + 1, Groups_t);
2817 (void)setgroups(i, gary);
2820 #else /* HAS_SETGROUPS */
2822 #endif /* HAS_SETGROUPS */
2823 if (PL_delaymagic) {
2824 PL_delaymagic |= DM_EGID;
2825 break; /* don't do magic till later */
2828 (void)setegid((Gid_t)PL_egid);
2831 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2833 #ifdef HAS_SETRESGID
2834 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2836 if (PL_egid == PL_gid) /* special case $) = $( */
2837 (void)PerlProc_setgid(PL_egid);
2839 PL_egid = PerlProc_getegid();
2840 Perl_croak(aTHX_ "setegid() not implemented");
2845 PL_egid = PerlProc_getegid();
2848 PL_chopset = SvPV_force(sv,len);
2851 LOCK_DOLLARZERO_MUTEX;
2852 #ifdef HAS_SETPROCTITLE
2853 /* The BSDs don't show the argv[] in ps(1) output, they
2854 * show a string from the process struct and provide
2855 * the setproctitle() routine to manipulate that. */
2856 if (PL_origalen != 1) {
2857 s = SvPV_const(sv, len);
2858 # if __FreeBSD_version > 410001
2859 /* The leading "-" removes the "perl: " prefix,
2860 * but not the "(perl) suffix from the ps(1)
2861 * output, because that's what ps(1) shows if the
2862 * argv[] is modified. */
2863 setproctitle("-%s", s);
2864 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2865 /* This doesn't really work if you assume that
2866 * $0 = 'foobar'; will wipe out 'perl' from the $0
2867 * because in ps(1) output the result will be like
2868 * sprintf("perl: %s (perl)", s)
2869 * I guess this is a security feature:
2870 * one (a user process) cannot get rid of the original name.
2872 setproctitle("%s", s);
2875 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2876 if (PL_origalen != 1) {
2878 s = SvPV_const(sv, len);
2879 un.pst_command = (char *)s;
2880 pstat(PSTAT_SETCMD, un, len, 0, 0);
2883 if (PL_origalen > 1) {
2884 /* PL_origalen is set in perl_parse(). */
2885 s = SvPV_force(sv,len);
2886 if (len >= (STRLEN)PL_origalen-1) {
2887 /* Longer than original, will be truncated. We assume that
2888 * PL_origalen bytes are available. */
2889 Copy(s, PL_origargv[0], PL_origalen-1, char);
2892 /* Shorter than original, will be padded. */
2894 /* Special case for Mac OS X: see [perl #38868] */
2897 /* Is the space counterintuitive? Yes.
2898 * (You were expecting \0?)
2899 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2901 const int pad = ' ';
2903 Copy(s, PL_origargv[0], len, char);
2904 PL_origargv[0][len] = 0;
2905 memset(PL_origargv[0] + len + 1,
2906 pad, PL_origalen - len - 1);
2908 PL_origargv[0][PL_origalen-1] = 0;
2909 for (i = 1; i < PL_origargc; i++)
2911 #ifdef HAS_PRCTL_SET_NAME
2912 /* Set the legacy process name in addition to the POSIX name on Linux */
2913 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2914 /* diag_listed_as: SKIPME */
2915 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2920 UNLOCK_DOLLARZERO_MUTEX;
2927 Perl_whichsig(pTHX_ const char *sig)
2929 register char* const* sigv;
2931 PERL_ARGS_ASSERT_WHICHSIG;
2932 PERL_UNUSED_CONTEXT;
2934 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2935 if (strEQ(sig,*sigv))
2936 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2938 if (strEQ(sig,"CHLD"))
2942 if (strEQ(sig,"CLD"))
2949 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2950 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2952 Perl_sighandler(int sig)
2955 #ifdef PERL_GET_SIG_CONTEXT
2956 dTHXa(PERL_GET_SIG_CONTEXT);
2963 SV * const tSv = PL_Sv;
2967 XPV * const tXpv = PL_Xpv;
2968 I32 old_ss_ix = PL_savestack_ix;
2971 if (!PL_psig_ptr[sig]) {
2972 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2977 /* Max number of items pushed there is 3*n or 4. We cannot fix
2978 infinity, so we fix 4 (in fact 5): */
2979 if (PL_savestack_ix + 15 <= PL_savestack_max) {
2981 PL_savestack_ix += 5; /* Protect save in progress. */
2982 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
2984 if (PL_markstack_ptr < PL_markstack_max - 2) {
2986 PL_markstack_ptr++; /* Protect mark. */
2988 if (PL_scopestack_ix < PL_scopestack_max - 3) {
2992 /* sv_2cv is too complicated, try a simpler variant first: */
2993 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2994 || SvTYPE(cv) != SVt_PVCV) {
2996 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2999 if (!cv || !CvROOT(cv)) {
3000 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3001 PL_sig_name[sig], (gv ? GvENAME(gv)
3008 sv = PL_psig_name[sig]
3009 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3010 : newSVpv(PL_sig_name[sig],0);
3014 /* make sure our assumption about the size of the SAVEs are correct:
3015 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3016 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3018 PUSHSTACKi(PERLSI_SIGNAL);
3021 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3023 struct sigaction oact;
3025 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3028 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3029 /* The siginfo fields signo, code, errno, pid, uid,
3030 * addr, status, and band are defined by POSIX/SUSv3. */
3031 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3032 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3033 #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. */
3034 hv_stores(sih, "errno", newSViv(sip->si_errno));
3035 hv_stores(sih, "status", newSViv(sip->si_status));
3036 hv_stores(sih, "uid", newSViv(sip->si_uid));
3037 hv_stores(sih, "pid", newSViv(sip->si_pid));
3038 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3039 hv_stores(sih, "band", newSViv(sip->si_band));
3043 mPUSHp((char *)sip, sizeof(*sip));
3051 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3054 if (SvTRUE(ERRSV)) {
3056 #ifdef HAS_SIGPROCMASK
3057 /* Handler "died", for example to get out of a restart-able read().
3058 * Before we re-do that on its behalf re-enable the signal which was
3059 * blocked by the system when we entered.
3063 sigaddset(&set,sig);
3064 sigprocmask(SIG_UNBLOCK, &set, NULL);
3066 /* Not clear if this will work */
3067 (void)rsignal(sig, SIG_IGN);
3068 (void)rsignal(sig, PL_csighandlerp);
3070 #endif /* !PERL_MICRO */
3074 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3075 PL_savestack_ix = old_ss_ix;
3079 PL_scopestack_ix -= 1;
3082 PL_op = myop; /* Apparently not needed... */
3084 PL_Sv = tSv; /* Restore global temporaries. */
3091 S_restore_magic(pTHX_ const void *p)
3094 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3095 SV* const sv = mgs->mgs_sv;
3100 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3102 #ifdef PERL_OLD_COPY_ON_WRITE
3103 /* While magic was saved (and off) sv_setsv may well have seen
3104 this SV as a prime candidate for COW. */
3106 sv_force_normal_flags(sv, 0);
3109 if (mgs->mgs_readonly)
3111 if (mgs->mgs_magical)
3112 SvFLAGS(sv) |= mgs->mgs_magical;
3115 if (SvGMAGICAL(sv)) {
3116 /* downgrade public flags to private,
3117 and discard any other private flags */
3119 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3121 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3122 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3127 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3129 /* If we're still on top of the stack, pop us off. (That condition
3130 * will be satisfied if restore_magic was called explicitly, but *not*
3131 * if it's being called via leave_scope.)
3132 * The reason for doing this is that otherwise, things like sv_2cv()
3133 * may leave alloc gunk on the savestack, and some code
3134 * (e.g. sighandler) doesn't expect that...
3136 if (PL_savestack_ix == mgs->mgs_ss_ix)
3138 UV popval = SSPOPUV;
3139 assert(popval == SAVEt_DESTRUCTOR_X);
3140 PL_savestack_ix -= 2;
3142 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3143 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3148 /* clean up the mess created by Perl_sighandler().
3149 * Note that this is only called during an exit in a signal handler;
3150 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3151 * skipped over. This is why we don't need to fix up the markstack and
3152 * scopestack - they're going to be set to 0 anyway */
3155 S_unwind_handler_stack(pTHX_ const void *p)
3160 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3164 =for apidoc magic_sethint
3166 Triggered by a store to %^H, records the key/value pair to
3167 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3168 anything that would need a deep copy. Maybe we should warn if we find a
3174 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3177 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3178 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3180 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3182 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3183 an alternative leaf in there, with PL_compiling.cop_hints being used if
3184 it's NULL. If needed for threads, the alternative could lock a mutex,
3185 or take other more complex action. */
3187 /* Something changed in %^H, so it will need to be restored on scope exit.
3188 Doing this here saves a lot of doing it manually in perl code (and
3189 forgetting to do it, and consequent subtle errors. */
3190 PL_hints |= HINT_LOCALIZE_HH;
3191 CopHINTHASH_set(&PL_compiling,
3192 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3197 =for apidoc magic_clearhint
3199 Triggered by a delete from %^H, records the key to
3200 C<PL_compiling.cop_hints_hash>.
3205 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3209 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3210 PERL_UNUSED_ARG(sv);
3212 assert(mg->mg_len == HEf_SVKEY);
3214 PERL_UNUSED_ARG(sv);
3216 PL_hints |= HINT_LOCALIZE_HH;
3217 CopHINTHASH_set(&PL_compiling,
3218 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3219 MUTABLE_SV(mg->mg_ptr), 0, 0));
3224 =for apidoc magic_clearhints
3226 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3231 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3233 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3234 PERL_UNUSED_ARG(sv);
3235 PERL_UNUSED_ARG(mg);
3236 cophh_free(CopHINTHASH_get(&PL_compiling));
3237 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3243 * c-indentation-style: bsd
3245 * indent-tabs-mode: t
3248 * ex: set ts=8 sts=4 sw=4 noet: