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);
813 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
814 if (nextchar == '\0') {
815 sv_setiv(sv, (IV)PL_minus_c);
817 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
818 sv_setiv(sv, (IV)STATUS_NATIVE);
822 case '\004': /* ^D */
823 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
825 case '\005': /* ^E */
826 if (nextchar == '\0') {
829 # include <descrip.h>
830 # include <starlet.h>
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) {
951 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
955 else if (PL_compiling.cop_warnings == pWARN_ALL) {
956 /* Get the bit mask for $warnings::Bits{all}, because
957 * it could have been extended by warnings::register */
958 HV * const bits=get_hv("warnings::Bits", 0);
960 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
962 sv_setsv(sv, *bits_all);
965 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
969 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
970 *PL_compiling.cop_warnings);
975 case '\015': /* $^MATCH */
976 if (strEQ(remaining, "ATCH")) {
977 case '1': case '2': case '3': case '4':
978 case '5': case '6': case '7': case '8': case '9': case '&':
979 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
981 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
982 * XXX Does the new way break anything?
984 paren = atoi(mg->mg_ptr); /* $& is in [0] */
985 CALLREG_NUMBUF_FETCH(rx,paren,sv);
988 sv_setsv(sv,&PL_sv_undef);
992 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
993 if (RX_LASTPAREN(rx)) {
994 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
998 sv_setsv(sv,&PL_sv_undef);
1000 case '\016': /* ^N */
1001 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1002 if (RX_LASTCLOSEPAREN(rx)) {
1003 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1008 sv_setsv(sv,&PL_sv_undef);
1012 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1013 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1016 sv_setsv(sv,&PL_sv_undef);
1020 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1021 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1024 sv_setsv(sv,&PL_sv_undef);
1027 if (GvIO(PL_last_in_gv)) {
1028 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1033 sv_setiv(sv, (IV)STATUS_CURRENT);
1034 #ifdef COMPLEX_STATUS
1035 SvUPGRADE(sv, SVt_PVLV);
1036 LvTARGOFF(sv) = PL_statusvalue;
1037 LvTARGLEN(sv) = PL_statusvalue_vms;
1042 if (!isGV_with_GP(PL_defoutgv))
1044 else if (GvIOp(PL_defoutgv))
1045 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1049 sv_setpv(sv,GvENAME(PL_defoutgv));
1050 sv_catpvs(sv,"_TOP");
1054 if (!isGV_with_GP(PL_defoutgv))
1056 else if (GvIOp(PL_defoutgv))
1057 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1059 s = GvENAME(PL_defoutgv);
1063 if (GvIO(PL_defoutgv))
1064 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1067 if (GvIO(PL_defoutgv))
1068 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1071 if (GvIO(PL_defoutgv))
1072 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1079 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1082 if (GvIO(PL_defoutgv))
1083 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1087 sv_copypv(sv, PL_ors_sv);
1093 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1095 sv_setnv(sv, (NV)errno);
1098 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1099 sv_setpv(sv, os2error(Perl_rc));
1102 sv_setpv(sv, errno ? Strerror(errno) : "");
1104 SvPOK_on(sv); /* may have got removed during taint processing */
1109 SvNOK_on(sv); /* what a wonderful hack! */
1112 sv_setiv(sv, (IV)PL_uid);
1115 sv_setiv(sv, (IV)PL_euid);
1118 sv_setiv(sv, (IV)PL_gid);
1121 sv_setiv(sv, (IV)PL_egid);
1123 #ifdef HAS_GETGROUPS
1125 Groups_t *gary = NULL;
1126 I32 i, num_groups = getgroups(0, gary);
1127 Newx(gary, num_groups, Groups_t);
1128 num_groups = getgroups(num_groups, gary);
1129 for (i = 0; i < num_groups; i++)
1130 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1133 (void)SvIOK_on(sv); /* what a wonderful hack! */
1143 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1145 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1147 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1149 if (uf && uf->uf_val)
1150 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1155 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1158 STRLEN len = 0, klen;
1159 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1160 const char * const ptr = MgPV_const(mg,klen);
1163 PERL_ARGS_ASSERT_MAGIC_SETENV;
1165 #ifdef DYNAMIC_ENV_FETCH
1166 /* We just undefd an environment var. Is a replacement */
1167 /* waiting in the wings? */
1169 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1171 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1175 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1176 /* And you'll never guess what the dog had */
1177 /* in its mouth... */
1179 MgTAINTEDDIR_off(mg);
1181 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1182 char pathbuf[256], eltbuf[256], *cp, *elt;
1186 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1188 do { /* DCL$PATH may be a search list */
1189 while (1) { /* as may dev portion of any element */
1190 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1191 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1192 cando_by_name(S_IWUSR,0,elt) ) {
1193 MgTAINTEDDIR_on(mg);
1197 if ((cp = strchr(elt, ':')) != NULL)
1199 if (my_trnlnm(elt, eltbuf, j++))
1205 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1208 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1209 const char * const strend = s + len;
1211 while (s < strend) {
1215 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1216 const char path_sep = '|';
1218 const char path_sep = ':';
1220 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1221 s, strend, path_sep, &i);
1223 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1225 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1227 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1229 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1230 MgTAINTEDDIR_on(mg);
1236 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1242 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1244 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1245 PERL_UNUSED_ARG(sv);
1246 my_setenv(MgPV_nolen_const(mg),NULL);
1251 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1254 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1255 PERL_UNUSED_ARG(mg);
1257 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1259 if (PL_localizing) {
1262 hv_iterinit(MUTABLE_HV(sv));
1263 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1265 my_setenv(hv_iterkey(entry, &keylen),
1266 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1274 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1277 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1278 PERL_UNUSED_ARG(sv);
1279 PERL_UNUSED_ARG(mg);
1281 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1289 #ifdef HAS_SIGPROCMASK
1291 restore_sigmask(pTHX_ SV *save_sv)
1293 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1294 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1298 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1301 /* Are we fetching a signal entry? */
1302 int i = (I16)mg->mg_private;
1304 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1307 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1312 sv_setsv(sv,PL_psig_ptr[i]);
1314 Sighandler_t sigstate = rsignal_state(i);
1315 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1316 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1319 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1320 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1323 /* cache state so we don't fetch it again */
1324 if(sigstate == (Sighandler_t) SIG_IGN)
1325 sv_setpvs(sv,"IGNORE");
1327 sv_setsv(sv,&PL_sv_undef);
1328 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1335 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1337 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1338 PERL_UNUSED_ARG(sv);
1340 magic_setsig(NULL, mg);
1341 return sv_unmagic(sv, mg->mg_type);
1345 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1346 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1348 Perl_csighandler(int sig)
1351 #ifdef PERL_GET_SIG_CONTEXT
1352 dTHXa(PERL_GET_SIG_CONTEXT);
1356 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1357 (void) rsignal(sig, PL_csighandlerp);
1358 if (PL_sig_ignoring[sig]) return;
1360 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1361 if (PL_sig_defaulting[sig])
1362 #ifdef KILL_BY_SIGPRC
1363 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1378 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1379 /* Call the perl level handler now--
1380 * with risk we may be in malloc() or being destructed etc. */
1381 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1382 (*PL_sighandlerp)(sig, NULL, NULL);
1384 (*PL_sighandlerp)(sig);
1387 if (!PL_psig_pend) return;
1388 /* Set a flag to say this signal is pending, that is awaiting delivery after
1389 * the current Perl opcode completes */
1390 PL_psig_pend[sig]++;
1392 #ifndef SIG_PENDING_DIE_COUNT
1393 # define SIG_PENDING_DIE_COUNT 120
1395 /* Add one to say _a_ signal is pending */
1396 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1397 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1398 (unsigned long)SIG_PENDING_DIE_COUNT);
1402 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1404 Perl_csighandler_init(void)
1407 if (PL_sig_handlers_initted) return;
1409 for (sig = 1; sig < SIG_SIZE; sig++) {
1410 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1412 PL_sig_defaulting[sig] = 1;
1413 (void) rsignal(sig, PL_csighandlerp);
1415 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1416 PL_sig_ignoring[sig] = 0;
1419 PL_sig_handlers_initted = 1;
1424 Perl_despatch_signals(pTHX)
1429 for (sig = 1; sig < SIG_SIZE; sig++) {
1430 if (PL_psig_pend[sig]) {
1432 PERL_BLOCKSIG_ADD(set, sig);
1433 PL_psig_pend[sig] = 0;
1434 PERL_BLOCKSIG_BLOCK(set);
1435 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1436 (*PL_sighandlerp)(sig, NULL, NULL);
1438 (*PL_sighandlerp)(sig);
1440 PERL_BLOCKSIG_UNBLOCK(set);
1446 /* sv of NULL signifies that we're acting as magic_clearsig. */
1448 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1453 /* Need to be careful with SvREFCNT_dec(), because that can have side
1454 * effects (due to closures). We must make sure that the new disposition
1455 * is in place before it is called.
1459 #ifdef HAS_SIGPROCMASK
1463 register const char *s = MgPV_const(mg,len);
1465 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1468 if (strEQ(s,"__DIE__"))
1470 else if (strEQ(s,"__WARN__")
1471 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1472 /* Merge the existing behaviours, which are as follows:
1473 magic_setsig, we always set svp to &PL_warnhook
1474 (hence we always change the warnings handler)
1475 For magic_clearsig, we don't change the warnings handler if it's
1476 set to the &PL_warnhook. */
1479 Perl_croak(aTHX_ "No such hook: %s", s);
1482 if (*svp != PERL_WARNHOOK_FATAL)
1488 i = (I16)mg->mg_private;
1490 i = whichsig(s); /* ...no, a brick */
1491 mg->mg_private = (U16)i;
1495 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1498 #ifdef HAS_SIGPROCMASK
1499 /* Avoid having the signal arrive at a bad time, if possible. */
1502 sigprocmask(SIG_BLOCK, &set, &save);
1504 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1505 SAVEFREESV(save_sv);
1506 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1509 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1510 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1512 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1513 PL_sig_ignoring[i] = 0;
1515 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1516 PL_sig_defaulting[i] = 0;
1518 to_dec = PL_psig_ptr[i];
1520 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1521 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1523 /* Signals don't change name during the program's execution, so once
1524 they're cached in the appropriate slot of PL_psig_name, they can
1527 Ideally we'd find some way of making SVs at (C) compile time, or
1528 at least, doing most of the work. */
1529 if (!PL_psig_name[i]) {
1530 PL_psig_name[i] = newSVpvn(s, len);
1531 SvREADONLY_on(PL_psig_name[i]);
1534 SvREFCNT_dec(PL_psig_name[i]);
1535 PL_psig_name[i] = NULL;
1536 PL_psig_ptr[i] = NULL;
1539 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1541 (void)rsignal(i, PL_csighandlerp);
1544 *svp = SvREFCNT_inc_simple_NN(sv);
1546 if (sv && SvOK(sv)) {
1547 s = SvPV_force(sv, len);
1551 if (sv && strEQ(s,"IGNORE")) {
1553 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1554 PL_sig_ignoring[i] = 1;
1555 (void)rsignal(i, PL_csighandlerp);
1557 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1561 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1563 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1564 PL_sig_defaulting[i] = 1;
1565 (void)rsignal(i, PL_csighandlerp);
1567 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1573 * We should warn if HINT_STRICT_REFS, but without
1574 * access to a known hint bit in a known OP, we can't
1575 * tell whether HINT_STRICT_REFS is in force or not.
1577 if (!strchr(s,':') && !strchr(s,'\''))
1578 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1581 (void)rsignal(i, PL_csighandlerp);
1583 *svp = SvREFCNT_inc_simple_NN(sv);
1587 #ifdef HAS_SIGPROCMASK
1591 SvREFCNT_dec(to_dec);
1594 #endif /* !PERL_MICRO */
1597 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1600 PERL_ARGS_ASSERT_MAGIC_SETISA;
1601 PERL_UNUSED_ARG(sv);
1603 /* Skip _isaelem because _isa will handle it shortly */
1604 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1607 return magic_clearisa(NULL, mg);
1610 /* sv of NULL signifies that we're acting as magic_setisa. */
1612 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1617 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1619 /* Bail out if destruction is going on */
1620 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1623 av_clear(MUTABLE_AV(sv));
1625 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1626 /* This occurs with setisa_elem magic, which calls this
1628 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1630 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1631 SV **svp = AvARRAY((AV *)mg->mg_obj);
1632 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1634 stash = GvSTASH((GV *)*svp++);
1635 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1642 (const GV *)mg->mg_obj
1645 /* The stash may have been detached from the symbol table, so check its
1646 name before doing anything. */
1647 if (stash && HvENAME_get(stash))
1648 mro_isa_changed_in(stash);
1654 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1657 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1658 PERL_UNUSED_ARG(sv);
1659 PERL_UNUSED_ARG(mg);
1660 PL_amagic_generation++;
1666 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1668 HV * const hv = MUTABLE_HV(LvTARG(sv));
1671 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1672 PERL_UNUSED_ARG(mg);
1675 (void) hv_iterinit(hv);
1676 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1679 while (hv_iternext(hv))
1684 sv_setiv(sv, (IV)i);
1689 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1691 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1692 PERL_UNUSED_ARG(mg);
1694 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1700 =for apidoc magic_methcall
1702 Invoke a magic method (like FETCH).
1704 * sv and mg are the tied thinggy and the tie magic;
1705 * meth is the name of the method to call;
1706 * argc is the number of args (in addition to $self) to pass to the method;
1707 the args themselves are any values following the argc argument.
1709 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1710 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1712 Returns the SV (if any) returned by the method, or NULL on failure.
1719 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1726 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1729 PUSHSTACKi(PERLSI_MAGIC);
1733 PUSHs(SvTIED_obj(sv, mg));
1734 if (flags & G_UNDEF_FILL) {
1736 PUSHs(&PL_sv_undef);
1738 } else if (argc > 0) {
1740 va_start(args, argc);
1743 SV *const sv = va_arg(args, SV *);
1750 if (flags & G_DISCARD) {
1751 call_method(meth, G_SCALAR|G_DISCARD);
1754 if (call_method(meth, G_SCALAR))
1755 ret = *PL_stack_sp--;
1763 /* wrapper for magic_methcall that creates the first arg */
1766 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1772 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1775 if (mg->mg_len >= 0) {
1776 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1778 else if (mg->mg_len == HEf_SVKEY)
1779 arg1 = MUTABLE_SV(mg->mg_ptr);
1781 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1782 arg1 = newSViv((IV)(mg->mg_len));
1786 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1788 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1792 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1797 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1799 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1806 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1808 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1810 if (mg->mg_type == PERL_MAGIC_tiedelem)
1811 mg->mg_flags |= MGf_GSKIP;
1812 magic_methpack(sv,mg,"FETCH");
1817 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1823 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1825 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1826 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1827 * public flags indicate its value based on copying from $val. Doing
1828 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1829 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1830 * wrong if $val happened to be tainted, as sv hasn't got magic
1831 * enabled, even though taint magic is in the chain. In which case,
1832 * fake up a temporary tainted value (this is easier than temporarily
1833 * re-enabling magic on sv). */
1835 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1836 && (tmg->mg_len & 1))
1838 val = sv_mortalcopy(sv);
1844 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1849 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1853 return magic_methpack(sv,mg,"DELETE");
1858 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1864 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1866 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1868 retval = SvIV(retsv)-1;
1870 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1872 return (U32) retval;
1876 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1880 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1882 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1887 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1892 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1894 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1895 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1902 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1904 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1906 return magic_methpack(sv,mg,"EXISTS");
1910 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1914 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1915 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1917 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1919 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1921 if (HvEITER_get(hv))
1922 /* we are in an iteration so the hash cannot be empty */
1924 /* no xhv_eiter so now use FIRSTKEY */
1925 key = sv_newmortal();
1926 magic_nextpack(MUTABLE_SV(hv), mg, key);
1927 HvEITER_set(hv, NULL); /* need to reset iterator */
1928 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1931 /* there is a SCALAR method that we can call */
1932 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1934 retval = &PL_sv_undef;
1939 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1942 GV * const gv = PL_DBline;
1943 const I32 i = SvTRUE(sv);
1944 SV ** const svp = av_fetch(GvAV(gv),
1945 atoi(MgPV_nolen_const(mg)), FALSE);
1947 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1949 if (svp && SvIOKp(*svp)) {
1950 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1952 /* set or clear breakpoint in the relevant control op */
1954 o->op_flags |= OPf_SPECIAL;
1956 o->op_flags &= ~OPf_SPECIAL;
1963 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1966 AV * const obj = MUTABLE_AV(mg->mg_obj);
1968 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1971 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1979 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1982 AV * const obj = MUTABLE_AV(mg->mg_obj);
1984 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1987 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1989 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1990 "Attempt to set length of freed array");
1996 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2000 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2001 PERL_UNUSED_ARG(sv);
2003 /* during global destruction, mg_obj may already have been freed */
2004 if (PL_in_clean_all)
2007 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2010 /* arylen scalar holds a pointer back to the array, but doesn't own a
2011 reference. Hence the we (the array) are about to go away with it
2012 still pointing at us. Clear its pointer, else it would be pointing
2013 at free memory. See the comment in sv_magic about reference loops,
2014 and why it can't own a reference to us. */
2021 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2024 SV* const lsv = LvTARG(sv);
2026 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2027 PERL_UNUSED_ARG(mg);
2029 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2030 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2031 if (found && found->mg_len >= 0) {
2032 I32 i = found->mg_len;
2034 sv_pos_b2u(lsv, &i);
2035 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2044 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2047 SV* const lsv = LvTARG(sv);
2053 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2054 PERL_UNUSED_ARG(mg);
2056 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2057 found = mg_find(lsv, PERL_MAGIC_regex_global);
2063 #ifdef PERL_OLD_COPY_ON_WRITE
2065 sv_force_normal_flags(lsv, 0);
2067 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2070 else if (!SvOK(sv)) {
2074 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2076 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2079 ulen = sv_len_utf8(lsv);
2089 else if (pos > (SSize_t)len)
2094 sv_pos_u2b(lsv, &p, 0);
2098 found->mg_len = pos;
2099 found->mg_flags &= ~MGf_MINMATCH;
2105 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2108 SV * const lsv = LvTARG(sv);
2109 const char * const tmps = SvPV_const(lsv,len);
2110 STRLEN offs = LvTARGOFF(sv);
2111 STRLEN rem = LvTARGLEN(sv);
2113 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2114 PERL_UNUSED_ARG(mg);
2117 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2120 if (rem > len - offs)
2122 sv_setpvn(sv, tmps + offs, rem);
2129 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2133 const char * const tmps = SvPV_const(sv, len);
2134 SV * const lsv = LvTARG(sv);
2135 STRLEN lvoff = LvTARGOFF(sv);
2136 STRLEN lvlen = LvTARGLEN(sv);
2138 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2139 PERL_UNUSED_ARG(mg);
2142 sv_utf8_upgrade(lsv);
2143 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2144 sv_insert(lsv, lvoff, lvlen, tmps, len);
2145 LvTARGLEN(sv) = sv_len_utf8(sv);
2148 else if (lsv && SvUTF8(lsv)) {
2150 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2151 LvTARGLEN(sv) = len;
2152 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2153 sv_insert(lsv, lvoff, lvlen, utf8, len);
2157 sv_insert(lsv, lvoff, lvlen, tmps, len);
2158 LvTARGLEN(sv) = len;
2165 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2169 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2170 PERL_UNUSED_ARG(sv);
2172 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2177 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2181 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2182 PERL_UNUSED_ARG(sv);
2184 /* update taint status */
2193 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2195 SV * const lsv = LvTARG(sv);
2197 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2198 PERL_UNUSED_ARG(mg);
2201 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2209 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2211 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2212 PERL_UNUSED_ARG(mg);
2213 do_vecset(sv); /* XXX slurp this routine */
2218 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2223 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2225 if (LvTARGLEN(sv)) {
2227 SV * const ahv = LvTARG(sv);
2228 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2233 AV *const av = MUTABLE_AV(LvTARG(sv));
2234 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2235 targ = AvARRAY(av)[LvTARGOFF(sv)];
2237 if (targ && (targ != &PL_sv_undef)) {
2238 /* somebody else defined it for us */
2239 SvREFCNT_dec(LvTARG(sv));
2240 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2242 SvREFCNT_dec(mg->mg_obj);
2244 mg->mg_flags &= ~MGf_REFCOUNTED;
2249 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2254 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2256 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2257 PERL_UNUSED_ARG(mg);
2261 sv_setsv(LvTARG(sv), sv);
2262 SvSETMAGIC(LvTARG(sv));
2268 Perl_vivify_defelem(pTHX_ SV *sv)
2274 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2276 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2279 SV * const ahv = LvTARG(sv);
2280 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2283 if (!value || value == &PL_sv_undef)
2284 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2287 AV *const av = MUTABLE_AV(LvTARG(sv));
2288 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2289 LvTARG(sv) = NULL; /* array can't be extended */
2291 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2292 if (!svp || (value = *svp) == &PL_sv_undef)
2293 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2296 SvREFCNT_inc_simple_void(value);
2297 SvREFCNT_dec(LvTARG(sv));
2300 SvREFCNT_dec(mg->mg_obj);
2302 mg->mg_flags &= ~MGf_REFCOUNTED;
2306 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2308 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2309 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2314 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2316 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2317 PERL_UNUSED_CONTEXT;
2319 if (!isGV_with_GP(sv))
2325 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2327 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2329 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2331 if (uf && uf->uf_set)
2332 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2337 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2339 const char type = mg->mg_type;
2341 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2343 if (type == PERL_MAGIC_qr) {
2344 } else if (type == PERL_MAGIC_bm) {
2348 assert(type == PERL_MAGIC_fm);
2351 return sv_unmagic(sv, type);
2354 #ifdef USE_LOCALE_COLLATE
2356 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2358 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2361 * RenE<eacute> Descartes said "I think not."
2362 * and vanished with a faint plop.
2364 PERL_UNUSED_CONTEXT;
2365 PERL_UNUSED_ARG(sv);
2367 Safefree(mg->mg_ptr);
2373 #endif /* USE_LOCALE_COLLATE */
2375 /* Just clear the UTF-8 cache data. */
2377 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2379 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2380 PERL_UNUSED_CONTEXT;
2381 PERL_UNUSED_ARG(sv);
2382 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2384 mg->mg_len = -1; /* The mg_len holds the len cache. */
2389 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2392 register const char *s;
2394 register const REGEXP * rx;
2395 const char * const remaining = mg->mg_ptr + 1;
2399 PERL_ARGS_ASSERT_MAGIC_SET;
2401 switch (*mg->mg_ptr) {
2402 case '\015': /* $^MATCH */
2403 if (strEQ(remaining, "ATCH"))
2405 case '`': /* ${^PREMATCH} caught below */
2407 paren = RX_BUFF_IDX_PREMATCH;
2409 case '\'': /* ${^POSTMATCH} caught below */
2411 paren = RX_BUFF_IDX_POSTMATCH;
2415 paren = RX_BUFF_IDX_FULLMATCH;
2417 case '1': case '2': case '3': case '4':
2418 case '5': case '6': case '7': case '8': case '9':
2419 paren = atoi(mg->mg_ptr);
2421 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2422 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2424 /* Croak with a READONLY error when a numbered match var is
2425 * set without a previous pattern match. Unless it's C<local $1>
2427 if (!PL_localizing) {
2428 Perl_croak_no_modify(aTHX);
2432 case '\001': /* ^A */
2433 sv_setsv(PL_bodytarget, sv);
2435 case '\003': /* ^C */
2436 PL_minus_c = cBOOL(SvIV(sv));
2439 case '\004': /* ^D */
2441 s = SvPV_nolen_const(sv);
2442 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2443 if (DEBUG_x_TEST || DEBUG_B_TEST)
2444 dump_all_perl(!DEBUG_B_TEST);
2446 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2449 case '\005': /* ^E */
2450 if (*(mg->mg_ptr+1) == '\0') {
2452 set_vaxc_errno(SvIV(sv));
2455 SetLastError( SvIV(sv) );
2458 os2_setsyserrno(SvIV(sv));
2460 /* will anyone ever use this? */
2461 SETERRNO(SvIV(sv), 4);
2466 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2467 SvREFCNT_dec(PL_encoding);
2468 if (SvOK(sv) || SvGMAGICAL(sv)) {
2469 PL_encoding = newSVsv(sv);
2476 case '\006': /* ^F */
2477 PL_maxsysfd = SvIV(sv);
2479 case '\010': /* ^H */
2480 PL_hints = SvIV(sv);
2482 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2483 Safefree(PL_inplace);
2484 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2486 case '\017': /* ^O */
2487 if (*(mg->mg_ptr+1) == '\0') {
2488 Safefree(PL_osname);
2491 TAINT_PROPER("assigning to $^O");
2492 PL_osname = savesvpv(sv);
2495 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2497 const char *const start = SvPV(sv, len);
2498 const char *out = (const char*)memchr(start, '\0', len);
2502 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2503 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2505 /* Opening for input is more common than opening for output, so
2506 ensure that hints for input are sooner on linked list. */
2507 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2509 : newSVpvs_flags("", SvUTF8(sv));
2510 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2513 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2515 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2519 case '\020': /* ^P */
2520 if (*remaining == '\0') { /* ^P */
2521 PL_perldb = SvIV(sv);
2522 if (PL_perldb && !PL_DBsingle)
2525 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2527 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2531 case '\024': /* ^T */
2533 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2535 PL_basetime = (Time_t)SvIV(sv);
2538 case '\025': /* ^UTF8CACHE */
2539 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2540 PL_utf8cache = (signed char) sv_2iv(sv);
2543 case '\027': /* ^W & $^WARNING_BITS */
2544 if (*(mg->mg_ptr+1) == '\0') {
2545 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2547 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2548 | (i ? G_WARN_ON : G_WARN_OFF) ;
2551 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2552 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2553 if (!SvPOK(sv) && PL_localizing) {
2554 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2555 PL_compiling.cop_warnings = pWARN_NONE;
2560 int accumulate = 0 ;
2561 int any_fatals = 0 ;
2562 const char * const ptr = SvPV_const(sv, len) ;
2563 for (i = 0 ; i < len ; ++i) {
2564 accumulate |= ptr[i] ;
2565 any_fatals |= (ptr[i] & 0xAA) ;
2568 if (!specialWARN(PL_compiling.cop_warnings))
2569 PerlMemShared_free(PL_compiling.cop_warnings);
2570 PL_compiling.cop_warnings = pWARN_NONE;
2572 /* Yuck. I can't see how to abstract this: */
2573 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2574 WARN_ALL) && !any_fatals) {
2575 if (!specialWARN(PL_compiling.cop_warnings))
2576 PerlMemShared_free(PL_compiling.cop_warnings);
2577 PL_compiling.cop_warnings = pWARN_ALL;
2578 PL_dowarn |= G_WARN_ONCE ;
2582 const char *const p = SvPV_const(sv, len);
2584 PL_compiling.cop_warnings
2585 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2588 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2589 PL_dowarn |= G_WARN_ONCE ;
2597 if (PL_localizing) {
2598 if (PL_localizing == 1)
2599 SAVESPTR(PL_last_in_gv);
2601 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2602 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2605 if (isGV_with_GP(PL_defoutgv)) {
2606 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2607 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2608 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2612 if (isGV_with_GP(PL_defoutgv)) {
2613 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2614 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2615 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2619 if (isGV_with_GP(PL_defoutgv))
2620 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2623 if (isGV_with_GP(PL_defoutgv)) {
2624 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2625 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2626 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2630 if (isGV_with_GP(PL_defoutgv))
2631 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2635 IO * const io = GvIO(PL_defoutgv);
2638 if ((SvIV(sv)) == 0)
2639 IoFLAGS(io) &= ~IOf_FLUSH;
2641 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2642 PerlIO *ofp = IoOFP(io);
2644 (void)PerlIO_flush(ofp);
2645 IoFLAGS(io) |= IOf_FLUSH;
2651 SvREFCNT_dec(PL_rs);
2652 PL_rs = newSVsv(sv);
2655 SvREFCNT_dec(PL_ors_sv);
2656 if (SvOK(sv) || SvGMAGICAL(sv)) {
2657 PL_ors_sv = newSVsv(sv);
2664 CopARYBASE_set(&PL_compiling, SvIV(sv));
2667 #ifdef COMPLEX_STATUS
2668 if (PL_localizing == 2) {
2669 SvUPGRADE(sv, SVt_PVLV);
2670 PL_statusvalue = LvTARGOFF(sv);
2671 PL_statusvalue_vms = LvTARGLEN(sv);
2675 #ifdef VMSISH_STATUS
2677 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2680 STATUS_UNIX_EXIT_SET(SvIV(sv));
2685 # define PERL_VMS_BANG vaxc$errno
2687 # define PERL_VMS_BANG 0
2689 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2690 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2695 if (PL_delaymagic) {
2696 PL_delaymagic |= DM_RUID;
2697 break; /* don't do magic till later */
2700 (void)setruid((Uid_t)PL_uid);
2703 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2705 #ifdef HAS_SETRESUID
2706 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2708 if (PL_uid == PL_euid) { /* special case $< = $> */
2710 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2711 if (PL_uid != 0 && PerlProc_getuid() == 0)
2712 (void)PerlProc_setuid(0);
2714 (void)PerlProc_setuid(PL_uid);
2716 PL_uid = PerlProc_getuid();
2717 Perl_croak(aTHX_ "setruid() not implemented");
2722 PL_uid = PerlProc_getuid();
2726 if (PL_delaymagic) {
2727 PL_delaymagic |= DM_EUID;
2728 break; /* don't do magic till later */
2731 (void)seteuid((Uid_t)PL_euid);
2734 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2736 #ifdef HAS_SETRESUID
2737 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2739 if (PL_euid == PL_uid) /* special case $> = $< */
2740 PerlProc_setuid(PL_euid);
2742 PL_euid = PerlProc_geteuid();
2743 Perl_croak(aTHX_ "seteuid() not implemented");
2748 PL_euid = PerlProc_geteuid();
2752 if (PL_delaymagic) {
2753 PL_delaymagic |= DM_RGID;
2754 break; /* don't do magic till later */
2757 (void)setrgid((Gid_t)PL_gid);
2760 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2762 #ifdef HAS_SETRESGID
2763 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2765 if (PL_gid == PL_egid) /* special case $( = $) */
2766 (void)PerlProc_setgid(PL_gid);
2768 PL_gid = PerlProc_getgid();
2769 Perl_croak(aTHX_ "setrgid() not implemented");
2774 PL_gid = PerlProc_getgid();
2777 #ifdef HAS_SETGROUPS
2779 const char *p = SvPV_const(sv, len);
2780 Groups_t *gary = NULL;
2781 #ifdef _SC_NGROUPS_MAX
2782 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2787 int maxgrp = NGROUPS;
2793 for (i = 0; i < maxgrp; ++i) {
2794 while (*p && !isSPACE(*p))
2801 Newx(gary, i + 1, Groups_t);
2803 Renew(gary, i + 1, Groups_t);
2807 (void)setgroups(i, gary);
2810 #else /* HAS_SETGROUPS */
2812 #endif /* HAS_SETGROUPS */
2813 if (PL_delaymagic) {
2814 PL_delaymagic |= DM_EGID;
2815 break; /* don't do magic till later */
2818 (void)setegid((Gid_t)PL_egid);
2821 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2823 #ifdef HAS_SETRESGID
2824 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2826 if (PL_egid == PL_gid) /* special case $) = $( */
2827 (void)PerlProc_setgid(PL_egid);
2829 PL_egid = PerlProc_getegid();
2830 Perl_croak(aTHX_ "setegid() not implemented");
2835 PL_egid = PerlProc_getegid();
2838 PL_chopset = SvPV_force(sv,len);
2841 LOCK_DOLLARZERO_MUTEX;
2842 #ifdef HAS_SETPROCTITLE
2843 /* The BSDs don't show the argv[] in ps(1) output, they
2844 * show a string from the process struct and provide
2845 * the setproctitle() routine to manipulate that. */
2846 if (PL_origalen != 1) {
2847 s = SvPV_const(sv, len);
2848 # if __FreeBSD_version > 410001
2849 /* The leading "-" removes the "perl: " prefix,
2850 * but not the "(perl) suffix from the ps(1)
2851 * output, because that's what ps(1) shows if the
2852 * argv[] is modified. */
2853 setproctitle("-%s", s);
2854 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2855 /* This doesn't really work if you assume that
2856 * $0 = 'foobar'; will wipe out 'perl' from the $0
2857 * because in ps(1) output the result will be like
2858 * sprintf("perl: %s (perl)", s)
2859 * I guess this is a security feature:
2860 * one (a user process) cannot get rid of the original name.
2862 setproctitle("%s", s);
2865 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2866 if (PL_origalen != 1) {
2868 s = SvPV_const(sv, len);
2869 un.pst_command = (char *)s;
2870 pstat(PSTAT_SETCMD, un, len, 0, 0);
2873 if (PL_origalen > 1) {
2874 /* PL_origalen is set in perl_parse(). */
2875 s = SvPV_force(sv,len);
2876 if (len >= (STRLEN)PL_origalen-1) {
2877 /* Longer than original, will be truncated. We assume that
2878 * PL_origalen bytes are available. */
2879 Copy(s, PL_origargv[0], PL_origalen-1, char);
2882 /* Shorter than original, will be padded. */
2884 /* Special case for Mac OS X: see [perl #38868] */
2887 /* Is the space counterintuitive? Yes.
2888 * (You were expecting \0?)
2889 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2891 const int pad = ' ';
2893 Copy(s, PL_origargv[0], len, char);
2894 PL_origargv[0][len] = 0;
2895 memset(PL_origargv[0] + len + 1,
2896 pad, PL_origalen - len - 1);
2898 PL_origargv[0][PL_origalen-1] = 0;
2899 for (i = 1; i < PL_origargc; i++)
2901 #ifdef HAS_PRCTL_SET_NAME
2902 /* Set the legacy process name in addition to the POSIX name on Linux */
2903 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2904 /* diag_listed_as: SKIPME */
2905 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2910 UNLOCK_DOLLARZERO_MUTEX;
2917 Perl_whichsig(pTHX_ const char *sig)
2919 register char* const* sigv;
2921 PERL_ARGS_ASSERT_WHICHSIG;
2922 PERL_UNUSED_CONTEXT;
2924 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2925 if (strEQ(sig,*sigv))
2926 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2928 if (strEQ(sig,"CHLD"))
2932 if (strEQ(sig,"CLD"))
2939 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2940 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2942 Perl_sighandler(int sig)
2945 #ifdef PERL_GET_SIG_CONTEXT
2946 dTHXa(PERL_GET_SIG_CONTEXT);
2953 SV * const tSv = PL_Sv;
2957 XPV * const tXpv = PL_Xpv;
2958 I32 old_ss_ix = PL_savestack_ix;
2961 if (!PL_psig_ptr[sig]) {
2962 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2967 /* Max number of items pushed there is 3*n or 4. We cannot fix
2968 infinity, so we fix 4 (in fact 5): */
2969 if (PL_savestack_ix + 15 <= PL_savestack_max) {
2971 PL_savestack_ix += 5; /* Protect save in progress. */
2972 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
2974 if (PL_markstack_ptr < PL_markstack_max - 2) {
2976 PL_markstack_ptr++; /* Protect mark. */
2978 if (PL_scopestack_ix < PL_scopestack_max - 3) {
2982 /* sv_2cv is too complicated, try a simpler variant first: */
2983 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2984 || SvTYPE(cv) != SVt_PVCV) {
2986 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2989 if (!cv || !CvROOT(cv)) {
2990 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2991 PL_sig_name[sig], (gv ? GvENAME(gv)
2998 sv = PL_psig_name[sig]
2999 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3000 : newSVpv(PL_sig_name[sig],0);
3004 /* make sure our assumption about the size of the SAVEs are correct:
3005 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3006 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3008 PUSHSTACKi(PERLSI_SIGNAL);
3011 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3013 struct sigaction oact;
3015 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3018 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3019 /* The siginfo fields signo, code, errno, pid, uid,
3020 * addr, status, and band are defined by POSIX/SUSv3. */
3021 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3022 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3023 #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. */
3024 hv_stores(sih, "errno", newSViv(sip->si_errno));
3025 hv_stores(sih, "status", newSViv(sip->si_status));
3026 hv_stores(sih, "uid", newSViv(sip->si_uid));
3027 hv_stores(sih, "pid", newSViv(sip->si_pid));
3028 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3029 hv_stores(sih, "band", newSViv(sip->si_band));
3033 mPUSHp((char *)sip, sizeof(*sip));
3041 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3044 if (SvTRUE(ERRSV)) {
3046 #ifdef HAS_SIGPROCMASK
3047 /* Handler "died", for example to get out of a restart-able read().
3048 * Before we re-do that on its behalf re-enable the signal which was
3049 * blocked by the system when we entered.
3053 sigaddset(&set,sig);
3054 sigprocmask(SIG_UNBLOCK, &set, NULL);
3056 /* Not clear if this will work */
3057 (void)rsignal(sig, SIG_IGN);
3058 (void)rsignal(sig, PL_csighandlerp);
3060 #endif /* !PERL_MICRO */
3064 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3065 PL_savestack_ix = old_ss_ix;
3069 PL_scopestack_ix -= 1;
3072 PL_op = myop; /* Apparently not needed... */
3074 PL_Sv = tSv; /* Restore global temporaries. */
3081 S_restore_magic(pTHX_ const void *p)
3084 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3085 SV* const sv = mgs->mgs_sv;
3090 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3092 #ifdef PERL_OLD_COPY_ON_WRITE
3093 /* While magic was saved (and off) sv_setsv may well have seen
3094 this SV as a prime candidate for COW. */
3096 sv_force_normal_flags(sv, 0);
3099 if (mgs->mgs_readonly)
3101 if (mgs->mgs_magical)
3102 SvFLAGS(sv) |= mgs->mgs_magical;
3105 if (SvGMAGICAL(sv)) {
3106 /* downgrade public flags to private,
3107 and discard any other private flags */
3109 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3111 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3112 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3117 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3119 /* If we're still on top of the stack, pop us off. (That condition
3120 * will be satisfied if restore_magic was called explicitly, but *not*
3121 * if it's being called via leave_scope.)
3122 * The reason for doing this is that otherwise, things like sv_2cv()
3123 * may leave alloc gunk on the savestack, and some code
3124 * (e.g. sighandler) doesn't expect that...
3126 if (PL_savestack_ix == mgs->mgs_ss_ix)
3128 UV popval = SSPOPUV;
3129 assert(popval == SAVEt_DESTRUCTOR_X);
3130 PL_savestack_ix -= 2;
3132 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3133 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3138 /* clean up the mess created by Perl_sighandler().
3139 * Note that this is only called during an exit in a signal handler;
3140 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3141 * skipped over. This is why we don't need to fix up the markstack and
3142 * scopestack - they're going to be set to 0 anyway */
3145 S_unwind_handler_stack(pTHX_ const void *p)
3150 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3154 =for apidoc magic_sethint
3156 Triggered by a store to %^H, records the key/value pair to
3157 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3158 anything that would need a deep copy. Maybe we should warn if we find a
3164 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3167 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3168 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3170 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3172 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3173 an alternative leaf in there, with PL_compiling.cop_hints being used if
3174 it's NULL. If needed for threads, the alternative could lock a mutex,
3175 or take other more complex action. */
3177 /* Something changed in %^H, so it will need to be restored on scope exit.
3178 Doing this here saves a lot of doing it manually in perl code (and
3179 forgetting to do it, and consequent subtle errors. */
3180 PL_hints |= HINT_LOCALIZE_HH;
3181 CopHINTHASH_set(&PL_compiling,
3182 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3187 =for apidoc magic_clearhint
3189 Triggered by a delete from %^H, records the key to
3190 C<PL_compiling.cop_hints_hash>.
3195 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3199 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3200 PERL_UNUSED_ARG(sv);
3202 assert(mg->mg_len == HEf_SVKEY);
3204 PERL_UNUSED_ARG(sv);
3206 PL_hints |= HINT_LOCALIZE_HH;
3207 CopHINTHASH_set(&PL_compiling,
3208 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3209 MUTABLE_SV(mg->mg_ptr), 0, 0));
3214 =for apidoc magic_clearhints
3216 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3221 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3223 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3224 PERL_UNUSED_ARG(sv);
3225 PERL_UNUSED_ARG(mg);
3226 cophh_free(CopHINTHASH_get(&PL_compiling));
3227 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3233 * c-indentation-style: bsd
3235 * indent-tabs-mode: t
3238 * ex: set ts=8 sts=4 sw=4 noet: