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_tiedscalar: /* so 'local $scalar' isn't tied */
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 CALL_FPTR(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 CALL_FPTR(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 = CALL_FPTR(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 = CALL_FPTR(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 CALL_FPTR(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 += CALL_FPTR(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)CALL_FPTR(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);
529 Free any magic storage used by the SV. See C<sv_magic>.
535 Perl_mg_free(pTHX_ SV *sv)
540 PERL_ARGS_ASSERT_MG_FREE;
542 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
543 const MGVTBL* const vtbl = mg->mg_virtual;
544 moremagic = mg->mg_moremagic;
545 if (vtbl && vtbl->svt_free)
546 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
547 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
548 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
549 Safefree(mg->mg_ptr);
550 else if (mg->mg_len == HEf_SVKEY)
551 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
553 if (mg->mg_flags & MGf_REFCOUNTED)
554 SvREFCNT_dec(mg->mg_obj);
556 SvMAGIC_set(sv, moremagic);
558 SvMAGIC_set(sv, NULL);
566 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
571 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
574 register const REGEXP * const rx = PM_GETRE(PL_curpm);
576 if (mg->mg_obj) { /* @+ */
577 /* return the number possible */
578 return RX_NPARENS(rx);
580 I32 paren = RX_LASTPAREN(rx);
582 /* return the last filled */
584 && (RX_OFFS(rx)[paren].start == -1
585 || RX_OFFS(rx)[paren].end == -1) )
596 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
600 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
603 register const REGEXP * const rx = PM_GETRE(PL_curpm);
605 register const I32 paren = mg->mg_len;
610 if (paren <= (I32)RX_NPARENS(rx) &&
611 (s = RX_OFFS(rx)[paren].start) != -1 &&
612 (t = RX_OFFS(rx)[paren].end) != -1)
615 if (mg->mg_obj) /* @+ */
620 if (i > 0 && RX_MATCH_UTF8(rx)) {
621 const char * const b = RX_SUBBEG(rx);
623 i = utf8_length((U8*)b, (U8*)(b+i));
634 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
636 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
639 Perl_croak(aTHX_ "%s", PL_no_modify);
640 NORETURN_FUNCTION_END;
644 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
649 register const REGEXP * rx;
650 const char * const remaining = mg->mg_ptr + 1;
652 PERL_ARGS_ASSERT_MAGIC_LEN;
654 switch (*mg->mg_ptr) {
656 if (*remaining == '\0') { /* ^P */
658 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
660 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
664 case '\015': /* $^MATCH */
665 if (strEQ(remaining, "ATCH")) {
672 paren = RX_BUFF_IDX_PREMATCH;
676 paren = RX_BUFF_IDX_POSTMATCH;
680 paren = RX_BUFF_IDX_FULLMATCH;
682 case '1': case '2': case '3': case '4':
683 case '5': case '6': case '7': case '8': case '9':
684 paren = atoi(mg->mg_ptr);
686 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
688 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
691 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
694 if (ckWARN(WARN_UNINITIALIZED))
699 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
700 paren = RX_LASTPAREN(rx);
705 case '\016': /* ^N */
706 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
707 paren = RX_LASTCLOSEPAREN(rx);
714 if (!SvPOK(sv) && SvNIOK(sv)) {
722 #define SvRTRIM(sv) STMT_START { \
724 STRLEN len = SvCUR(sv); \
725 char * const p = SvPVX(sv); \
726 while (len > 0 && isSPACE(p[len-1])) \
728 SvCUR_set(sv, len); \
734 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
736 PERL_ARGS_ASSERT_EMULATE_COP_IO;
738 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
739 sv_setsv(sv, &PL_sv_undef);
743 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
744 SV *const value = Perl_refcounted_he_fetch(aTHX_
746 0, "open<", 5, 0, 0);
751 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
752 SV *const value = Perl_refcounted_he_fetch(aTHX_
754 0, "open>", 5, 0, 0);
762 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
766 register char *s = NULL;
768 const char * const remaining = mg->mg_ptr + 1;
769 const char nextchar = *remaining;
771 PERL_ARGS_ASSERT_MAGIC_GET;
773 switch (*mg->mg_ptr) {
774 case '\001': /* ^A */
775 sv_setsv(sv, PL_bodytarget);
777 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
778 if (nextchar == '\0') {
779 sv_setiv(sv, (IV)PL_minus_c);
781 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
782 sv_setiv(sv, (IV)STATUS_NATIVE);
786 case '\004': /* ^D */
787 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
789 case '\005': /* ^E */
790 if (nextchar == '\0') {
793 # include <descrip.h>
794 # include <starlet.h>
796 $DESCRIPTOR(msgdsc,msg);
797 sv_setnv(sv,(NV) vaxc$errno);
798 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
799 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
804 if (!(_emx_env & 0x200)) { /* Under DOS */
805 sv_setnv(sv, (NV)errno);
806 sv_setpv(sv, errno ? Strerror(errno) : "");
808 if (errno != errno_isOS2) {
809 const int tmp = _syserrno();
810 if (tmp) /* 2nd call to _syserrno() makes it 0 */
813 sv_setnv(sv, (NV)Perl_rc);
814 sv_setpv(sv, os2error(Perl_rc));
818 const DWORD dwErr = GetLastError();
819 sv_setnv(sv, (NV)dwErr);
821 PerlProc_GetOSError(sv, dwErr);
830 sv_setnv(sv, (NV)errno);
831 sv_setpv(sv, errno ? Strerror(errno) : "");
836 SvNOK_on(sv); /* what a wonderful hack! */
838 else if (strEQ(remaining, "NCODING"))
839 sv_setsv(sv, PL_encoding);
841 case '\006': /* ^F */
842 sv_setiv(sv, (IV)PL_maxsysfd);
844 case '\010': /* ^H */
845 sv_setiv(sv, (IV)PL_hints);
847 case '\011': /* ^I */ /* NOT \t in EBCDIC */
848 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
850 case '\017': /* ^O & ^OPEN */
851 if (nextchar == '\0') {
852 sv_setpv(sv, PL_osname);
855 else if (strEQ(remaining, "PEN")) {
856 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
860 if (nextchar == '\0') { /* ^P */
861 sv_setiv(sv, (IV)PL_perldb);
862 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
863 goto do_prematch_fetch;
864 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
865 goto do_postmatch_fetch;
868 case '\023': /* ^S */
869 if (nextchar == '\0') {
870 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
873 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
878 case '\024': /* ^T */
879 if (nextchar == '\0') {
881 sv_setnv(sv, PL_basetime);
883 sv_setiv(sv, (IV)PL_basetime);
886 else if (strEQ(remaining, "AINT"))
887 sv_setiv(sv, PL_tainting
888 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
891 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
892 if (strEQ(remaining, "NICODE"))
893 sv_setuv(sv, (UV) PL_unicode);
894 else if (strEQ(remaining, "TF8LOCALE"))
895 sv_setuv(sv, (UV) PL_utf8locale);
896 else if (strEQ(remaining, "TF8CACHE"))
897 sv_setiv(sv, (IV) PL_utf8cache);
899 case '\027': /* ^W & $^WARNING_BITS */
900 if (nextchar == '\0')
901 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
902 else if (strEQ(remaining, "ARNING_BITS")) {
903 if (PL_compiling.cop_warnings == pWARN_NONE) {
904 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
906 else if (PL_compiling.cop_warnings == pWARN_STD) {
909 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
913 else if (PL_compiling.cop_warnings == pWARN_ALL) {
914 /* Get the bit mask for $warnings::Bits{all}, because
915 * it could have been extended by warnings::register */
916 HV * const bits=get_hv("warnings::Bits", 0);
918 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
920 sv_setsv(sv, *bits_all);
923 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
927 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
928 *PL_compiling.cop_warnings);
933 case '\015': /* $^MATCH */
934 if (strEQ(remaining, "ATCH")) {
935 case '1': case '2': case '3': case '4':
936 case '5': case '6': case '7': case '8': case '9': case '&':
937 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
939 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
940 * XXX Does the new way break anything?
942 paren = atoi(mg->mg_ptr); /* $& is in [0] */
943 CALLREG_NUMBUF_FETCH(rx,paren,sv);
946 sv_setsv(sv,&PL_sv_undef);
950 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
951 if (RX_LASTPAREN(rx)) {
952 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
956 sv_setsv(sv,&PL_sv_undef);
958 case '\016': /* ^N */
959 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
960 if (RX_LASTCLOSEPAREN(rx)) {
961 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
966 sv_setsv(sv,&PL_sv_undef);
970 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
971 CALLREG_NUMBUF_FETCH(rx,-2,sv);
974 sv_setsv(sv,&PL_sv_undef);
978 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
979 CALLREG_NUMBUF_FETCH(rx,-1,sv);
982 sv_setsv(sv,&PL_sv_undef);
985 if (GvIO(PL_last_in_gv)) {
986 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
991 sv_setiv(sv, (IV)STATUS_CURRENT);
992 #ifdef COMPLEX_STATUS
993 SvUPGRADE(sv, SVt_PVLV);
994 LvTARGOFF(sv) = PL_statusvalue;
995 LvTARGLEN(sv) = PL_statusvalue_vms;
1000 if (!isGV_with_GP(PL_defoutgv))
1002 else if (GvIOp(PL_defoutgv))
1003 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1007 sv_setpv(sv,GvENAME(PL_defoutgv));
1008 sv_catpvs(sv,"_TOP");
1012 if (!isGV_with_GP(PL_defoutgv))
1014 else if (GvIOp(PL_defoutgv))
1015 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1017 s = GvENAME(PL_defoutgv);
1021 if (GvIO(PL_defoutgv))
1022 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1025 if (GvIO(PL_defoutgv))
1026 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1029 if (GvIO(PL_defoutgv))
1030 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1037 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1040 if (GvIO(PL_defoutgv))
1041 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1045 sv_copypv(sv, PL_ors_sv);
1051 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1053 sv_setnv(sv, (NV)errno);
1056 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1057 sv_setpv(sv, os2error(Perl_rc));
1060 sv_setpv(sv, errno ? Strerror(errno) : "");
1062 SvPOK_on(sv); /* may have got removed during taint processing */
1067 SvNOK_on(sv); /* what a wonderful hack! */
1070 sv_setiv(sv, (IV)PL_uid);
1073 sv_setiv(sv, (IV)PL_euid);
1076 sv_setiv(sv, (IV)PL_gid);
1079 sv_setiv(sv, (IV)PL_egid);
1081 #ifdef HAS_GETGROUPS
1083 Groups_t *gary = NULL;
1084 I32 i, num_groups = getgroups(0, gary);
1085 Newx(gary, num_groups, Groups_t);
1086 num_groups = getgroups(num_groups, gary);
1087 for (i = 0; i < num_groups; i++)
1088 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1091 (void)SvIOK_on(sv); /* what a wonderful hack! */
1101 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1103 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1105 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1107 if (uf && uf->uf_val)
1108 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1113 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1116 STRLEN len = 0, klen;
1117 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1118 const char * const ptr = MgPV_const(mg,klen);
1121 PERL_ARGS_ASSERT_MAGIC_SETENV;
1123 #ifdef DYNAMIC_ENV_FETCH
1124 /* We just undefd an environment var. Is a replacement */
1125 /* waiting in the wings? */
1127 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1129 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1133 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1134 /* And you'll never guess what the dog had */
1135 /* in its mouth... */
1137 MgTAINTEDDIR_off(mg);
1139 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1140 char pathbuf[256], eltbuf[256], *cp, *elt;
1144 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1146 do { /* DCL$PATH may be a search list */
1147 while (1) { /* as may dev portion of any element */
1148 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1149 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1150 cando_by_name(S_IWUSR,0,elt) ) {
1151 MgTAINTEDDIR_on(mg);
1155 if ((cp = strchr(elt, ':')) != NULL)
1157 if (my_trnlnm(elt, eltbuf, j++))
1163 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1166 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1167 const char * const strend = s + len;
1169 while (s < strend) {
1173 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1174 const char path_sep = '|';
1176 const char path_sep = ':';
1178 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1179 s, strend, path_sep, &i);
1181 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1183 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1185 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1187 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1188 MgTAINTEDDIR_on(mg);
1194 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1200 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1202 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1203 PERL_UNUSED_ARG(sv);
1204 my_setenv(MgPV_nolen_const(mg),NULL);
1209 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1212 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1213 PERL_UNUSED_ARG(mg);
1215 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1217 if (PL_localizing) {
1220 hv_iterinit(MUTABLE_HV(sv));
1221 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1223 my_setenv(hv_iterkey(entry, &keylen),
1224 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1232 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1235 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1236 PERL_UNUSED_ARG(sv);
1237 PERL_UNUSED_ARG(mg);
1239 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1247 #ifdef HAS_SIGPROCMASK
1249 restore_sigmask(pTHX_ SV *save_sv)
1251 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1252 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1256 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1259 /* Are we fetching a signal entry? */
1260 int i = (I16)mg->mg_private;
1262 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1265 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1270 sv_setsv(sv,PL_psig_ptr[i]);
1272 Sighandler_t sigstate = rsignal_state(i);
1273 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1274 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1277 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1278 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1281 /* cache state so we don't fetch it again */
1282 if(sigstate == (Sighandler_t) SIG_IGN)
1283 sv_setpvs(sv,"IGNORE");
1285 sv_setsv(sv,&PL_sv_undef);
1286 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1293 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1295 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1296 PERL_UNUSED_ARG(sv);
1298 magic_setsig(NULL, mg);
1299 return sv_unmagic(sv, mg->mg_type);
1303 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1304 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1306 Perl_csighandler(int sig)
1309 #ifdef PERL_GET_SIG_CONTEXT
1310 dTHXa(PERL_GET_SIG_CONTEXT);
1314 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1315 (void) rsignal(sig, PL_csighandlerp);
1316 if (PL_sig_ignoring[sig]) return;
1318 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319 if (PL_sig_defaulting[sig])
1320 #ifdef KILL_BY_SIGPRC
1321 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1336 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1337 /* Call the perl level handler now--
1338 * with risk we may be in malloc() or being destructed etc. */
1339 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1340 (*PL_sighandlerp)(sig, NULL, NULL);
1342 (*PL_sighandlerp)(sig);
1345 if (!PL_psig_pend) return;
1346 /* Set a flag to say this signal is pending, that is awaiting delivery after
1347 * the current Perl opcode completes */
1348 PL_psig_pend[sig]++;
1350 #ifndef SIG_PENDING_DIE_COUNT
1351 # define SIG_PENDING_DIE_COUNT 120
1353 /* Add one to say _a_ signal is pending */
1354 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1355 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1356 (unsigned long)SIG_PENDING_DIE_COUNT);
1360 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1362 Perl_csighandler_init(void)
1365 if (PL_sig_handlers_initted) return;
1367 for (sig = 1; sig < SIG_SIZE; sig++) {
1368 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1370 PL_sig_defaulting[sig] = 1;
1371 (void) rsignal(sig, PL_csighandlerp);
1373 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1374 PL_sig_ignoring[sig] = 0;
1377 PL_sig_handlers_initted = 1;
1382 Perl_despatch_signals(pTHX)
1387 for (sig = 1; sig < SIG_SIZE; sig++) {
1388 if (PL_psig_pend[sig]) {
1389 PERL_BLOCKSIG_ADD(set, sig);
1390 PL_psig_pend[sig] = 0;
1391 PERL_BLOCKSIG_BLOCK(set);
1392 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1393 (*PL_sighandlerp)(sig, NULL, NULL);
1395 (*PL_sighandlerp)(sig);
1397 PERL_BLOCKSIG_UNBLOCK(set);
1402 /* sv of NULL signifies that we're acting as magic_clearsig. */
1404 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1409 /* Need to be careful with SvREFCNT_dec(), because that can have side
1410 * effects (due to closures). We must make sure that the new disposition
1411 * is in place before it is called.
1415 #ifdef HAS_SIGPROCMASK
1419 register const char *s = MgPV_const(mg,len);
1421 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1424 if (strEQ(s,"__DIE__"))
1426 else if (strEQ(s,"__WARN__")
1427 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1428 /* Merge the existing behaviours, which are as follows:
1429 magic_setsig, we always set svp to &PL_warnhook
1430 (hence we always change the warnings handler)
1431 For magic_clearsig, we don't change the warnings handler if it's
1432 set to the &PL_warnhook. */
1435 Perl_croak(aTHX_ "No such hook: %s", s);
1438 if (*svp != PERL_WARNHOOK_FATAL)
1444 i = (I16)mg->mg_private;
1446 i = whichsig(s); /* ...no, a brick */
1447 mg->mg_private = (U16)i;
1451 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1454 #ifdef HAS_SIGPROCMASK
1455 /* Avoid having the signal arrive at a bad time, if possible. */
1458 sigprocmask(SIG_BLOCK, &set, &save);
1460 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1461 SAVEFREESV(save_sv);
1462 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1465 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1466 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1468 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1469 PL_sig_ignoring[i] = 0;
1471 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1472 PL_sig_defaulting[i] = 0;
1474 to_dec = PL_psig_ptr[i];
1476 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1477 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1479 /* Signals don't change name during the program's execution, so once
1480 they're cached in the appropriate slot of PL_psig_name, they can
1483 Ideally we'd find some way of making SVs at (C) compile time, or
1484 at least, doing most of the work. */
1485 if (!PL_psig_name[i]) {
1486 PL_psig_name[i] = newSVpvn(s, len);
1487 SvREADONLY_on(PL_psig_name[i]);
1490 SvREFCNT_dec(PL_psig_name[i]);
1491 PL_psig_name[i] = NULL;
1492 PL_psig_ptr[i] = NULL;
1495 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1497 (void)rsignal(i, PL_csighandlerp);
1500 *svp = SvREFCNT_inc_simple_NN(sv);
1502 if (sv && SvOK(sv)) {
1503 s = SvPV_force(sv, len);
1507 if (sv && strEQ(s,"IGNORE")) {
1509 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1510 PL_sig_ignoring[i] = 1;
1511 (void)rsignal(i, PL_csighandlerp);
1513 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1517 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1519 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1520 PL_sig_defaulting[i] = 1;
1521 (void)rsignal(i, PL_csighandlerp);
1523 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1529 * We should warn if HINT_STRICT_REFS, but without
1530 * access to a known hint bit in a known OP, we can't
1531 * tell whether HINT_STRICT_REFS is in force or not.
1533 if (!strchr(s,':') && !strchr(s,'\''))
1534 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1537 (void)rsignal(i, PL_csighandlerp);
1539 *svp = SvREFCNT_inc_simple_NN(sv);
1543 #ifdef HAS_SIGPROCMASK
1547 SvREFCNT_dec(to_dec);
1550 #endif /* !PERL_MICRO */
1553 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1556 PERL_ARGS_ASSERT_MAGIC_SETISA;
1557 PERL_UNUSED_ARG(sv);
1559 /* Skip _isaelem because _isa will handle it shortly */
1560 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1563 return magic_clearisa(NULL, mg);
1566 /* sv of NULL signifies that we're acting as magic_setisa. */
1568 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1573 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1575 /* Bail out if destruction is going on */
1576 if(PL_dirty) return 0;
1579 av_clear(MUTABLE_AV(sv));
1581 /* XXX Once it's possible, we need to
1582 detect that our @ISA is aliased in
1583 other stashes, and act on the stashes
1584 of all of the aliases */
1586 /* The first case occurs via setisa,
1587 the second via setisa_elem, which
1588 calls this same magic */
1590 SvTYPE(mg->mg_obj) == SVt_PVGV
1591 ? (const GV *)mg->mg_obj
1592 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1596 mro_isa_changed_in(stash);
1602 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1605 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1606 PERL_UNUSED_ARG(sv);
1607 PERL_UNUSED_ARG(mg);
1608 PL_amagic_generation++;
1614 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1616 HV * const hv = MUTABLE_HV(LvTARG(sv));
1619 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1620 PERL_UNUSED_ARG(mg);
1623 (void) hv_iterinit(hv);
1624 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1627 while (hv_iternext(hv))
1632 sv_setiv(sv, (IV)i);
1637 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1639 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1640 PERL_UNUSED_ARG(mg);
1642 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1648 =for apidoc magic_methcall
1650 Invoke a magic method (like FETCH).
1652 * sv and mg are the tied thinggy and the tie magic;
1653 * meth is the name of the method to call;
1654 * argc is the number of args (in addition to $self) to pass to the method;
1655 the args themselves are any values following the argc argument.
1657 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1658 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1660 Returns the SV (if any) returned by the method, or NULL on failure.
1667 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1674 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1677 PUSHSTACKi(PERLSI_MAGIC);
1681 PUSHs(SvTIED_obj(sv, mg));
1682 if (flags & G_UNDEF_FILL) {
1684 PUSHs(&PL_sv_undef);
1686 } else if (argc > 0) {
1688 va_start(args, argc);
1691 SV *const sv = va_arg(args, SV *);
1698 if (flags & G_DISCARD) {
1699 call_method(meth, G_SCALAR|G_DISCARD);
1702 if (call_method(meth, G_SCALAR))
1703 ret = *PL_stack_sp--;
1711 /* wrapper for magic_methcall that creates the first arg */
1714 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1720 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1723 if (mg->mg_len >= 0) {
1724 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1726 else if (mg->mg_len == HEf_SVKEY)
1727 arg1 = MUTABLE_SV(mg->mg_ptr);
1729 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1730 arg1 = newSViv((IV)(mg->mg_len));
1734 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1736 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1740 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1745 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1747 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1754 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1756 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1758 if (mg->mg_type == PERL_MAGIC_tiedelem)
1759 mg->mg_flags |= MGf_GSKIP;
1760 magic_methpack(sv,mg,"FETCH");
1765 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1771 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1773 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1774 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1775 * public flags indicate its value based on copying from $val. Doing
1776 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1777 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1778 * wrong if $val happened to be tainted, as sv hasn't got magic
1779 * enabled, even though taint magic is in the chain. In which case,
1780 * fake up a temporary tainted value (this is easier than temporarily
1781 * re-enabling magic on sv). */
1783 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1784 && (tmg->mg_len & 1))
1786 val = sv_mortalcopy(sv);
1792 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1797 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1799 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1801 return magic_methpack(sv,mg,"DELETE");
1806 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1812 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1814 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1816 retval = SvIV(retsv)-1;
1818 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1820 return (U32) retval;
1824 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1828 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1830 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1835 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1840 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1842 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1843 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1850 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1852 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1854 return magic_methpack(sv,mg,"EXISTS");
1858 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1862 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1863 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1865 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1867 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1869 if (HvEITER_get(hv))
1870 /* we are in an iteration so the hash cannot be empty */
1872 /* no xhv_eiter so now use FIRSTKEY */
1873 key = sv_newmortal();
1874 magic_nextpack(MUTABLE_SV(hv), mg, key);
1875 HvEITER_set(hv, NULL); /* need to reset iterator */
1876 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1879 /* there is a SCALAR method that we can call */
1880 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1882 retval = &PL_sv_undef;
1887 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1890 GV * const gv = PL_DBline;
1891 const I32 i = SvTRUE(sv);
1892 SV ** const svp = av_fetch(GvAV(gv),
1893 atoi(MgPV_nolen_const(mg)), FALSE);
1895 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1897 if (svp && SvIOKp(*svp)) {
1898 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1900 /* set or clear breakpoint in the relevant control op */
1902 o->op_flags |= OPf_SPECIAL;
1904 o->op_flags &= ~OPf_SPECIAL;
1911 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1914 AV * const obj = MUTABLE_AV(mg->mg_obj);
1916 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1919 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1927 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1930 AV * const obj = MUTABLE_AV(mg->mg_obj);
1932 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1935 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1937 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1938 "Attempt to set length of freed array");
1944 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1948 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1949 PERL_UNUSED_ARG(sv);
1951 /* during global destruction, mg_obj may already have been freed */
1952 if (PL_in_clean_all)
1955 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1958 /* arylen scalar holds a pointer back to the array, but doesn't own a
1959 reference. Hence the we (the array) are about to go away with it
1960 still pointing at us. Clear its pointer, else it would be pointing
1961 at free memory. See the comment in sv_magic about reference loops,
1962 and why it can't own a reference to us. */
1969 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1972 SV* const lsv = LvTARG(sv);
1974 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1975 PERL_UNUSED_ARG(mg);
1977 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1978 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1979 if (found && found->mg_len >= 0) {
1980 I32 i = found->mg_len;
1982 sv_pos_b2u(lsv, &i);
1983 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1992 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1995 SV* const lsv = LvTARG(sv);
2001 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2002 PERL_UNUSED_ARG(mg);
2004 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2005 found = mg_find(lsv, PERL_MAGIC_regex_global);
2011 #ifdef PERL_OLD_COPY_ON_WRITE
2013 sv_force_normal_flags(lsv, 0);
2015 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2018 else if (!SvOK(sv)) {
2022 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2024 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2027 ulen = sv_len_utf8(lsv);
2037 else if (pos > (SSize_t)len)
2042 sv_pos_u2b(lsv, &p, 0);
2046 found->mg_len = pos;
2047 found->mg_flags &= ~MGf_MINMATCH;
2053 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2056 SV * const lsv = LvTARG(sv);
2057 const char * const tmps = SvPV_const(lsv,len);
2058 STRLEN offs = LvTARGOFF(sv);
2059 STRLEN rem = LvTARGLEN(sv);
2061 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2062 PERL_UNUSED_ARG(mg);
2065 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2068 if (rem > len - offs)
2070 sv_setpvn(sv, tmps + offs, rem);
2077 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2081 const char * const tmps = SvPV_const(sv, len);
2082 SV * const lsv = LvTARG(sv);
2083 STRLEN lvoff = LvTARGOFF(sv);
2084 STRLEN lvlen = LvTARGLEN(sv);
2086 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2087 PERL_UNUSED_ARG(mg);
2090 sv_utf8_upgrade(lsv);
2091 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2092 sv_insert(lsv, lvoff, lvlen, tmps, len);
2093 LvTARGLEN(sv) = sv_len_utf8(sv);
2096 else if (lsv && SvUTF8(lsv)) {
2098 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2099 LvTARGLEN(sv) = len;
2100 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2101 sv_insert(lsv, lvoff, lvlen, utf8, len);
2105 sv_insert(lsv, lvoff, lvlen, tmps, len);
2106 LvTARGLEN(sv) = len;
2113 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2117 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2118 PERL_UNUSED_ARG(sv);
2120 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2125 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2129 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2130 PERL_UNUSED_ARG(sv);
2132 /* update taint status */
2141 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2143 SV * const lsv = LvTARG(sv);
2145 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2146 PERL_UNUSED_ARG(mg);
2149 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2157 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2159 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2160 PERL_UNUSED_ARG(mg);
2161 do_vecset(sv); /* XXX slurp this routine */
2166 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2171 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2173 if (LvTARGLEN(sv)) {
2175 SV * const ahv = LvTARG(sv);
2176 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2181 AV *const av = MUTABLE_AV(LvTARG(sv));
2182 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2183 targ = AvARRAY(av)[LvTARGOFF(sv)];
2185 if (targ && (targ != &PL_sv_undef)) {
2186 /* somebody else defined it for us */
2187 SvREFCNT_dec(LvTARG(sv));
2188 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2190 SvREFCNT_dec(mg->mg_obj);
2192 mg->mg_flags &= ~MGf_REFCOUNTED;
2197 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2202 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2204 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2205 PERL_UNUSED_ARG(mg);
2209 sv_setsv(LvTARG(sv), sv);
2210 SvSETMAGIC(LvTARG(sv));
2216 Perl_vivify_defelem(pTHX_ SV *sv)
2222 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2224 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2227 SV * const ahv = LvTARG(sv);
2228 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2231 if (!value || value == &PL_sv_undef)
2232 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2235 AV *const av = MUTABLE_AV(LvTARG(sv));
2236 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2237 LvTARG(sv) = NULL; /* array can't be extended */
2239 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2240 if (!svp || (value = *svp) == &PL_sv_undef)
2241 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2244 SvREFCNT_inc_simple_void(value);
2245 SvREFCNT_dec(LvTARG(sv));
2248 SvREFCNT_dec(mg->mg_obj);
2250 mg->mg_flags &= ~MGf_REFCOUNTED;
2254 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2256 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2257 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2261 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2263 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2264 PERL_UNUSED_CONTEXT;
2266 if (!isGV_with_GP(sv))
2272 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2274 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2276 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2278 if (uf && uf->uf_set)
2279 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2284 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2286 const char type = mg->mg_type;
2288 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2290 if (type == PERL_MAGIC_qr) {
2291 } else if (type == PERL_MAGIC_bm) {
2295 assert(type == PERL_MAGIC_fm);
2298 return sv_unmagic(sv, type);
2301 #ifdef USE_LOCALE_COLLATE
2303 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2305 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2308 * RenE<eacute> Descartes said "I think not."
2309 * and vanished with a faint plop.
2311 PERL_UNUSED_CONTEXT;
2312 PERL_UNUSED_ARG(sv);
2314 Safefree(mg->mg_ptr);
2320 #endif /* USE_LOCALE_COLLATE */
2322 /* Just clear the UTF-8 cache data. */
2324 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2326 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2327 PERL_UNUSED_CONTEXT;
2328 PERL_UNUSED_ARG(sv);
2329 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2331 mg->mg_len = -1; /* The mg_len holds the len cache. */
2336 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2339 register const char *s;
2341 register const REGEXP * rx;
2342 const char * const remaining = mg->mg_ptr + 1;
2346 PERL_ARGS_ASSERT_MAGIC_SET;
2348 switch (*mg->mg_ptr) {
2349 case '\015': /* $^MATCH */
2350 if (strEQ(remaining, "ATCH"))
2352 case '`': /* ${^PREMATCH} caught below */
2354 paren = RX_BUFF_IDX_PREMATCH;
2356 case '\'': /* ${^POSTMATCH} caught below */
2358 paren = RX_BUFF_IDX_POSTMATCH;
2362 paren = RX_BUFF_IDX_FULLMATCH;
2364 case '1': case '2': case '3': case '4':
2365 case '5': case '6': case '7': case '8': case '9':
2366 paren = atoi(mg->mg_ptr);
2368 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2369 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2372 /* Croak with a READONLY error when a numbered match var is
2373 * set without a previous pattern match. Unless it's C<local $1>
2375 if (!PL_localizing) {
2376 Perl_croak(aTHX_ "%s", PL_no_modify);
2379 case '\001': /* ^A */
2380 sv_setsv(PL_bodytarget, sv);
2382 case '\003': /* ^C */
2383 PL_minus_c = cBOOL(SvIV(sv));
2386 case '\004': /* ^D */
2388 s = SvPV_nolen_const(sv);
2389 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2390 if (DEBUG_x_TEST || DEBUG_B_TEST)
2391 dump_all_perl(!DEBUG_B_TEST);
2393 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2396 case '\005': /* ^E */
2397 if (*(mg->mg_ptr+1) == '\0') {
2399 set_vaxc_errno(SvIV(sv));
2402 SetLastError( SvIV(sv) );
2405 os2_setsyserrno(SvIV(sv));
2407 /* will anyone ever use this? */
2408 SETERRNO(SvIV(sv), 4);
2413 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2414 SvREFCNT_dec(PL_encoding);
2415 if (SvOK(sv) || SvGMAGICAL(sv)) {
2416 PL_encoding = newSVsv(sv);
2423 case '\006': /* ^F */
2424 PL_maxsysfd = SvIV(sv);
2426 case '\010': /* ^H */
2427 PL_hints = SvIV(sv);
2429 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2430 Safefree(PL_inplace);
2431 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2433 case '\017': /* ^O */
2434 if (*(mg->mg_ptr+1) == '\0') {
2435 Safefree(PL_osname);
2438 TAINT_PROPER("assigning to $^O");
2439 PL_osname = savesvpv(sv);
2442 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2444 const char *const start = SvPV(sv, len);
2445 const char *out = (const char*)memchr(start, '\0', len);
2449 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2450 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2452 /* Opening for input is more common than opening for output, so
2453 ensure that hints for input are sooner on linked list. */
2454 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2456 : newSVpvs_flags("", SvUTF8(sv));
2457 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2460 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2462 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2466 case '\020': /* ^P */
2467 if (*remaining == '\0') { /* ^P */
2468 PL_perldb = SvIV(sv);
2469 if (PL_perldb && !PL_DBsingle)
2472 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2474 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2477 case '\024': /* ^T */
2479 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2481 PL_basetime = (Time_t)SvIV(sv);
2484 case '\025': /* ^UTF8CACHE */
2485 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2486 PL_utf8cache = (signed char) sv_2iv(sv);
2489 case '\027': /* ^W & $^WARNING_BITS */
2490 if (*(mg->mg_ptr+1) == '\0') {
2491 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2493 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2494 | (i ? G_WARN_ON : G_WARN_OFF) ;
2497 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2498 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2499 if (!SvPOK(sv) && PL_localizing) {
2500 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2501 PL_compiling.cop_warnings = pWARN_NONE;
2506 int accumulate = 0 ;
2507 int any_fatals = 0 ;
2508 const char * const ptr = SvPV_const(sv, len) ;
2509 for (i = 0 ; i < len ; ++i) {
2510 accumulate |= ptr[i] ;
2511 any_fatals |= (ptr[i] & 0xAA) ;
2514 if (!specialWARN(PL_compiling.cop_warnings))
2515 PerlMemShared_free(PL_compiling.cop_warnings);
2516 PL_compiling.cop_warnings = pWARN_NONE;
2518 /* Yuck. I can't see how to abstract this: */
2519 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2520 WARN_ALL) && !any_fatals) {
2521 if (!specialWARN(PL_compiling.cop_warnings))
2522 PerlMemShared_free(PL_compiling.cop_warnings);
2523 PL_compiling.cop_warnings = pWARN_ALL;
2524 PL_dowarn |= G_WARN_ONCE ;
2528 const char *const p = SvPV_const(sv, len);
2530 PL_compiling.cop_warnings
2531 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2534 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2535 PL_dowarn |= G_WARN_ONCE ;
2543 if (PL_localizing) {
2544 if (PL_localizing == 1)
2545 SAVESPTR(PL_last_in_gv);
2547 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2548 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2551 if (isGV_with_GP(PL_defoutgv)) {
2552 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2553 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2554 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2558 if (isGV_with_GP(PL_defoutgv)) {
2559 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2560 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2561 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2565 if (isGV_with_GP(PL_defoutgv))
2566 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2569 if (isGV_with_GP(PL_defoutgv)) {
2570 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2571 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2572 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2576 if (isGV_with_GP(PL_defoutgv))
2577 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2581 IO * const io = GvIO(PL_defoutgv);
2584 if ((SvIV(sv)) == 0)
2585 IoFLAGS(io) &= ~IOf_FLUSH;
2587 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2588 PerlIO *ofp = IoOFP(io);
2590 (void)PerlIO_flush(ofp);
2591 IoFLAGS(io) |= IOf_FLUSH;
2597 SvREFCNT_dec(PL_rs);
2598 PL_rs = newSVsv(sv);
2601 SvREFCNT_dec(PL_ors_sv);
2602 if (SvOK(sv) || SvGMAGICAL(sv)) {
2603 PL_ors_sv = newSVsv(sv);
2610 CopARYBASE_set(&PL_compiling, SvIV(sv));
2613 #ifdef COMPLEX_STATUS
2614 if (PL_localizing == 2) {
2615 SvUPGRADE(sv, SVt_PVLV);
2616 PL_statusvalue = LvTARGOFF(sv);
2617 PL_statusvalue_vms = LvTARGLEN(sv);
2621 #ifdef VMSISH_STATUS
2623 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2626 STATUS_UNIX_EXIT_SET(SvIV(sv));
2631 # define PERL_VMS_BANG vaxc$errno
2633 # define PERL_VMS_BANG 0
2635 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2636 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2641 if (PL_delaymagic) {
2642 PL_delaymagic |= DM_RUID;
2643 break; /* don't do magic till later */
2646 (void)setruid((Uid_t)PL_uid);
2649 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2651 #ifdef HAS_SETRESUID
2652 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2654 if (PL_uid == PL_euid) { /* special case $< = $> */
2656 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2657 if (PL_uid != 0 && PerlProc_getuid() == 0)
2658 (void)PerlProc_setuid(0);
2660 (void)PerlProc_setuid(PL_uid);
2662 PL_uid = PerlProc_getuid();
2663 Perl_croak(aTHX_ "setruid() not implemented");
2668 PL_uid = PerlProc_getuid();
2672 if (PL_delaymagic) {
2673 PL_delaymagic |= DM_EUID;
2674 break; /* don't do magic till later */
2677 (void)seteuid((Uid_t)PL_euid);
2680 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2682 #ifdef HAS_SETRESUID
2683 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2685 if (PL_euid == PL_uid) /* special case $> = $< */
2686 PerlProc_setuid(PL_euid);
2688 PL_euid = PerlProc_geteuid();
2689 Perl_croak(aTHX_ "seteuid() not implemented");
2694 PL_euid = PerlProc_geteuid();
2698 if (PL_delaymagic) {
2699 PL_delaymagic |= DM_RGID;
2700 break; /* don't do magic till later */
2703 (void)setrgid((Gid_t)PL_gid);
2706 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2708 #ifdef HAS_SETRESGID
2709 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2711 if (PL_gid == PL_egid) /* special case $( = $) */
2712 (void)PerlProc_setgid(PL_gid);
2714 PL_gid = PerlProc_getgid();
2715 Perl_croak(aTHX_ "setrgid() not implemented");
2720 PL_gid = PerlProc_getgid();
2723 #ifdef HAS_SETGROUPS
2725 const char *p = SvPV_const(sv, len);
2726 Groups_t *gary = NULL;
2727 #ifdef _SC_NGROUPS_MAX
2728 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2733 int maxgrp = NGROUPS;
2739 for (i = 0; i < maxgrp; ++i) {
2740 while (*p && !isSPACE(*p))
2747 Newx(gary, i + 1, Groups_t);
2749 Renew(gary, i + 1, Groups_t);
2753 (void)setgroups(i, gary);
2756 #else /* HAS_SETGROUPS */
2758 #endif /* HAS_SETGROUPS */
2759 if (PL_delaymagic) {
2760 PL_delaymagic |= DM_EGID;
2761 break; /* don't do magic till later */
2764 (void)setegid((Gid_t)PL_egid);
2767 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2769 #ifdef HAS_SETRESGID
2770 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2772 if (PL_egid == PL_gid) /* special case $) = $( */
2773 (void)PerlProc_setgid(PL_egid);
2775 PL_egid = PerlProc_getegid();
2776 Perl_croak(aTHX_ "setegid() not implemented");
2781 PL_egid = PerlProc_getegid();
2784 PL_chopset = SvPV_force(sv,len);
2787 LOCK_DOLLARZERO_MUTEX;
2788 #ifdef HAS_SETPROCTITLE
2789 /* The BSDs don't show the argv[] in ps(1) output, they
2790 * show a string from the process struct and provide
2791 * the setproctitle() routine to manipulate that. */
2792 if (PL_origalen != 1) {
2793 s = SvPV_const(sv, len);
2794 # if __FreeBSD_version > 410001
2795 /* The leading "-" removes the "perl: " prefix,
2796 * but not the "(perl) suffix from the ps(1)
2797 * output, because that's what ps(1) shows if the
2798 * argv[] is modified. */
2799 setproctitle("-%s", s);
2800 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2801 /* This doesn't really work if you assume that
2802 * $0 = 'foobar'; will wipe out 'perl' from the $0
2803 * because in ps(1) output the result will be like
2804 * sprintf("perl: %s (perl)", s)
2805 * I guess this is a security feature:
2806 * one (a user process) cannot get rid of the original name.
2808 setproctitle("%s", s);
2811 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2812 if (PL_origalen != 1) {
2814 s = SvPV_const(sv, len);
2815 un.pst_command = (char *)s;
2816 pstat(PSTAT_SETCMD, un, len, 0, 0);
2819 if (PL_origalen > 1) {
2820 /* PL_origalen is set in perl_parse(). */
2821 s = SvPV_force(sv,len);
2822 if (len >= (STRLEN)PL_origalen-1) {
2823 /* Longer than original, will be truncated. We assume that
2824 * PL_origalen bytes are available. */
2825 Copy(s, PL_origargv[0], PL_origalen-1, char);
2828 /* Shorter than original, will be padded. */
2830 /* Special case for Mac OS X: see [perl #38868] */
2833 /* Is the space counterintuitive? Yes.
2834 * (You were expecting \0?)
2835 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2837 const int pad = ' ';
2839 Copy(s, PL_origargv[0], len, char);
2840 PL_origargv[0][len] = 0;
2841 memset(PL_origargv[0] + len + 1,
2842 pad, PL_origalen - len - 1);
2844 PL_origargv[0][PL_origalen-1] = 0;
2845 for (i = 1; i < PL_origargc; i++)
2847 #ifdef HAS_PRCTL_SET_NAME
2848 /* Set the legacy process name in addition to the POSIX name on Linux */
2849 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2850 /* diag_listed_as: SKIPME */
2851 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2856 UNLOCK_DOLLARZERO_MUTEX;
2863 Perl_whichsig(pTHX_ const char *sig)
2865 register char* const* sigv;
2867 PERL_ARGS_ASSERT_WHICHSIG;
2868 PERL_UNUSED_CONTEXT;
2870 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2871 if (strEQ(sig,*sigv))
2872 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2874 if (strEQ(sig,"CHLD"))
2878 if (strEQ(sig,"CLD"))
2885 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2886 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2888 Perl_sighandler(int sig)
2891 #ifdef PERL_GET_SIG_CONTEXT
2892 dTHXa(PERL_GET_SIG_CONTEXT);
2899 SV * const tSv = PL_Sv;
2903 XPV * const tXpv = PL_Xpv;
2905 if (PL_savestack_ix + 15 <= PL_savestack_max)
2907 if (PL_markstack_ptr < PL_markstack_max - 2)
2909 if (PL_scopestack_ix < PL_scopestack_max - 3)
2912 if (!PL_psig_ptr[sig]) {
2913 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2918 /* Max number of items pushed there is 3*n or 4. We cannot fix
2919 infinity, so we fix 4 (in fact 5): */
2921 PL_savestack_ix += 5; /* Protect save in progress. */
2922 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2925 PL_markstack_ptr++; /* Protect mark. */
2927 PL_scopestack_ix += 1;
2928 /* sv_2cv is too complicated, try a simpler variant first: */
2929 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2930 || SvTYPE(cv) != SVt_PVCV) {
2932 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2935 if (!cv || !CvROOT(cv)) {
2936 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2937 PL_sig_name[sig], (gv ? GvENAME(gv)
2944 if(PL_psig_name[sig]) {
2945 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2947 #if !defined(PERL_IMPLICIT_CONTEXT)
2951 sv = sv_newmortal();
2952 sv_setpv(sv,PL_sig_name[sig]);
2955 PUSHSTACKi(PERLSI_SIGNAL);
2958 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2960 struct sigaction oact;
2962 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2965 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2966 /* The siginfo fields signo, code, errno, pid, uid,
2967 * addr, status, and band are defined by POSIX/SUSv3. */
2968 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2969 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2970 #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. */
2971 hv_stores(sih, "errno", newSViv(sip->si_errno));
2972 hv_stores(sih, "status", newSViv(sip->si_status));
2973 hv_stores(sih, "uid", newSViv(sip->si_uid));
2974 hv_stores(sih, "pid", newSViv(sip->si_pid));
2975 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2976 hv_stores(sih, "band", newSViv(sip->si_band));
2980 mPUSHp((char *)sip, sizeof(*sip));
2988 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2991 if (SvTRUE(ERRSV)) {
2993 #ifdef HAS_SIGPROCMASK
2994 /* Handler "died", for example to get out of a restart-able read().
2995 * Before we re-do that on its behalf re-enable the signal which was
2996 * blocked by the system when we entered.
3000 sigaddset(&set,sig);
3001 sigprocmask(SIG_UNBLOCK, &set, NULL);
3003 /* Not clear if this will work */
3004 (void)rsignal(sig, SIG_IGN);
3005 (void)rsignal(sig, PL_csighandlerp);
3007 #endif /* !PERL_MICRO */
3012 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3016 PL_scopestack_ix -= 1;
3019 PL_op = myop; /* Apparently not needed... */
3021 PL_Sv = tSv; /* Restore global temporaries. */
3028 S_restore_magic(pTHX_ const void *p)
3031 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3032 SV* const sv = mgs->mgs_sv;
3037 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3039 #ifdef PERL_OLD_COPY_ON_WRITE
3040 /* While magic was saved (and off) sv_setsv may well have seen
3041 this SV as a prime candidate for COW. */
3043 sv_force_normal_flags(sv, 0);
3046 if (mgs->mgs_readonly)
3048 if (mgs->mgs_magical)
3049 SvFLAGS(sv) |= mgs->mgs_magical;
3052 if (SvGMAGICAL(sv)) {
3053 /* downgrade public flags to private,
3054 and discard any other private flags */
3056 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3058 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3059 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3064 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3066 /* If we're still on top of the stack, pop us off. (That condition
3067 * will be satisfied if restore_magic was called explicitly, but *not*
3068 * if it's being called via leave_scope.)
3069 * The reason for doing this is that otherwise, things like sv_2cv()
3070 * may leave alloc gunk on the savestack, and some code
3071 * (e.g. sighandler) doesn't expect that...
3073 if (PL_savestack_ix == mgs->mgs_ss_ix)
3075 UV popval = SSPOPUV;
3076 assert(popval == SAVEt_DESTRUCTOR_X);
3077 PL_savestack_ix -= 2;
3079 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3080 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3086 S_unwind_handler_stack(pTHX_ const void *p)
3089 const U32 flags = *(const U32*)p;
3091 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3094 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3095 #if !defined(PERL_IMPLICIT_CONTEXT)
3097 SvREFCNT_dec(PL_sig_sv);
3102 =for apidoc magic_sethint
3104 Triggered by a store to %^H, records the key/value pair to
3105 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3106 anything that would need a deep copy. Maybe we should warn if we find a
3112 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3115 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3116 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3118 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3120 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3121 an alternative leaf in there, with PL_compiling.cop_hints being used if
3122 it's NULL. If needed for threads, the alternative could lock a mutex,
3123 or take other more complex action. */
3125 /* Something changed in %^H, so it will need to be restored on scope exit.
3126 Doing this here saves a lot of doing it manually in perl code (and
3127 forgetting to do it, and consequent subtle errors. */
3128 PL_hints |= HINT_LOCALIZE_HH;
3129 PL_compiling.cop_hints_hash
3130 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3135 =for apidoc magic_clearhint
3137 Triggered by a delete from %^H, records the key to
3138 C<PL_compiling.cop_hints_hash>.
3143 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3147 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3148 PERL_UNUSED_ARG(sv);
3150 assert(mg->mg_len == HEf_SVKEY);
3152 PERL_UNUSED_ARG(sv);
3154 PL_hints |= HINT_LOCALIZE_HH;
3155 PL_compiling.cop_hints_hash
3156 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3157 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3162 =for apidoc magic_clearhints
3164 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3169 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3171 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3172 PERL_UNUSED_ARG(sv);
3173 PERL_UNUSED_ARG(mg);
3174 if (PL_compiling.cop_hints_hash) {
3175 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3176 PL_compiling.cop_hints_hash = NULL;
3183 * c-indentation-style: bsd
3185 * indent-tabs-mode: t
3188 * ex: set ts=8 sts=4 sw=4 noet: