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 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
61 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
63 Signal_t Perl_csighandler(int sig);
67 /* Missing protos on LynxOS */
68 void setruid(uid_t id);
69 void seteuid(uid_t id);
70 void setrgid(uid_t id);
71 void setegid(uid_t id);
75 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
83 /* MGS is typedef'ed to struct magic_state in perl.h */
86 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
91 PERL_ARGS_ASSERT_SAVE_MAGIC;
93 assert(SvMAGICAL(sv));
94 /* Turning READONLY off for a copy-on-write scalar (including shared
95 hash keys) is a bad idea. */
97 sv_force_normal_flags(sv, 0);
99 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
101 mgs = SSPTR(mgs_ix, MGS*);
103 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
104 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
108 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
109 /* No public flags are set, so promote any private flags to public. */
110 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
115 =for apidoc mg_magical
117 Turns on the magical status of an SV. See C<sv_magic>.
123 Perl_mg_magical(pTHX_ SV *sv)
126 PERL_ARGS_ASSERT_MG_MAGICAL;
128 if ((mg = SvMAGIC(sv))) {
131 const MGVTBL* const vtbl = mg->mg_virtual;
133 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
140 } while ((mg = mg->mg_moremagic));
141 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
147 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
150 S_is_container_magic(const MAGIC *mg)
153 switch (mg->mg_type) {
156 case PERL_MAGIC_regex_global:
157 case PERL_MAGIC_nkeys:
158 #ifdef USE_LOCALE_COLLATE
159 case PERL_MAGIC_collxfrm:
162 case PERL_MAGIC_taint:
164 case PERL_MAGIC_vstring:
165 case PERL_MAGIC_utf8:
166 case PERL_MAGIC_substr:
167 case PERL_MAGIC_defelem:
168 case PERL_MAGIC_arylen:
170 case PERL_MAGIC_backref:
171 case PERL_MAGIC_arylen_p:
172 case PERL_MAGIC_rhash:
173 case PERL_MAGIC_symtab:
183 Do magic after a value is retrieved from the SV. See C<sv_magic>.
189 Perl_mg_get(pTHX_ SV *sv)
192 const I32 mgs_ix = SSNEW(sizeof(MGS));
193 const bool was_temp = (bool)SvTEMP(sv);
195 MAGIC *newmg, *head, *cur, *mg;
196 /* guard against sv having being freed midway by holding a private
199 PERL_ARGS_ASSERT_MG_GET;
201 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
202 cause the SV's buffer to get stolen (and maybe other stuff).
205 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
210 save_magic(mgs_ix, sv);
212 /* We must call svt_get(sv, mg) for each valid entry in the linked
213 list of magic. svt_get() may delete the current entry, add new
214 magic to the head of the list, or upgrade the SV. AMS 20010810 */
216 newmg = cur = head = mg = SvMAGIC(sv);
218 const MGVTBL * const vtbl = mg->mg_virtual;
220 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
221 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
223 /* guard against magic having been deleted - eg FETCH calling
228 /* Don't restore the flags for this entry if it was deleted. */
229 if (mg->mg_flags & MGf_GSKIP)
230 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
233 mg = mg->mg_moremagic;
236 /* Have we finished with the new entries we saw? Start again
237 where we left off (unless there are more new entries). */
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
253 restore_magic(INT2PTR(void *, (IV)mgs_ix));
255 if (SvREFCNT(sv) == 1) {
256 /* We hold the last reference to this SV, which implies that the
257 SV was deleted as a side effect of the routines we called. */
266 Do magic after a value is assigned to the SV. See C<sv_magic>.
272 Perl_mg_set(pTHX_ SV *sv)
275 const I32 mgs_ix = SSNEW(sizeof(MGS));
279 PERL_ARGS_ASSERT_MG_SET;
281 save_magic(mgs_ix, sv);
283 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
284 const MGVTBL* vtbl = mg->mg_virtual;
285 nextmg = mg->mg_moremagic; /* it may delete itself */
286 if (mg->mg_flags & MGf_GSKIP) {
287 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
288 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
290 if (PL_localizing == 2 && !S_is_container_magic(mg))
292 if (vtbl && vtbl->svt_set)
293 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
301 =for apidoc mg_length
303 Report on the SV's length. See C<sv_magic>.
309 Perl_mg_length(pTHX_ SV *sv)
315 PERL_ARGS_ASSERT_MG_LENGTH;
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 const MGVTBL * const vtbl = mg->mg_virtual;
319 if (vtbl && vtbl->svt_len) {
320 const I32 mgs_ix = SSNEW(sizeof(MGS));
321 save_magic(mgs_ix, sv);
322 /* omit MGf_GSKIP -- not changed here */
323 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
324 restore_magic(INT2PTR(void*, (IV)mgs_ix));
330 /* You can't know whether it's UTF-8 until you get the string again...
332 const U8 *s = (U8*)SvPV_const(sv, len);
335 len = utf8_length(s, s + len);
342 Perl_mg_size(pTHX_ SV *sv)
346 PERL_ARGS_ASSERT_MG_SIZE;
348 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
349 const MGVTBL* const vtbl = mg->mg_virtual;
350 if (vtbl && vtbl->svt_len) {
351 const I32 mgs_ix = SSNEW(sizeof(MGS));
353 save_magic(mgs_ix, sv);
354 /* omit MGf_GSKIP -- not changed here */
355 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
356 restore_magic(INT2PTR(void*, (IV)mgs_ix));
363 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
367 Perl_croak(aTHX_ "Size magic not implemented");
376 Clear something magical that the SV represents. See C<sv_magic>.
382 Perl_mg_clear(pTHX_ SV *sv)
384 const I32 mgs_ix = SSNEW(sizeof(MGS));
387 PERL_ARGS_ASSERT_MG_CLEAR;
389 save_magic(mgs_ix, sv);
391 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
392 const MGVTBL* const vtbl = mg->mg_virtual;
393 /* omit GSKIP -- never set here */
395 if (vtbl && vtbl->svt_clear)
396 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
399 restore_magic(INT2PTR(void*, (IV)mgs_ix));
406 Finds the magic pointer for type matching the SV. See C<sv_magic>.
412 Perl_mg_find(pTHX_ const SV *sv, int type)
417 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
418 if (mg->mg_type == type)
428 Copies the magic from one SV to another. See C<sv_magic>.
434 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
439 PERL_ARGS_ASSERT_MG_COPY;
441 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
442 const MGVTBL* const vtbl = mg->mg_virtual;
443 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
444 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
447 const char type = mg->mg_type;
448 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
450 (type == PERL_MAGIC_tied)
452 : (type == PERL_MAGIC_regdata && mg->mg_obj)
455 toLOWER(type), key, klen);
464 =for apidoc mg_localize
466 Copy some of the magic from an existing SV to new localized version of
467 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
468 doesn't (eg taint, pos).
474 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
479 PERL_ARGS_ASSERT_MG_LOCALIZE;
481 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
482 const MGVTBL* const vtbl = mg->mg_virtual;
483 if (!S_is_container_magic(mg))
486 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
487 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
489 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
490 mg->mg_ptr, mg->mg_len);
492 /* container types should remain read-only across localization */
493 SvFLAGS(nsv) |= SvREADONLY(sv);
496 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
497 SvFLAGS(nsv) |= SvMAGICAL(sv);
507 Free any magic storage used by the SV. See C<sv_magic>.
513 Perl_mg_free(pTHX_ SV *sv)
518 PERL_ARGS_ASSERT_MG_FREE;
520 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
521 const MGVTBL* const vtbl = mg->mg_virtual;
522 moremagic = mg->mg_moremagic;
523 if (vtbl && vtbl->svt_free)
524 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
525 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
526 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
527 Safefree(mg->mg_ptr);
528 else if (mg->mg_len == HEf_SVKEY)
529 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
531 if (mg->mg_flags & MGf_REFCOUNTED)
532 SvREFCNT_dec(mg->mg_obj);
534 SvMAGIC_set(sv, moremagic);
536 SvMAGIC_set(sv, NULL);
544 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
549 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
552 register const REGEXP * const rx = PM_GETRE(PL_curpm);
554 if (mg->mg_obj) { /* @+ */
555 /* return the number possible */
556 return RX_NPARENS(rx);
558 I32 paren = RX_LASTPAREN(rx);
560 /* return the last filled */
562 && (RX_OFFS(rx)[paren].start == -1
563 || RX_OFFS(rx)[paren].end == -1) )
574 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
578 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
581 register const REGEXP * const rx = PM_GETRE(PL_curpm);
583 register const I32 paren = mg->mg_len;
588 if (paren <= (I32)RX_NPARENS(rx) &&
589 (s = RX_OFFS(rx)[paren].start) != -1 &&
590 (t = RX_OFFS(rx)[paren].end) != -1)
593 if (mg->mg_obj) /* @+ */
598 if (i > 0 && RX_MATCH_UTF8(rx)) {
599 const char * const b = RX_SUBBEG(rx);
601 i = utf8_length((U8*)b, (U8*)(b+i));
612 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
614 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
617 Perl_croak(aTHX_ "%s", PL_no_modify);
618 NORETURN_FUNCTION_END;
622 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
627 register const REGEXP * rx;
628 const char * const remaining = mg->mg_ptr + 1;
630 PERL_ARGS_ASSERT_MAGIC_LEN;
632 switch (*mg->mg_ptr) {
634 if (*remaining == '\0') { /* ^P */
636 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
638 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
642 case '\015': /* $^MATCH */
643 if (strEQ(remaining, "ATCH")) {
650 paren = RX_BUFF_IDX_PREMATCH;
654 paren = RX_BUFF_IDX_POSTMATCH;
658 paren = RX_BUFF_IDX_FULLMATCH;
660 case '1': case '2': case '3': case '4':
661 case '5': case '6': case '7': case '8': case '9':
662 paren = atoi(mg->mg_ptr);
664 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
666 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
669 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
672 if (ckWARN(WARN_UNINITIALIZED))
677 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
678 paren = RX_LASTPAREN(rx);
683 case '\016': /* ^N */
684 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
685 paren = RX_LASTCLOSEPAREN(rx);
692 if (!SvPOK(sv) && SvNIOK(sv)) {
700 #define SvRTRIM(sv) STMT_START { \
702 STRLEN len = SvCUR(sv); \
703 char * const p = SvPVX(sv); \
704 while (len > 0 && isSPACE(p[len-1])) \
706 SvCUR_set(sv, len); \
712 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
714 PERL_ARGS_ASSERT_EMULATE_COP_IO;
716 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
717 sv_setsv(sv, &PL_sv_undef);
721 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
722 SV *const value = Perl_refcounted_he_fetch(aTHX_
724 0, "open<", 5, 0, 0);
729 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
730 SV *const value = Perl_refcounted_he_fetch(aTHX_
732 0, "open>", 5, 0, 0);
740 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
744 register char *s = NULL;
746 const char * const remaining = mg->mg_ptr + 1;
747 const char nextchar = *remaining;
749 PERL_ARGS_ASSERT_MAGIC_GET;
751 switch (*mg->mg_ptr) {
752 case '\001': /* ^A */
753 sv_setsv(sv, PL_bodytarget);
755 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
756 if (nextchar == '\0') {
757 sv_setiv(sv, (IV)PL_minus_c);
759 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
760 sv_setiv(sv, (IV)STATUS_NATIVE);
764 case '\004': /* ^D */
765 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
767 case '\005': /* ^E */
768 if (nextchar == '\0') {
769 #if defined(MACOS_TRADITIONAL)
773 sv_setnv(sv,(double)gMacPerl_OSErr);
774 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
778 # include <descrip.h>
779 # include <starlet.h>
781 $DESCRIPTOR(msgdsc,msg);
782 sv_setnv(sv,(NV) vaxc$errno);
783 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
784 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
789 if (!(_emx_env & 0x200)) { /* Under DOS */
790 sv_setnv(sv, (NV)errno);
791 sv_setpv(sv, errno ? Strerror(errno) : "");
793 if (errno != errno_isOS2) {
794 const int tmp = _syserrno();
795 if (tmp) /* 2nd call to _syserrno() makes it 0 */
798 sv_setnv(sv, (NV)Perl_rc);
799 sv_setpv(sv, os2error(Perl_rc));
803 const DWORD dwErr = GetLastError();
804 sv_setnv(sv, (NV)dwErr);
806 PerlProc_GetOSError(sv, dwErr);
814 const int saveerrno = errno;
815 sv_setnv(sv, (NV)errno);
816 sv_setpv(sv, errno ? Strerror(errno) : "");
821 SvNOK_on(sv); /* what a wonderful hack! */
823 else if (strEQ(remaining, "NCODING"))
824 sv_setsv(sv, PL_encoding);
826 case '\006': /* ^F */
827 sv_setiv(sv, (IV)PL_maxsysfd);
829 case '\010': /* ^H */
830 sv_setiv(sv, (IV)PL_hints);
832 case '\011': /* ^I */ /* NOT \t in EBCDIC */
833 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
835 case '\017': /* ^O & ^OPEN */
836 if (nextchar == '\0') {
837 sv_setpv(sv, PL_osname);
840 else if (strEQ(remaining, "PEN")) {
841 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
845 if (nextchar == '\0') { /* ^P */
846 sv_setiv(sv, (IV)PL_perldb);
847 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
848 goto do_prematch_fetch;
849 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
850 goto do_postmatch_fetch;
853 case '\023': /* ^S */
854 if (nextchar == '\0') {
855 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
858 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
863 case '\024': /* ^T */
864 if (nextchar == '\0') {
866 sv_setnv(sv, PL_basetime);
868 sv_setiv(sv, (IV)PL_basetime);
871 else if (strEQ(remaining, "AINT"))
872 sv_setiv(sv, PL_tainting
873 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
876 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
877 if (strEQ(remaining, "NICODE"))
878 sv_setuv(sv, (UV) PL_unicode);
879 else if (strEQ(remaining, "TF8LOCALE"))
880 sv_setuv(sv, (UV) PL_utf8locale);
881 else if (strEQ(remaining, "TF8CACHE"))
882 sv_setiv(sv, (IV) PL_utf8cache);
884 case '\027': /* ^W & $^WARNING_BITS */
885 if (nextchar == '\0')
886 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
887 else if (strEQ(remaining, "ARNING_BITS")) {
888 if (PL_compiling.cop_warnings == pWARN_NONE) {
889 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
891 else if (PL_compiling.cop_warnings == pWARN_STD) {
894 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
898 else if (PL_compiling.cop_warnings == pWARN_ALL) {
899 /* Get the bit mask for $warnings::Bits{all}, because
900 * it could have been extended by warnings::register */
901 HV * const bits=get_hv("warnings::Bits", FALSE);
903 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
905 sv_setsv(sv, *bits_all);
908 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
912 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
913 *PL_compiling.cop_warnings);
918 case '\015': /* $^MATCH */
919 if (strEQ(remaining, "ATCH")) {
920 case '1': case '2': case '3': case '4':
921 case '5': case '6': case '7': case '8': case '9': case '&':
922 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
924 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
925 * XXX Does the new way break anything?
927 paren = atoi(mg->mg_ptr); /* $& is in [0] */
928 CALLREG_NUMBUF_FETCH(rx,paren,sv);
931 sv_setsv(sv,&PL_sv_undef);
935 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
936 if (RX_LASTPAREN(rx)) {
937 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
941 sv_setsv(sv,&PL_sv_undef);
943 case '\016': /* ^N */
944 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
945 if (RX_LASTCLOSEPAREN(rx)) {
946 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
951 sv_setsv(sv,&PL_sv_undef);
955 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
956 CALLREG_NUMBUF_FETCH(rx,-2,sv);
959 sv_setsv(sv,&PL_sv_undef);
963 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
964 CALLREG_NUMBUF_FETCH(rx,-1,sv);
967 sv_setsv(sv,&PL_sv_undef);
970 if (GvIO(PL_last_in_gv)) {
971 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
976 sv_setiv(sv, (IV)STATUS_CURRENT);
977 #ifdef COMPLEX_STATUS
978 LvTARGOFF(sv) = PL_statusvalue;
979 LvTARGLEN(sv) = PL_statusvalue_vms;
984 if (GvIOp(PL_defoutgv))
985 s = IoTOP_NAME(GvIOp(PL_defoutgv));
989 sv_setpv(sv,GvENAME(PL_defoutgv));
990 sv_catpvs(sv,"_TOP");
994 if (GvIOp(PL_defoutgv))
995 s = IoFMT_NAME(GvIOp(PL_defoutgv));
997 s = GvENAME(PL_defoutgv);
1001 if (GvIOp(PL_defoutgv))
1002 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1005 if (GvIOp(PL_defoutgv))
1006 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1009 if (GvIOp(PL_defoutgv))
1010 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1017 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1020 if (GvIOp(PL_defoutgv))
1021 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1027 sv_copypv(sv, PL_ors_sv);
1031 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1032 sv_setpv(sv, errno ? Strerror(errno) : "");
1035 const int saveerrno = errno;
1036 sv_setnv(sv, (NV)errno);
1038 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1039 sv_setpv(sv, os2error(Perl_rc));
1042 sv_setpv(sv, errno ? Strerror(errno) : "");
1047 SvNOK_on(sv); /* what a wonderful hack! */
1050 sv_setiv(sv, (IV)PL_uid);
1053 sv_setiv(sv, (IV)PL_euid);
1056 sv_setiv(sv, (IV)PL_gid);
1059 sv_setiv(sv, (IV)PL_egid);
1061 #ifdef HAS_GETGROUPS
1063 Groups_t *gary = NULL;
1064 I32 i, num_groups = getgroups(0, gary);
1065 Newx(gary, num_groups, Groups_t);
1066 num_groups = getgroups(num_groups, gary);
1067 for (i = 0; i < num_groups; i++)
1068 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1071 (void)SvIOK_on(sv); /* what a wonderful hack! */
1074 #ifndef MACOS_TRADITIONAL
1083 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1085 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1087 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1089 if (uf && uf->uf_val)
1090 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1095 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1098 STRLEN len = 0, klen;
1099 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1100 const char * const ptr = MgPV_const(mg,klen);
1103 PERL_ARGS_ASSERT_MAGIC_SETENV;
1105 #ifdef DYNAMIC_ENV_FETCH
1106 /* We just undefd an environment var. Is a replacement */
1107 /* waiting in the wings? */
1109 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1111 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1115 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1116 /* And you'll never guess what the dog had */
1117 /* in its mouth... */
1119 MgTAINTEDDIR_off(mg);
1121 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1122 char pathbuf[256], eltbuf[256], *cp, *elt;
1126 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1128 do { /* DCL$PATH may be a search list */
1129 while (1) { /* as may dev portion of any element */
1130 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1131 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1132 cando_by_name(S_IWUSR,0,elt) ) {
1133 MgTAINTEDDIR_on(mg);
1137 if ((cp = strchr(elt, ':')) != NULL)
1139 if (my_trnlnm(elt, eltbuf, j++))
1145 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1148 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1149 const char * const strend = s + len;
1151 while (s < strend) {
1155 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1156 const char path_sep = '|';
1158 const char path_sep = ':';
1160 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1161 s, strend, path_sep, &i);
1163 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1165 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1167 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1169 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1170 MgTAINTEDDIR_on(mg);
1176 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1182 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1184 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1185 PERL_UNUSED_ARG(sv);
1186 my_setenv(MgPV_nolen_const(mg),NULL);
1191 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1194 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1195 PERL_UNUSED_ARG(mg);
1197 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1199 if (PL_localizing) {
1202 hv_iterinit(MUTABLE_HV(sv));
1203 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1205 my_setenv(hv_iterkey(entry, &keylen),
1206 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1214 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1217 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1218 PERL_UNUSED_ARG(sv);
1219 PERL_UNUSED_ARG(mg);
1221 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1229 #ifdef HAS_SIGPROCMASK
1231 restore_sigmask(pTHX_ SV *save_sv)
1233 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1234 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1238 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1241 /* Are we fetching a signal entry? */
1242 const I32 i = whichsig(MgPV_nolen_const(mg));
1244 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1248 sv_setsv(sv,PL_psig_ptr[i]);
1250 Sighandler_t sigstate = rsignal_state(i);
1251 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1252 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1255 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1256 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1259 /* cache state so we don't fetch it again */
1260 if(sigstate == (Sighandler_t) SIG_IGN)
1261 sv_setpvs(sv,"IGNORE");
1263 sv_setsv(sv,&PL_sv_undef);
1264 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1271 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1273 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1274 * refactoring might be in order.
1277 register const char * const s = MgPV_nolen_const(mg);
1278 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1279 PERL_UNUSED_ARG(sv);
1282 if (strEQ(s,"__DIE__"))
1284 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1287 SV *const to_dec = *svp;
1289 SvREFCNT_dec(to_dec);
1293 /* Are we clearing a signal entry? */
1294 const I32 i = whichsig(s);
1296 #ifdef HAS_SIGPROCMASK
1299 /* Avoid having the signal arrive at a bad time, if possible. */
1302 sigprocmask(SIG_BLOCK, &set, &save);
1304 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1305 SAVEFREESV(save_sv);
1306 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1309 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1310 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1312 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313 PL_sig_defaulting[i] = 1;
1314 (void)rsignal(i, PL_csighandlerp);
1316 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1318 if(PL_psig_name[i]) {
1319 SvREFCNT_dec(PL_psig_name[i]);
1322 if(PL_psig_ptr[i]) {
1323 SV * const to_dec=PL_psig_ptr[i];
1326 SvREFCNT_dec(to_dec);
1336 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1337 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1339 Perl_csighandler(int sig)
1342 #ifdef PERL_GET_SIG_CONTEXT
1343 dTHXa(PERL_GET_SIG_CONTEXT);
1347 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1348 (void) rsignal(sig, PL_csighandlerp);
1349 if (PL_sig_ignoring[sig]) return;
1351 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1352 if (PL_sig_defaulting[sig])
1353 #ifdef KILL_BY_SIGPRC
1354 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1369 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1370 /* Call the perl level handler now--
1371 * with risk we may be in malloc() etc. */
1372 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1373 (*PL_sighandlerp)(sig, NULL, NULL);
1375 (*PL_sighandlerp)(sig);
1378 /* Set a flag to say this signal is pending, that is awaiting delivery after
1379 * the current Perl opcode completes */
1380 PL_psig_pend[sig]++;
1382 #ifndef SIG_PENDING_DIE_COUNT
1383 # define SIG_PENDING_DIE_COUNT 120
1385 /* And one to say _a_ signal is pending */
1386 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1387 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1388 (unsigned long)SIG_PENDING_DIE_COUNT);
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1394 Perl_csighandler_init(void)
1397 if (PL_sig_handlers_initted) return;
1399 for (sig = 1; sig < SIG_SIZE; sig++) {
1400 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1402 PL_sig_defaulting[sig] = 1;
1403 (void) rsignal(sig, PL_csighandlerp);
1405 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1406 PL_sig_ignoring[sig] = 0;
1409 PL_sig_handlers_initted = 1;
1414 Perl_despatch_signals(pTHX)
1419 for (sig = 1; sig < SIG_SIZE; sig++) {
1420 if (PL_psig_pend[sig]) {
1421 PERL_BLOCKSIG_ADD(set, sig);
1422 PL_psig_pend[sig] = 0;
1423 PERL_BLOCKSIG_BLOCK(set);
1424 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1425 (*PL_sighandlerp)(sig, NULL, NULL);
1427 (*PL_sighandlerp)(sig);
1429 PERL_BLOCKSIG_UNBLOCK(set);
1435 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1440 /* Need to be careful with SvREFCNT_dec(), because that can have side
1441 * effects (due to closures). We must make sure that the new disposition
1442 * is in place before it is called.
1446 #ifdef HAS_SIGPROCMASK
1450 register const char *s = MgPV_const(mg,len);
1452 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1455 if (strEQ(s,"__DIE__"))
1457 else if (strEQ(s,"__WARN__"))
1460 Perl_croak(aTHX_ "No such hook: %s", s);
1463 if (*svp != PERL_WARNHOOK_FATAL)
1469 i = whichsig(s); /* ...no, a brick */
1471 if (ckWARN(WARN_SIGNAL))
1472 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1475 #ifdef HAS_SIGPROCMASK
1476 /* Avoid having the signal arrive at a bad time, if possible. */
1479 sigprocmask(SIG_BLOCK, &set, &save);
1481 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1482 SAVEFREESV(save_sv);
1483 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1486 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1487 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1489 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1490 PL_sig_ignoring[i] = 0;
1492 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1493 PL_sig_defaulting[i] = 0;
1495 SvREFCNT_dec(PL_psig_name[i]);
1496 to_dec = PL_psig_ptr[i];
1497 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1498 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1499 PL_psig_name[i] = newSVpvn(s, len);
1500 SvREADONLY_on(PL_psig_name[i]);
1502 if (isGV_with_GP(sv) || SvROK(sv)) {
1504 (void)rsignal(i, PL_csighandlerp);
1505 #ifdef HAS_SIGPROCMASK
1510 *svp = SvREFCNT_inc_simple_NN(sv);
1512 SvREFCNT_dec(to_dec);
1515 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1516 if (strEQ(s,"IGNORE")) {
1518 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1519 PL_sig_ignoring[i] = 1;
1520 (void)rsignal(i, PL_csighandlerp);
1522 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1526 else if (strEQ(s,"DEFAULT") || !*s) {
1528 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1530 PL_sig_defaulting[i] = 1;
1531 (void)rsignal(i, PL_csighandlerp);
1534 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1539 * We should warn if HINT_STRICT_REFS, but without
1540 * access to a known hint bit in a known OP, we can't
1541 * tell whether HINT_STRICT_REFS is in force or not.
1543 if (!strchr(s,':') && !strchr(s,'\''))
1544 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1547 (void)rsignal(i, PL_csighandlerp);
1549 *svp = SvREFCNT_inc_simple_NN(sv);
1551 #ifdef HAS_SIGPROCMASK
1556 SvREFCNT_dec(to_dec);
1559 #endif /* !PERL_MICRO */
1562 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1567 PERL_ARGS_ASSERT_MAGIC_SETISA;
1568 PERL_UNUSED_ARG(sv);
1570 /* Bail out if destruction is going on */
1571 if(PL_dirty) return 0;
1573 /* Skip _isaelem because _isa will handle it shortly */
1574 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1577 /* XXX Once it's possible, we need to
1578 detect that our @ISA is aliased in
1579 other stashes, and act on the stashes
1580 of all of the aliases */
1582 /* The first case occurs via setisa,
1583 the second via setisa_elem, which
1584 calls this same magic */
1586 SvTYPE(mg->mg_obj) == SVt_PVGV
1587 ? (const GV *)mg->mg_obj
1588 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1592 mro_isa_changed_in(stash);
1598 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1603 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1605 /* Bail out if destruction is going on */
1606 if(PL_dirty) return 0;
1608 av_clear(MUTABLE_AV(sv));
1610 /* XXX see comments in magic_setisa */
1612 SvTYPE(mg->mg_obj) == SVt_PVGV
1613 ? (const GV *)mg->mg_obj
1614 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1618 mro_isa_changed_in(stash);
1624 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1627 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1628 PERL_UNUSED_ARG(sv);
1629 PERL_UNUSED_ARG(mg);
1630 PL_amagic_generation++;
1636 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1638 HV * const hv = MUTABLE_HV(LvTARG(sv));
1641 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1642 PERL_UNUSED_ARG(mg);
1645 (void) hv_iterinit(hv);
1646 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1649 while (hv_iternext(hv))
1654 sv_setiv(sv, (IV)i);
1659 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1661 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1662 PERL_UNUSED_ARG(mg);
1664 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1669 /* caller is responsible for stack switching/cleanup */
1671 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1676 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1680 PUSHs(SvTIED_obj(sv, mg));
1683 if (mg->mg_len >= 0)
1684 mPUSHp(mg->mg_ptr, mg->mg_len);
1685 else if (mg->mg_len == HEf_SVKEY)
1686 PUSHs(MUTABLE_SV(mg->mg_ptr));
1688 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1697 return call_method(meth, flags);
1701 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1705 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1709 PUSHSTACKi(PERLSI_MAGIC);
1711 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1712 sv_setsv(sv, *PL_stack_sp--);
1722 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1724 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1727 mg->mg_flags |= MGf_GSKIP;
1728 magic_methpack(sv,mg,"FETCH");
1733 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1737 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1740 PUSHSTACKi(PERLSI_MAGIC);
1741 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1748 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1750 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1752 return magic_methpack(sv,mg,"DELETE");
1757 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1762 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1766 PUSHSTACKi(PERLSI_MAGIC);
1767 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1768 sv = *PL_stack_sp--;
1769 retval = SvIV(sv)-1;
1771 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1776 return (U32) retval;
1780 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1784 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1787 PUSHSTACKi(PERLSI_MAGIC);
1789 XPUSHs(SvTIED_obj(sv, mg));
1791 call_method("CLEAR", G_SCALAR|G_DISCARD);
1799 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1802 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1804 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1808 PUSHSTACKi(PERLSI_MAGIC);
1811 PUSHs(SvTIED_obj(sv, mg));
1816 if (call_method(meth, G_SCALAR))
1817 sv_setsv(key, *PL_stack_sp--);
1826 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1828 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1830 return magic_methpack(sv,mg,"EXISTS");
1834 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1838 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1839 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1841 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1843 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1845 if (HvEITER_get(hv))
1846 /* we are in an iteration so the hash cannot be empty */
1848 /* no xhv_eiter so now use FIRSTKEY */
1849 key = sv_newmortal();
1850 magic_nextpack(MUTABLE_SV(hv), mg, key);
1851 HvEITER_set(hv, NULL); /* need to reset iterator */
1852 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1855 /* there is a SCALAR method that we can call */
1857 PUSHSTACKi(PERLSI_MAGIC);
1863 if (call_method("SCALAR", G_SCALAR))
1864 retval = *PL_stack_sp--;
1866 retval = &PL_sv_undef;
1873 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1876 GV * const gv = PL_DBline;
1877 const I32 i = SvTRUE(sv);
1878 SV ** const svp = av_fetch(GvAV(gv),
1879 atoi(MgPV_nolen_const(mg)), FALSE);
1881 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1883 if (svp && SvIOKp(*svp)) {
1884 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1886 /* set or clear breakpoint in the relevant control op */
1888 o->op_flags |= OPf_SPECIAL;
1890 o->op_flags &= ~OPf_SPECIAL;
1897 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1900 AV * const obj = MUTABLE_AV(mg->mg_obj);
1902 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1905 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1913 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1916 AV * const obj = MUTABLE_AV(mg->mg_obj);
1918 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1921 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1923 if (ckWARN(WARN_MISC))
1924 Perl_warner(aTHX_ packWARN(WARN_MISC),
1925 "Attempt to set length of freed array");
1931 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1935 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1936 PERL_UNUSED_ARG(sv);
1938 /* during global destruction, mg_obj may already have been freed */
1939 if (PL_in_clean_all)
1942 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1945 /* arylen scalar holds a pointer back to the array, but doesn't own a
1946 reference. Hence the we (the array) are about to go away with it
1947 still pointing at us. Clear its pointer, else it would be pointing
1948 at free memory. See the comment in sv_magic about reference loops,
1949 and why it can't own a reference to us. */
1956 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1959 SV* const lsv = LvTARG(sv);
1961 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1962 PERL_UNUSED_ARG(mg);
1964 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1965 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1966 if (found && found->mg_len >= 0) {
1967 I32 i = found->mg_len;
1969 sv_pos_b2u(lsv, &i);
1970 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1979 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1982 SV* const lsv = LvTARG(sv);
1988 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1989 PERL_UNUSED_ARG(mg);
1991 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1992 found = mg_find(lsv, PERL_MAGIC_regex_global);
1998 #ifdef PERL_OLD_COPY_ON_WRITE
2000 sv_force_normal_flags(lsv, 0);
2002 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2005 else if (!SvOK(sv)) {
2009 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2011 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2014 ulen = sv_len_utf8(lsv);
2024 else if (pos > (SSize_t)len)
2029 sv_pos_u2b(lsv, &p, 0);
2033 found->mg_len = pos;
2034 found->mg_flags &= ~MGf_MINMATCH;
2040 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2043 SV * const lsv = LvTARG(sv);
2044 const char * const tmps = SvPV_const(lsv,len);
2045 I32 offs = LvTARGOFF(sv);
2046 I32 rem = LvTARGLEN(sv);
2048 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2049 PERL_UNUSED_ARG(mg);
2052 sv_pos_u2b(lsv, &offs, &rem);
2053 if (offs > (I32)len)
2055 if (rem + offs > (I32)len)
2057 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2064 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2068 const char * const tmps = SvPV_const(sv, len);
2069 SV * const lsv = LvTARG(sv);
2070 I32 lvoff = LvTARGOFF(sv);
2071 I32 lvlen = LvTARGLEN(sv);
2073 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2074 PERL_UNUSED_ARG(mg);
2077 sv_utf8_upgrade(lsv);
2078 sv_pos_u2b(lsv, &lvoff, &lvlen);
2079 sv_insert(lsv, lvoff, lvlen, tmps, len);
2080 LvTARGLEN(sv) = sv_len_utf8(sv);
2083 else if (lsv && SvUTF8(lsv)) {
2085 sv_pos_u2b(lsv, &lvoff, &lvlen);
2086 LvTARGLEN(sv) = len;
2087 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2088 sv_insert(lsv, lvoff, lvlen, utf8, len);
2092 sv_insert(lsv, lvoff, lvlen, tmps, len);
2093 LvTARGLEN(sv) = len;
2101 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2105 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2106 PERL_UNUSED_ARG(sv);
2108 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2113 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2117 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2118 PERL_UNUSED_ARG(sv);
2120 /* update taint status */
2129 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2131 SV * const lsv = LvTARG(sv);
2133 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2134 PERL_UNUSED_ARG(mg);
2137 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2145 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2147 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2148 PERL_UNUSED_ARG(mg);
2149 do_vecset(sv); /* XXX slurp this routine */
2154 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2159 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2161 if (LvTARGLEN(sv)) {
2163 SV * const ahv = LvTARG(sv);
2164 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2169 AV *const av = MUTABLE_AV(LvTARG(sv));
2170 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2171 targ = AvARRAY(av)[LvTARGOFF(sv)];
2173 if (targ && (targ != &PL_sv_undef)) {
2174 /* somebody else defined it for us */
2175 SvREFCNT_dec(LvTARG(sv));
2176 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2178 SvREFCNT_dec(mg->mg_obj);
2180 mg->mg_flags &= ~MGf_REFCOUNTED;
2185 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2190 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2192 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2193 PERL_UNUSED_ARG(mg);
2197 sv_setsv(LvTARG(sv), sv);
2198 SvSETMAGIC(LvTARG(sv));
2204 Perl_vivify_defelem(pTHX_ SV *sv)
2210 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2212 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2215 SV * const ahv = LvTARG(sv);
2216 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2219 if (!value || value == &PL_sv_undef)
2220 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2223 AV *const av = MUTABLE_AV(LvTARG(sv));
2224 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2225 LvTARG(sv) = NULL; /* array can't be extended */
2227 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2228 if (!svp || (value = *svp) == &PL_sv_undef)
2229 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2232 SvREFCNT_inc_simple_void(value);
2233 SvREFCNT_dec(LvTARG(sv));
2236 SvREFCNT_dec(mg->mg_obj);
2238 mg->mg_flags &= ~MGf_REFCOUNTED;
2242 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2244 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2245 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2249 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2251 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2252 PERL_UNUSED_CONTEXT;
2259 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2261 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2263 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2265 if (uf && uf->uf_set)
2266 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2271 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2273 const char type = mg->mg_type;
2275 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2277 if (type == PERL_MAGIC_qr) {
2278 } else if (type == PERL_MAGIC_bm) {
2282 assert(type == PERL_MAGIC_fm);
2285 return sv_unmagic(sv, type);
2288 #ifdef USE_LOCALE_COLLATE
2290 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2292 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2295 * RenE<eacute> Descartes said "I think not."
2296 * and vanished with a faint plop.
2298 PERL_UNUSED_CONTEXT;
2299 PERL_UNUSED_ARG(sv);
2301 Safefree(mg->mg_ptr);
2307 #endif /* USE_LOCALE_COLLATE */
2309 /* Just clear the UTF-8 cache data. */
2311 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2313 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2314 PERL_UNUSED_CONTEXT;
2315 PERL_UNUSED_ARG(sv);
2316 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2318 mg->mg_len = -1; /* The mg_len holds the len cache. */
2323 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2326 register const char *s;
2328 register const REGEXP * rx;
2329 const char * const remaining = mg->mg_ptr + 1;
2333 PERL_ARGS_ASSERT_MAGIC_SET;
2335 switch (*mg->mg_ptr) {
2336 case '\015': /* $^MATCH */
2337 if (strEQ(remaining, "ATCH"))
2339 case '`': /* ${^PREMATCH} caught below */
2341 paren = RX_BUFF_IDX_PREMATCH;
2343 case '\'': /* ${^POSTMATCH} caught below */
2345 paren = RX_BUFF_IDX_POSTMATCH;
2349 paren = RX_BUFF_IDX_FULLMATCH;
2351 case '1': case '2': case '3': case '4':
2352 case '5': case '6': case '7': case '8': case '9':
2353 paren = atoi(mg->mg_ptr);
2355 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2356 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2359 /* Croak with a READONLY error when a numbered match var is
2360 * set without a previous pattern match. Unless it's C<local $1>
2362 if (!PL_localizing) {
2363 Perl_croak(aTHX_ "%s", PL_no_modify);
2366 case '\001': /* ^A */
2367 sv_setsv(PL_bodytarget, sv);
2369 case '\003': /* ^C */
2370 PL_minus_c = (bool)SvIV(sv);
2373 case '\004': /* ^D */
2375 s = SvPV_nolen_const(sv);
2376 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2377 DEBUG_x(dump_all());
2379 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2382 case '\005': /* ^E */
2383 if (*(mg->mg_ptr+1) == '\0') {
2384 #ifdef MACOS_TRADITIONAL
2385 gMacPerl_OSErr = SvIV(sv);
2388 set_vaxc_errno(SvIV(sv));
2391 SetLastError( SvIV(sv) );
2394 os2_setsyserrno(SvIV(sv));
2396 /* will anyone ever use this? */
2397 SETERRNO(SvIV(sv), 4);
2403 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2405 SvREFCNT_dec(PL_encoding);
2406 if (SvOK(sv) || SvGMAGICAL(sv)) {
2407 PL_encoding = newSVsv(sv);
2414 case '\006': /* ^F */
2415 PL_maxsysfd = SvIV(sv);
2417 case '\010': /* ^H */
2418 PL_hints = SvIV(sv);
2420 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2421 Safefree(PL_inplace);
2422 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2424 case '\017': /* ^O */
2425 if (*(mg->mg_ptr+1) == '\0') {
2426 Safefree(PL_osname);
2429 TAINT_PROPER("assigning to $^O");
2430 PL_osname = savesvpv(sv);
2433 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2435 const char *const start = SvPV(sv, len);
2436 const char *out = (const char*)memchr(start, '\0', len);
2438 struct refcounted_he *tmp_he;
2441 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2443 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2445 /* Opening for input is more common than opening for output, so
2446 ensure that hints for input are sooner on linked list. */
2447 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2448 SVs_TEMP | SvUTF8(sv))
2449 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
2452 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2453 newSVpvs_flags("open>", SVs_TEMP),
2456 /* The UTF-8 setting is carried over */
2457 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2459 PL_compiling.cop_hints_hash
2460 = Perl_refcounted_he_new(aTHX_ tmp_he,
2461 newSVpvs_flags("open<", SVs_TEMP),
2465 case '\020': /* ^P */
2466 if (*remaining == '\0') { /* ^P */
2467 PL_perldb = SvIV(sv);
2468 if (PL_perldb && !PL_DBsingle)
2471 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2473 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2476 case '\024': /* ^T */
2478 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2480 PL_basetime = (Time_t)SvIV(sv);
2483 case '\025': /* ^UTF8CACHE */
2484 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2485 PL_utf8cache = (signed char) sv_2iv(sv);
2488 case '\027': /* ^W & $^WARNING_BITS */
2489 if (*(mg->mg_ptr+1) == '\0') {
2490 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2492 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2493 | (i ? G_WARN_ON : G_WARN_OFF) ;
2496 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2497 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2498 if (!SvPOK(sv) && PL_localizing) {
2499 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2500 PL_compiling.cop_warnings = pWARN_NONE;
2505 int accumulate = 0 ;
2506 int any_fatals = 0 ;
2507 const char * const ptr = SvPV_const(sv, len) ;
2508 for (i = 0 ; i < len ; ++i) {
2509 accumulate |= ptr[i] ;
2510 any_fatals |= (ptr[i] & 0xAA) ;
2513 if (!specialWARN(PL_compiling.cop_warnings))
2514 PerlMemShared_free(PL_compiling.cop_warnings);
2515 PL_compiling.cop_warnings = pWARN_NONE;
2517 /* Yuck. I can't see how to abstract this: */
2518 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2519 WARN_ALL) && !any_fatals) {
2520 if (!specialWARN(PL_compiling.cop_warnings))
2521 PerlMemShared_free(PL_compiling.cop_warnings);
2522 PL_compiling.cop_warnings = pWARN_ALL;
2523 PL_dowarn |= G_WARN_ONCE ;
2527 const char *const p = SvPV_const(sv, len);
2529 PL_compiling.cop_warnings
2530 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2533 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2534 PL_dowarn |= G_WARN_ONCE ;
2542 if (PL_localizing) {
2543 if (PL_localizing == 1)
2544 SAVESPTR(PL_last_in_gv);
2546 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2547 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2550 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2551 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2552 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2555 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2556 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2557 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2560 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2563 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2564 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2565 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2568 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2572 IO * const io = GvIOp(PL_defoutgv);
2575 if ((SvIV(sv)) == 0)
2576 IoFLAGS(io) &= ~IOf_FLUSH;
2578 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2579 PerlIO *ofp = IoOFP(io);
2581 (void)PerlIO_flush(ofp);
2582 IoFLAGS(io) |= IOf_FLUSH;
2588 SvREFCNT_dec(PL_rs);
2589 PL_rs = newSVsv(sv);
2593 SvREFCNT_dec(PL_ors_sv);
2594 if (SvOK(sv) || SvGMAGICAL(sv)) {
2595 PL_ors_sv = newSVsv(sv);
2603 SvREFCNT_dec(PL_ofs_sv);
2604 if (SvOK(sv) || SvGMAGICAL(sv)) {
2605 PL_ofs_sv = newSVsv(sv);
2612 CopARYBASE_set(&PL_compiling, SvIV(sv));
2615 #ifdef COMPLEX_STATUS
2616 if (PL_localizing == 2) {
2617 PL_statusvalue = LvTARGOFF(sv);
2618 PL_statusvalue_vms = LvTARGLEN(sv);
2622 #ifdef VMSISH_STATUS
2624 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2627 STATUS_UNIX_EXIT_SET(SvIV(sv));
2632 # define PERL_VMS_BANG vaxc$errno
2634 # define PERL_VMS_BANG 0
2636 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2637 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2642 if (PL_delaymagic) {
2643 PL_delaymagic |= DM_RUID;
2644 break; /* don't do magic till later */
2647 (void)setruid((Uid_t)PL_uid);
2650 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2652 #ifdef HAS_SETRESUID
2653 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2655 if (PL_uid == PL_euid) { /* special case $< = $> */
2657 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2658 if (PL_uid != 0 && PerlProc_getuid() == 0)
2659 (void)PerlProc_setuid(0);
2661 (void)PerlProc_setuid(PL_uid);
2663 PL_uid = PerlProc_getuid();
2664 Perl_croak(aTHX_ "setruid() not implemented");
2669 PL_uid = PerlProc_getuid();
2670 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2674 if (PL_delaymagic) {
2675 PL_delaymagic |= DM_EUID;
2676 break; /* don't do magic till later */
2679 (void)seteuid((Uid_t)PL_euid);
2682 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2684 #ifdef HAS_SETRESUID
2685 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2687 if (PL_euid == PL_uid) /* special case $> = $< */
2688 PerlProc_setuid(PL_euid);
2690 PL_euid = PerlProc_geteuid();
2691 Perl_croak(aTHX_ "seteuid() not implemented");
2696 PL_euid = PerlProc_geteuid();
2697 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2701 if (PL_delaymagic) {
2702 PL_delaymagic |= DM_RGID;
2703 break; /* don't do magic till later */
2706 (void)setrgid((Gid_t)PL_gid);
2709 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2711 #ifdef HAS_SETRESGID
2712 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2714 if (PL_gid == PL_egid) /* special case $( = $) */
2715 (void)PerlProc_setgid(PL_gid);
2717 PL_gid = PerlProc_getgid();
2718 Perl_croak(aTHX_ "setrgid() not implemented");
2723 PL_gid = PerlProc_getgid();
2724 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2727 #ifdef HAS_SETGROUPS
2729 const char *p = SvPV_const(sv, len);
2730 Groups_t *gary = NULL;
2735 for (i = 0; i < NGROUPS; ++i) {
2736 while (*p && !isSPACE(*p))
2743 Newx(gary, i + 1, Groups_t);
2745 Renew(gary, i + 1, Groups_t);
2749 (void)setgroups(i, gary);
2752 #else /* HAS_SETGROUPS */
2754 #endif /* HAS_SETGROUPS */
2755 if (PL_delaymagic) {
2756 PL_delaymagic |= DM_EGID;
2757 break; /* don't do magic till later */
2760 (void)setegid((Gid_t)PL_egid);
2763 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2765 #ifdef HAS_SETRESGID
2766 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2768 if (PL_egid == PL_gid) /* special case $) = $( */
2769 (void)PerlProc_setgid(PL_egid);
2771 PL_egid = PerlProc_getegid();
2772 Perl_croak(aTHX_ "setegid() not implemented");
2777 PL_egid = PerlProc_getegid();
2778 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2781 PL_chopset = SvPV_force(sv,len);
2783 #ifndef MACOS_TRADITIONAL
2785 LOCK_DOLLARZERO_MUTEX;
2786 #ifdef HAS_SETPROCTITLE
2787 /* The BSDs don't show the argv[] in ps(1) output, they
2788 * show a string from the process struct and provide
2789 * the setproctitle() routine to manipulate that. */
2790 if (PL_origalen != 1) {
2791 s = SvPV_const(sv, len);
2792 # if __FreeBSD_version > 410001
2793 /* The leading "-" removes the "perl: " prefix,
2794 * but not the "(perl) suffix from the ps(1)
2795 * output, because that's what ps(1) shows if the
2796 * argv[] is modified. */
2797 setproctitle("-%s", s);
2798 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2799 /* This doesn't really work if you assume that
2800 * $0 = 'foobar'; will wipe out 'perl' from the $0
2801 * because in ps(1) output the result will be like
2802 * sprintf("perl: %s (perl)", s)
2803 * I guess this is a security feature:
2804 * one (a user process) cannot get rid of the original name.
2806 setproctitle("%s", s);
2809 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2810 if (PL_origalen != 1) {
2812 s = SvPV_const(sv, len);
2813 un.pst_command = (char *)s;
2814 pstat(PSTAT_SETCMD, un, len, 0, 0);
2817 if (PL_origalen > 1) {
2818 /* PL_origalen is set in perl_parse(). */
2819 s = SvPV_force(sv,len);
2820 if (len >= (STRLEN)PL_origalen-1) {
2821 /* Longer than original, will be truncated. We assume that
2822 * PL_origalen bytes are available. */
2823 Copy(s, PL_origargv[0], PL_origalen-1, char);
2826 /* Shorter than original, will be padded. */
2828 /* Special case for Mac OS X: see [perl #38868] */
2831 /* Is the space counterintuitive? Yes.
2832 * (You were expecting \0?)
2833 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2835 const int pad = ' ';
2837 Copy(s, PL_origargv[0], len, char);
2838 PL_origargv[0][len] = 0;
2839 memset(PL_origargv[0] + len + 1,
2840 pad, PL_origalen - len - 1);
2842 PL_origargv[0][PL_origalen-1] = 0;
2843 for (i = 1; i < PL_origargc; i++)
2847 UNLOCK_DOLLARZERO_MUTEX;
2855 Perl_whichsig(pTHX_ const char *sig)
2857 register char* const* sigv;
2859 PERL_ARGS_ASSERT_WHICHSIG;
2860 PERL_UNUSED_CONTEXT;
2862 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2863 if (strEQ(sig,*sigv))
2864 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2866 if (strEQ(sig,"CHLD"))
2870 if (strEQ(sig,"CLD"))
2877 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2878 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2880 Perl_sighandler(int sig)
2883 #ifdef PERL_GET_SIG_CONTEXT
2884 dTHXa(PERL_GET_SIG_CONTEXT);
2891 SV * const tSv = PL_Sv;
2895 XPV * const tXpv = PL_Xpv;
2897 if (PL_savestack_ix + 15 <= PL_savestack_max)
2899 if (PL_markstack_ptr < PL_markstack_max - 2)
2901 if (PL_scopestack_ix < PL_scopestack_max - 3)
2904 if (!PL_psig_ptr[sig]) {
2905 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2910 /* Max number of items pushed there is 3*n or 4. We cannot fix
2911 infinity, so we fix 4 (in fact 5): */
2913 PL_savestack_ix += 5; /* Protect save in progress. */
2914 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2917 PL_markstack_ptr++; /* Protect mark. */
2919 PL_scopestack_ix += 1;
2920 /* sv_2cv is too complicated, try a simpler variant first: */
2921 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2922 || SvTYPE(cv) != SVt_PVCV) {
2924 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2927 if (!cv || !CvROOT(cv)) {
2928 if (ckWARN(WARN_SIGNAL))
2929 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2930 PL_sig_name[sig], (gv ? GvENAME(gv)
2937 if(PL_psig_name[sig]) {
2938 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2940 #if !defined(PERL_IMPLICIT_CONTEXT)
2944 sv = sv_newmortal();
2945 sv_setpv(sv,PL_sig_name[sig]);
2948 PUSHSTACKi(PERLSI_SIGNAL);
2951 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2953 struct sigaction oact;
2955 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2958 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2959 /* The siginfo fields signo, code, errno, pid, uid,
2960 * addr, status, and band are defined by POSIX/SUSv3. */
2961 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2962 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2963 #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. */
2964 hv_stores(sih, "errno", newSViv(sip->si_errno));
2965 hv_stores(sih, "status", newSViv(sip->si_status));
2966 hv_stores(sih, "uid", newSViv(sip->si_uid));
2967 hv_stores(sih, "pid", newSViv(sip->si_pid));
2968 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2969 hv_stores(sih, "band", newSViv(sip->si_band));
2973 mPUSHp((char *)sip, sizeof(*sip));
2981 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2984 if (SvTRUE(ERRSV)) {
2986 #ifdef HAS_SIGPROCMASK
2987 /* Handler "died", for example to get out of a restart-able read().
2988 * Before we re-do that on its behalf re-enable the signal which was
2989 * blocked by the system when we entered.
2993 sigaddset(&set,sig);
2994 sigprocmask(SIG_UNBLOCK, &set, NULL);
2996 /* Not clear if this will work */
2997 (void)rsignal(sig, SIG_IGN);
2998 (void)rsignal(sig, PL_csighandlerp);
3000 #endif /* !PERL_MICRO */
3001 Perl_die(aTHX_ NULL);
3005 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3009 PL_scopestack_ix -= 1;
3012 PL_op = myop; /* Apparently not needed... */
3014 PL_Sv = tSv; /* Restore global temporaries. */
3021 S_restore_magic(pTHX_ const void *p)
3024 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3025 SV* const sv = mgs->mgs_sv;
3030 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3032 #ifdef PERL_OLD_COPY_ON_WRITE
3033 /* While magic was saved (and off) sv_setsv may well have seen
3034 this SV as a prime candidate for COW. */
3036 sv_force_normal_flags(sv, 0);
3040 SvFLAGS(sv) |= mgs->mgs_flags;
3043 if (SvGMAGICAL(sv)) {
3044 /* downgrade public flags to private,
3045 and discard any other private flags */
3047 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3049 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3050 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3055 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3057 /* If we're still on top of the stack, pop us off. (That condition
3058 * will be satisfied if restore_magic was called explicitly, but *not*
3059 * if it's being called via leave_scope.)
3060 * The reason for doing this is that otherwise, things like sv_2cv()
3061 * may leave alloc gunk on the savestack, and some code
3062 * (e.g. sighandler) doesn't expect that...
3064 if (PL_savestack_ix == mgs->mgs_ss_ix)
3066 I32 popval = SSPOPINT;
3067 assert(popval == SAVEt_DESTRUCTOR_X);
3068 PL_savestack_ix -= 2;
3070 assert(popval == SAVEt_ALLOC);
3072 PL_savestack_ix -= popval;
3078 S_unwind_handler_stack(pTHX_ const void *p)
3081 const U32 flags = *(const U32*)p;
3083 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3086 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3087 #if !defined(PERL_IMPLICIT_CONTEXT)
3089 SvREFCNT_dec(PL_sig_sv);
3094 =for apidoc magic_sethint
3096 Triggered by a store to %^H, records the key/value pair to
3097 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3098 anything that would need a deep copy. Maybe we should warn if we find a
3104 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3107 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3108 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3110 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3112 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3113 an alternative leaf in there, with PL_compiling.cop_hints being used if
3114 it's NULL. If needed for threads, the alternative could lock a mutex,
3115 or take other more complex action. */
3117 /* Something changed in %^H, so it will need to be restored on scope exit.
3118 Doing this here saves a lot of doing it manually in perl code (and
3119 forgetting to do it, and consequent subtle errors. */
3120 PL_hints |= HINT_LOCALIZE_HH;
3121 PL_compiling.cop_hints_hash
3122 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3127 =for apidoc magic_clearhint
3129 Triggered by a delete from %^H, records the key to
3130 C<PL_compiling.cop_hints_hash>.
3135 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3139 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3140 PERL_UNUSED_ARG(sv);
3142 assert(mg->mg_len == HEf_SVKEY);
3144 PERL_UNUSED_ARG(sv);
3146 PL_hints |= HINT_LOCALIZE_HH;
3147 PL_compiling.cop_hints_hash
3148 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3149 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3155 * c-indentation-style: bsd
3157 * indent-tabs-mode: t
3160 * ex: set ts=8 sts=4 sw=4 noet: