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 && 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, arg1, arg2 are the number of args (in addition to $self) to pass to
1655 the method, and the args themselves
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;
1659 ignore arg1 and arg2.
1661 Returns the SV (if any) returned by the method, or NULL on failure.
1668 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1675 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1678 PUSHSTACKi(PERLSI_MAGIC);
1682 PUSHs(SvTIED_obj(sv, mg));
1683 if (flags & G_UNDEF_FILL) {
1685 PUSHs(&PL_sv_undef);
1687 } else if (argc > 0) {
1689 va_start(args, argc);
1692 SV *const sv = va_arg(args, SV *);
1699 if (flags & G_DISCARD) {
1700 call_method(meth, G_SCALAR|G_DISCARD);
1703 if (call_method(meth, G_SCALAR))
1704 ret = *PL_stack_sp--;
1712 /* wrapper for magic_methcall that creates the first arg */
1715 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1721 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1724 if (mg->mg_len >= 0) {
1725 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1727 else if (mg->mg_len == HEf_SVKEY)
1728 arg1 = MUTABLE_SV(mg->mg_ptr);
1730 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1731 arg1 = newSViv((IV)(mg->mg_len));
1735 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1737 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1741 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1746 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1748 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1755 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1757 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1759 if (mg->mg_type == PERL_MAGIC_tiedelem)
1760 mg->mg_flags |= MGf_GSKIP;
1761 magic_methpack(sv,mg,"FETCH");
1766 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1772 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1774 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1775 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1776 * public flags indicate its value based on copying from $val. Doing
1777 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1778 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1779 * wrong if $val happened to be tainted, as sv hasn't got magic
1780 * enabled, even though taint magic is in the chain. In which case,
1781 * fake up a temporary tainted value (this is easier than temporarily
1782 * re-enabling magic on sv). */
1784 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1785 && (tmg->mg_len & 1))
1787 val = sv_mortalcopy(sv);
1793 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1798 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1800 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1802 return magic_methpack(sv,mg,"DELETE");
1807 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1813 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1815 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1817 retval = SvIV(retsv)-1;
1819 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1821 return (U32) retval;
1825 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1829 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1831 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1836 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1841 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1843 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1844 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1851 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1853 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1855 return magic_methpack(sv,mg,"EXISTS");
1859 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1863 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1864 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1866 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1868 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1870 if (HvEITER_get(hv))
1871 /* we are in an iteration so the hash cannot be empty */
1873 /* no xhv_eiter so now use FIRSTKEY */
1874 key = sv_newmortal();
1875 magic_nextpack(MUTABLE_SV(hv), mg, key);
1876 HvEITER_set(hv, NULL); /* need to reset iterator */
1877 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1880 /* there is a SCALAR method that we can call */
1881 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1883 retval = &PL_sv_undef;
1888 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1891 GV * const gv = PL_DBline;
1892 const I32 i = SvTRUE(sv);
1893 SV ** const svp = av_fetch(GvAV(gv),
1894 atoi(MgPV_nolen_const(mg)), FALSE);
1896 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1898 if (svp && SvIOKp(*svp)) {
1899 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1901 /* set or clear breakpoint in the relevant control op */
1903 o->op_flags |= OPf_SPECIAL;
1905 o->op_flags &= ~OPf_SPECIAL;
1912 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1915 AV * const obj = MUTABLE_AV(mg->mg_obj);
1917 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1920 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1928 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1931 AV * const obj = MUTABLE_AV(mg->mg_obj);
1933 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1936 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1938 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1939 "Attempt to set length of freed array");
1945 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1949 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1950 PERL_UNUSED_ARG(sv);
1952 /* during global destruction, mg_obj may already have been freed */
1953 if (PL_in_clean_all)
1956 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1959 /* arylen scalar holds a pointer back to the array, but doesn't own a
1960 reference. Hence the we (the array) are about to go away with it
1961 still pointing at us. Clear its pointer, else it would be pointing
1962 at free memory. See the comment in sv_magic about reference loops,
1963 and why it can't own a reference to us. */
1970 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1973 SV* const lsv = LvTARG(sv);
1975 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1976 PERL_UNUSED_ARG(mg);
1978 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1979 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1980 if (found && found->mg_len >= 0) {
1981 I32 i = found->mg_len;
1983 sv_pos_b2u(lsv, &i);
1984 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1993 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1996 SV* const lsv = LvTARG(sv);
2002 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2003 PERL_UNUSED_ARG(mg);
2005 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2006 found = mg_find(lsv, PERL_MAGIC_regex_global);
2012 #ifdef PERL_OLD_COPY_ON_WRITE
2014 sv_force_normal_flags(lsv, 0);
2016 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2019 else if (!SvOK(sv)) {
2023 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2025 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2028 ulen = sv_len_utf8(lsv);
2038 else if (pos > (SSize_t)len)
2043 sv_pos_u2b(lsv, &p, 0);
2047 found->mg_len = pos;
2048 found->mg_flags &= ~MGf_MINMATCH;
2054 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2057 SV * const lsv = LvTARG(sv);
2058 const char * const tmps = SvPV_const(lsv,len);
2059 STRLEN offs = LvTARGOFF(sv);
2060 STRLEN rem = LvTARGLEN(sv);
2062 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2063 PERL_UNUSED_ARG(mg);
2066 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2069 if (rem > len - offs)
2071 sv_setpvn(sv, tmps + offs, rem);
2078 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2082 const char * const tmps = SvPV_const(sv, len);
2083 SV * const lsv = LvTARG(sv);
2084 STRLEN lvoff = LvTARGOFF(sv);
2085 STRLEN lvlen = LvTARGLEN(sv);
2087 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2088 PERL_UNUSED_ARG(mg);
2091 sv_utf8_upgrade(lsv);
2092 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2093 sv_insert(lsv, lvoff, lvlen, tmps, len);
2094 LvTARGLEN(sv) = sv_len_utf8(sv);
2097 else if (lsv && SvUTF8(lsv)) {
2099 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2100 LvTARGLEN(sv) = len;
2101 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2102 sv_insert(lsv, lvoff, lvlen, utf8, len);
2106 sv_insert(lsv, lvoff, lvlen, tmps, len);
2107 LvTARGLEN(sv) = len;
2114 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2118 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2119 PERL_UNUSED_ARG(sv);
2121 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2126 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2130 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2131 PERL_UNUSED_ARG(sv);
2133 /* update taint status */
2142 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2144 SV * const lsv = LvTARG(sv);
2146 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2147 PERL_UNUSED_ARG(mg);
2150 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2158 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2160 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2161 PERL_UNUSED_ARG(mg);
2162 do_vecset(sv); /* XXX slurp this routine */
2167 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2172 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2174 if (LvTARGLEN(sv)) {
2176 SV * const ahv = LvTARG(sv);
2177 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2182 AV *const av = MUTABLE_AV(LvTARG(sv));
2183 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2184 targ = AvARRAY(av)[LvTARGOFF(sv)];
2186 if (targ && (targ != &PL_sv_undef)) {
2187 /* somebody else defined it for us */
2188 SvREFCNT_dec(LvTARG(sv));
2189 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2191 SvREFCNT_dec(mg->mg_obj);
2193 mg->mg_flags &= ~MGf_REFCOUNTED;
2198 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2203 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2205 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2206 PERL_UNUSED_ARG(mg);
2210 sv_setsv(LvTARG(sv), sv);
2211 SvSETMAGIC(LvTARG(sv));
2217 Perl_vivify_defelem(pTHX_ SV *sv)
2223 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2225 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2228 SV * const ahv = LvTARG(sv);
2229 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2232 if (!value || value == &PL_sv_undef)
2233 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2236 AV *const av = MUTABLE_AV(LvTARG(sv));
2237 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2238 LvTARG(sv) = NULL; /* array can't be extended */
2240 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2241 if (!svp || (value = *svp) == &PL_sv_undef)
2242 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2245 SvREFCNT_inc_simple_void(value);
2246 SvREFCNT_dec(LvTARG(sv));
2249 SvREFCNT_dec(mg->mg_obj);
2251 mg->mg_flags &= ~MGf_REFCOUNTED;
2255 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2257 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2258 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2262 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2264 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2265 PERL_UNUSED_CONTEXT;
2267 if (!isGV_with_GP(sv))
2273 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2275 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2277 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2279 if (uf && uf->uf_set)
2280 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2285 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2287 const char type = mg->mg_type;
2289 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2291 if (type == PERL_MAGIC_qr) {
2292 } else if (type == PERL_MAGIC_bm) {
2296 assert(type == PERL_MAGIC_fm);
2299 return sv_unmagic(sv, type);
2302 #ifdef USE_LOCALE_COLLATE
2304 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2306 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2309 * RenE<eacute> Descartes said "I think not."
2310 * and vanished with a faint plop.
2312 PERL_UNUSED_CONTEXT;
2313 PERL_UNUSED_ARG(sv);
2315 Safefree(mg->mg_ptr);
2321 #endif /* USE_LOCALE_COLLATE */
2323 /* Just clear the UTF-8 cache data. */
2325 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2327 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2328 PERL_UNUSED_CONTEXT;
2329 PERL_UNUSED_ARG(sv);
2330 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2332 mg->mg_len = -1; /* The mg_len holds the len cache. */
2337 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2340 register const char *s;
2342 register const REGEXP * rx;
2343 const char * const remaining = mg->mg_ptr + 1;
2347 PERL_ARGS_ASSERT_MAGIC_SET;
2349 switch (*mg->mg_ptr) {
2350 case '\015': /* $^MATCH */
2351 if (strEQ(remaining, "ATCH"))
2353 case '`': /* ${^PREMATCH} caught below */
2355 paren = RX_BUFF_IDX_PREMATCH;
2357 case '\'': /* ${^POSTMATCH} caught below */
2359 paren = RX_BUFF_IDX_POSTMATCH;
2363 paren = RX_BUFF_IDX_FULLMATCH;
2365 case '1': case '2': case '3': case '4':
2366 case '5': case '6': case '7': case '8': case '9':
2367 paren = atoi(mg->mg_ptr);
2369 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2370 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2373 /* Croak with a READONLY error when a numbered match var is
2374 * set without a previous pattern match. Unless it's C<local $1>
2376 if (!PL_localizing) {
2377 Perl_croak(aTHX_ "%s", PL_no_modify);
2380 case '\001': /* ^A */
2381 sv_setsv(PL_bodytarget, sv);
2383 case '\003': /* ^C */
2384 PL_minus_c = cBOOL(SvIV(sv));
2387 case '\004': /* ^D */
2389 s = SvPV_nolen_const(sv);
2390 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2391 if (DEBUG_x_TEST || DEBUG_B_TEST)
2392 dump_all_perl(!DEBUG_B_TEST);
2394 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2397 case '\005': /* ^E */
2398 if (*(mg->mg_ptr+1) == '\0') {
2400 set_vaxc_errno(SvIV(sv));
2403 SetLastError( SvIV(sv) );
2406 os2_setsyserrno(SvIV(sv));
2408 /* will anyone ever use this? */
2409 SETERRNO(SvIV(sv), 4);
2414 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2415 SvREFCNT_dec(PL_encoding);
2416 if (SvOK(sv) || SvGMAGICAL(sv)) {
2417 PL_encoding = newSVsv(sv);
2424 case '\006': /* ^F */
2425 PL_maxsysfd = SvIV(sv);
2427 case '\010': /* ^H */
2428 PL_hints = SvIV(sv);
2430 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2431 Safefree(PL_inplace);
2432 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2434 case '\017': /* ^O */
2435 if (*(mg->mg_ptr+1) == '\0') {
2436 Safefree(PL_osname);
2439 TAINT_PROPER("assigning to $^O");
2440 PL_osname = savesvpv(sv);
2443 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2445 const char *const start = SvPV(sv, len);
2446 const char *out = (const char*)memchr(start, '\0', len);
2450 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2451 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2453 /* Opening for input is more common than opening for output, so
2454 ensure that hints for input are sooner on linked list. */
2455 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2457 : newSVpvs_flags("", SvUTF8(sv));
2458 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2461 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2463 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2467 case '\020': /* ^P */
2468 if (*remaining == '\0') { /* ^P */
2469 PL_perldb = SvIV(sv);
2470 if (PL_perldb && !PL_DBsingle)
2473 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2475 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2478 case '\024': /* ^T */
2480 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2482 PL_basetime = (Time_t)SvIV(sv);
2485 case '\025': /* ^UTF8CACHE */
2486 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2487 PL_utf8cache = (signed char) sv_2iv(sv);
2490 case '\027': /* ^W & $^WARNING_BITS */
2491 if (*(mg->mg_ptr+1) == '\0') {
2492 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2494 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2495 | (i ? G_WARN_ON : G_WARN_OFF) ;
2498 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2499 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2500 if (!SvPOK(sv) && PL_localizing) {
2501 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2502 PL_compiling.cop_warnings = pWARN_NONE;
2507 int accumulate = 0 ;
2508 int any_fatals = 0 ;
2509 const char * const ptr = SvPV_const(sv, len) ;
2510 for (i = 0 ; i < len ; ++i) {
2511 accumulate |= ptr[i] ;
2512 any_fatals |= (ptr[i] & 0xAA) ;
2515 if (!specialWARN(PL_compiling.cop_warnings))
2516 PerlMemShared_free(PL_compiling.cop_warnings);
2517 PL_compiling.cop_warnings = pWARN_NONE;
2519 /* Yuck. I can't see how to abstract this: */
2520 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2521 WARN_ALL) && !any_fatals) {
2522 if (!specialWARN(PL_compiling.cop_warnings))
2523 PerlMemShared_free(PL_compiling.cop_warnings);
2524 PL_compiling.cop_warnings = pWARN_ALL;
2525 PL_dowarn |= G_WARN_ONCE ;
2529 const char *const p = SvPV_const(sv, len);
2531 PL_compiling.cop_warnings
2532 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2535 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2536 PL_dowarn |= G_WARN_ONCE ;
2544 if (PL_localizing) {
2545 if (PL_localizing == 1)
2546 SAVESPTR(PL_last_in_gv);
2548 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2549 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2552 if (isGV_with_GP(PL_defoutgv)) {
2553 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2554 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2555 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2559 if (isGV_with_GP(PL_defoutgv)) {
2560 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2561 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2562 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2566 if (isGV_with_GP(PL_defoutgv))
2567 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2570 if (isGV_with_GP(PL_defoutgv)) {
2571 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2572 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2573 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2577 if (isGV_with_GP(PL_defoutgv))
2578 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2582 IO * const io = GvIO(PL_defoutgv);
2585 if ((SvIV(sv)) == 0)
2586 IoFLAGS(io) &= ~IOf_FLUSH;
2588 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2589 PerlIO *ofp = IoOFP(io);
2591 (void)PerlIO_flush(ofp);
2592 IoFLAGS(io) |= IOf_FLUSH;
2598 SvREFCNT_dec(PL_rs);
2599 PL_rs = newSVsv(sv);
2602 SvREFCNT_dec(PL_ors_sv);
2603 if (SvOK(sv) || SvGMAGICAL(sv)) {
2604 PL_ors_sv = newSVsv(sv);
2611 CopARYBASE_set(&PL_compiling, SvIV(sv));
2614 #ifdef COMPLEX_STATUS
2615 if (PL_localizing == 2) {
2616 SvUPGRADE(sv, SVt_PVLV);
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();
2673 if (PL_delaymagic) {
2674 PL_delaymagic |= DM_EUID;
2675 break; /* don't do magic till later */
2678 (void)seteuid((Uid_t)PL_euid);
2681 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2683 #ifdef HAS_SETRESUID
2684 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2686 if (PL_euid == PL_uid) /* special case $> = $< */
2687 PerlProc_setuid(PL_euid);
2689 PL_euid = PerlProc_geteuid();
2690 Perl_croak(aTHX_ "seteuid() not implemented");
2695 PL_euid = PerlProc_geteuid();
2699 if (PL_delaymagic) {
2700 PL_delaymagic |= DM_RGID;
2701 break; /* don't do magic till later */
2704 (void)setrgid((Gid_t)PL_gid);
2707 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2709 #ifdef HAS_SETRESGID
2710 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2712 if (PL_gid == PL_egid) /* special case $( = $) */
2713 (void)PerlProc_setgid(PL_gid);
2715 PL_gid = PerlProc_getgid();
2716 Perl_croak(aTHX_ "setrgid() not implemented");
2721 PL_gid = PerlProc_getgid();
2724 #ifdef HAS_SETGROUPS
2726 const char *p = SvPV_const(sv, len);
2727 Groups_t *gary = NULL;
2728 #ifdef _SC_NGROUPS_MAX
2729 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2734 int maxgrp = NGROUPS;
2740 for (i = 0; i < maxgrp; ++i) {
2741 while (*p && !isSPACE(*p))
2748 Newx(gary, i + 1, Groups_t);
2750 Renew(gary, i + 1, Groups_t);
2754 (void)setgroups(i, gary);
2757 #else /* HAS_SETGROUPS */
2759 #endif /* HAS_SETGROUPS */
2760 if (PL_delaymagic) {
2761 PL_delaymagic |= DM_EGID;
2762 break; /* don't do magic till later */
2765 (void)setegid((Gid_t)PL_egid);
2768 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2770 #ifdef HAS_SETRESGID
2771 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2773 if (PL_egid == PL_gid) /* special case $) = $( */
2774 (void)PerlProc_setgid(PL_egid);
2776 PL_egid = PerlProc_getegid();
2777 Perl_croak(aTHX_ "setegid() not implemented");
2782 PL_egid = PerlProc_getegid();
2785 PL_chopset = SvPV_force(sv,len);
2788 LOCK_DOLLARZERO_MUTEX;
2789 #ifdef HAS_SETPROCTITLE
2790 /* The BSDs don't show the argv[] in ps(1) output, they
2791 * show a string from the process struct and provide
2792 * the setproctitle() routine to manipulate that. */
2793 if (PL_origalen != 1) {
2794 s = SvPV_const(sv, len);
2795 # if __FreeBSD_version > 410001
2796 /* The leading "-" removes the "perl: " prefix,
2797 * but not the "(perl) suffix from the ps(1)
2798 * output, because that's what ps(1) shows if the
2799 * argv[] is modified. */
2800 setproctitle("-%s", s);
2801 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2802 /* This doesn't really work if you assume that
2803 * $0 = 'foobar'; will wipe out 'perl' from the $0
2804 * because in ps(1) output the result will be like
2805 * sprintf("perl: %s (perl)", s)
2806 * I guess this is a security feature:
2807 * one (a user process) cannot get rid of the original name.
2809 setproctitle("%s", s);
2812 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2813 if (PL_origalen != 1) {
2815 s = SvPV_const(sv, len);
2816 un.pst_command = (char *)s;
2817 pstat(PSTAT_SETCMD, un, len, 0, 0);
2820 if (PL_origalen > 1) {
2821 /* PL_origalen is set in perl_parse(). */
2822 s = SvPV_force(sv,len);
2823 if (len >= (STRLEN)PL_origalen-1) {
2824 /* Longer than original, will be truncated. We assume that
2825 * PL_origalen bytes are available. */
2826 Copy(s, PL_origargv[0], PL_origalen-1, char);
2829 /* Shorter than original, will be padded. */
2831 /* Special case for Mac OS X: see [perl #38868] */
2834 /* Is the space counterintuitive? Yes.
2835 * (You were expecting \0?)
2836 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2838 const int pad = ' ';
2840 Copy(s, PL_origargv[0], len, char);
2841 PL_origargv[0][len] = 0;
2842 memset(PL_origargv[0] + len + 1,
2843 pad, PL_origalen - len - 1);
2845 PL_origargv[0][PL_origalen-1] = 0;
2846 for (i = 1; i < PL_origargc; i++)
2848 #ifdef HAS_PRCTL_SET_NAME
2849 /* Set the legacy process name in addition to the POSIX name on Linux */
2850 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2851 /* diag_listed_as: SKIPME */
2852 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2857 UNLOCK_DOLLARZERO_MUTEX;
2864 Perl_whichsig(pTHX_ const char *sig)
2866 register char* const* sigv;
2868 PERL_ARGS_ASSERT_WHICHSIG;
2869 PERL_UNUSED_CONTEXT;
2871 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2872 if (strEQ(sig,*sigv))
2873 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2875 if (strEQ(sig,"CHLD"))
2879 if (strEQ(sig,"CLD"))
2886 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2887 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2889 Perl_sighandler(int sig)
2892 #ifdef PERL_GET_SIG_CONTEXT
2893 dTHXa(PERL_GET_SIG_CONTEXT);
2900 SV * const tSv = PL_Sv;
2904 XPV * const tXpv = PL_Xpv;
2906 if (PL_savestack_ix + 15 <= PL_savestack_max)
2908 if (PL_markstack_ptr < PL_markstack_max - 2)
2910 if (PL_scopestack_ix < PL_scopestack_max - 3)
2913 if (!PL_psig_ptr[sig]) {
2914 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2919 /* Max number of items pushed there is 3*n or 4. We cannot fix
2920 infinity, so we fix 4 (in fact 5): */
2922 PL_savestack_ix += 5; /* Protect save in progress. */
2923 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2926 PL_markstack_ptr++; /* Protect mark. */
2928 PL_scopestack_ix += 1;
2929 /* sv_2cv is too complicated, try a simpler variant first: */
2930 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2931 || SvTYPE(cv) != SVt_PVCV) {
2933 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2936 if (!cv || !CvROOT(cv)) {
2937 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2938 PL_sig_name[sig], (gv ? GvENAME(gv)
2945 if(PL_psig_name[sig]) {
2946 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2948 #if !defined(PERL_IMPLICIT_CONTEXT)
2952 sv = sv_newmortal();
2953 sv_setpv(sv,PL_sig_name[sig]);
2956 PUSHSTACKi(PERLSI_SIGNAL);
2959 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2961 struct sigaction oact;
2963 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2966 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2967 /* The siginfo fields signo, code, errno, pid, uid,
2968 * addr, status, and band are defined by POSIX/SUSv3. */
2969 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2970 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2971 #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. */
2972 hv_stores(sih, "errno", newSViv(sip->si_errno));
2973 hv_stores(sih, "status", newSViv(sip->si_status));
2974 hv_stores(sih, "uid", newSViv(sip->si_uid));
2975 hv_stores(sih, "pid", newSViv(sip->si_pid));
2976 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2977 hv_stores(sih, "band", newSViv(sip->si_band));
2981 mPUSHp((char *)sip, sizeof(*sip));
2989 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2992 if (SvTRUE(ERRSV)) {
2994 #ifdef HAS_SIGPROCMASK
2995 /* Handler "died", for example to get out of a restart-able read().
2996 * Before we re-do that on its behalf re-enable the signal which was
2997 * blocked by the system when we entered.
3001 sigaddset(&set,sig);
3002 sigprocmask(SIG_UNBLOCK, &set, NULL);
3004 /* Not clear if this will work */
3005 (void)rsignal(sig, SIG_IGN);
3006 (void)rsignal(sig, PL_csighandlerp);
3008 #endif /* !PERL_MICRO */
3013 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3017 PL_scopestack_ix -= 1;
3020 PL_op = myop; /* Apparently not needed... */
3022 PL_Sv = tSv; /* Restore global temporaries. */
3029 S_restore_magic(pTHX_ const void *p)
3032 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3033 SV* const sv = mgs->mgs_sv;
3038 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3040 #ifdef PERL_OLD_COPY_ON_WRITE
3041 /* While magic was saved (and off) sv_setsv may well have seen
3042 this SV as a prime candidate for COW. */
3044 sv_force_normal_flags(sv, 0);
3047 if (mgs->mgs_readonly)
3049 if (mgs->mgs_magical)
3050 SvFLAGS(sv) |= mgs->mgs_magical;
3053 if (SvGMAGICAL(sv)) {
3054 /* downgrade public flags to private,
3055 and discard any other private flags */
3057 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3059 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3060 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3065 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3067 /* If we're still on top of the stack, pop us off. (That condition
3068 * will be satisfied if restore_magic was called explicitly, but *not*
3069 * if it's being called via leave_scope.)
3070 * The reason for doing this is that otherwise, things like sv_2cv()
3071 * may leave alloc gunk on the savestack, and some code
3072 * (e.g. sighandler) doesn't expect that...
3074 if (PL_savestack_ix == mgs->mgs_ss_ix)
3076 UV popval = SSPOPUV;
3077 assert(popval == SAVEt_DESTRUCTOR_X);
3078 PL_savestack_ix -= 2;
3080 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3081 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3087 S_unwind_handler_stack(pTHX_ const void *p)
3090 const U32 flags = *(const U32*)p;
3092 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3095 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3096 #if !defined(PERL_IMPLICIT_CONTEXT)
3098 SvREFCNT_dec(PL_sig_sv);
3103 =for apidoc magic_sethint
3105 Triggered by a store to %^H, records the key/value pair to
3106 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3107 anything that would need a deep copy. Maybe we should warn if we find a
3113 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3116 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3117 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3119 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3121 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3122 an alternative leaf in there, with PL_compiling.cop_hints being used if
3123 it's NULL. If needed for threads, the alternative could lock a mutex,
3124 or take other more complex action. */
3126 /* Something changed in %^H, so it will need to be restored on scope exit.
3127 Doing this here saves a lot of doing it manually in perl code (and
3128 forgetting to do it, and consequent subtle errors. */
3129 PL_hints |= HINT_LOCALIZE_HH;
3130 PL_compiling.cop_hints_hash
3131 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3136 =for apidoc magic_clearhint
3138 Triggered by a delete from %^H, records the key to
3139 C<PL_compiling.cop_hints_hash>.
3144 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3148 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3149 PERL_UNUSED_ARG(sv);
3151 assert(mg->mg_len == HEf_SVKEY);
3153 PERL_UNUSED_ARG(sv);
3155 PL_hints |= HINT_LOCALIZE_HH;
3156 PL_compiling.cop_hints_hash
3157 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3158 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3163 =for apidoc magic_clearhints
3165 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3170 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3172 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3173 PERL_UNUSED_ARG(sv);
3174 PERL_UNUSED_ARG(mg);
3175 if (PL_compiling.cop_hints_hash) {
3176 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3177 PL_compiling.cop_hints_hash = NULL;
3184 * c-indentation-style: bsd
3186 * indent-tabs-mode: t
3189 * ex: set ts=8 sts=4 sw=4 noet: