3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
61 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
63 Signal_t Perl_csighandler(int sig);
67 /* Missing protos on LynxOS */
68 void setruid(uid_t id);
69 void seteuid(uid_t id);
70 void setrgid(uid_t id);
71 void setegid(uid_t id);
75 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
83 /* MGS is typedef'ed to struct magic_state in perl.h */
86 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
91 PERL_ARGS_ASSERT_SAVE_MAGIC;
93 assert(SvMAGICAL(sv));
94 /* Turning READONLY off for a copy-on-write scalar (including shared
95 hash keys) is a bad idea. */
97 sv_force_normal_flags(sv, 0);
99 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
101 mgs = SSPTR(mgs_ix, MGS*);
103 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
104 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
108 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
109 /* No public flags are set, so promote any private flags to public. */
110 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
115 =for apidoc mg_magical
117 Turns on the magical status of an SV. See C<sv_magic>.
123 Perl_mg_magical(pTHX_ SV *sv)
126 PERL_ARGS_ASSERT_MG_MAGICAL;
128 if ((mg = SvMAGIC(sv))) {
131 const MGVTBL* const vtbl = mg->mg_virtual;
133 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
140 } while ((mg = mg->mg_moremagic));
141 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
147 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
150 S_is_container_magic(const MAGIC *mg)
153 switch (mg->mg_type) {
156 case PERL_MAGIC_regex_global:
157 case PERL_MAGIC_nkeys:
158 #ifdef USE_LOCALE_COLLATE
159 case PERL_MAGIC_collxfrm:
162 case PERL_MAGIC_taint:
164 case PERL_MAGIC_vstring:
165 case PERL_MAGIC_utf8:
166 case PERL_MAGIC_substr:
167 case PERL_MAGIC_defelem:
168 case PERL_MAGIC_arylen:
170 case PERL_MAGIC_backref:
171 case PERL_MAGIC_arylen_p:
172 case PERL_MAGIC_rhash:
173 case PERL_MAGIC_symtab:
183 Do magic after a value is retrieved from the SV. See C<sv_magic>.
189 Perl_mg_get(pTHX_ SV *sv)
192 const I32 mgs_ix = SSNEW(sizeof(MGS));
193 const bool was_temp = (bool)SvTEMP(sv);
195 MAGIC *newmg, *head, *cur, *mg;
196 /* guard against sv having being freed midway by holding a private
199 PERL_ARGS_ASSERT_MG_GET;
201 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
202 cause the SV's buffer to get stolen (and maybe other stuff).
205 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
210 save_magic(mgs_ix, sv);
212 /* We must call svt_get(sv, mg) for each valid entry in the linked
213 list of magic. svt_get() may delete the current entry, add new
214 magic to the head of the list, or upgrade the SV. AMS 20010810 */
216 newmg = cur = head = mg = SvMAGIC(sv);
218 const MGVTBL * const vtbl = mg->mg_virtual;
220 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
221 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
223 /* guard against magic having been deleted - eg FETCH calling
228 /* Don't restore the flags for this entry if it was deleted. */
229 if (mg->mg_flags & MGf_GSKIP)
230 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
233 mg = mg->mg_moremagic;
236 /* Have we finished with the new entries we saw? Start again
237 where we left off (unless there are more new entries). */
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
253 restore_magic(INT2PTR(void *, (IV)mgs_ix));
255 if (SvREFCNT(sv) == 1) {
256 /* We hold the last reference to this SV, which implies that the
257 SV was deleted as a side effect of the routines we called. */
266 Do magic after a value is assigned to the SV. See C<sv_magic>.
272 Perl_mg_set(pTHX_ SV *sv)
275 const I32 mgs_ix = SSNEW(sizeof(MGS));
279 PERL_ARGS_ASSERT_MG_SET;
281 save_magic(mgs_ix, sv);
283 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
284 const MGVTBL* vtbl = mg->mg_virtual;
285 nextmg = mg->mg_moremagic; /* it may delete itself */
286 if (mg->mg_flags & MGf_GSKIP) {
287 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
288 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
290 if (PL_localizing == 2 && !S_is_container_magic(mg))
292 if (vtbl && vtbl->svt_set)
293 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
301 =for apidoc mg_length
303 Report on the SV's length. See C<sv_magic>.
309 Perl_mg_length(pTHX_ SV *sv)
315 PERL_ARGS_ASSERT_MG_LENGTH;
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 const MGVTBL * const vtbl = mg->mg_virtual;
319 if (vtbl && vtbl->svt_len) {
320 const I32 mgs_ix = SSNEW(sizeof(MGS));
321 save_magic(mgs_ix, sv);
322 /* omit MGf_GSKIP -- not changed here */
323 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
324 restore_magic(INT2PTR(void*, (IV)mgs_ix));
330 /* You can't know whether it's UTF-8 until you get the string again...
332 const U8 *s = (U8*)SvPV_const(sv, len);
335 len = utf8_length(s, s + len);
342 Perl_mg_size(pTHX_ SV *sv)
346 PERL_ARGS_ASSERT_MG_SIZE;
348 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
349 const MGVTBL* const vtbl = mg->mg_virtual;
350 if (vtbl && vtbl->svt_len) {
351 const I32 mgs_ix = SSNEW(sizeof(MGS));
353 save_magic(mgs_ix, sv);
354 /* omit MGf_GSKIP -- not changed here */
355 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
356 restore_magic(INT2PTR(void*, (IV)mgs_ix));
363 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
367 Perl_croak(aTHX_ "Size magic not implemented");
376 Clear something magical that the SV represents. See C<sv_magic>.
382 Perl_mg_clear(pTHX_ SV *sv)
384 const I32 mgs_ix = SSNEW(sizeof(MGS));
387 PERL_ARGS_ASSERT_MG_CLEAR;
389 save_magic(mgs_ix, sv);
391 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
392 const MGVTBL* const vtbl = mg->mg_virtual;
393 /* omit GSKIP -- never set here */
395 if (vtbl && vtbl->svt_clear)
396 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
399 restore_magic(INT2PTR(void*, (IV)mgs_ix));
406 Finds the magic pointer for type matching the SV. See C<sv_magic>.
412 Perl_mg_find(pTHX_ const SV *sv, int type)
417 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
418 if (mg->mg_type == type)
428 Copies the magic from one SV to another. See C<sv_magic>.
434 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
439 PERL_ARGS_ASSERT_MG_COPY;
441 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
442 const MGVTBL* const vtbl = mg->mg_virtual;
443 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
444 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
447 const char type = mg->mg_type;
448 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
450 (type == PERL_MAGIC_tied)
452 : (type == PERL_MAGIC_regdata && mg->mg_obj)
455 toLOWER(type), key, klen);
464 =for apidoc mg_localize
466 Copy some of the magic from an existing SV to new localized version of that
467 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
470 If empty is false then no set magic will be called on the new (empty) SV.
471 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
472 and that will handle the magic.
478 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, I32 empty)
483 PERL_ARGS_ASSERT_MG_LOCALIZE;
485 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
486 const MGVTBL* const vtbl = mg->mg_virtual;
487 if (!S_is_container_magic(mg))
490 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
491 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
493 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
494 mg->mg_ptr, mg->mg_len);
496 /* container types should remain read-only across localization */
497 SvFLAGS(nsv) |= SvREADONLY(sv);
500 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
501 SvFLAGS(nsv) |= SvMAGICAL(sv);
513 Free any magic storage used by the SV. See C<sv_magic>.
519 Perl_mg_free(pTHX_ SV *sv)
524 PERL_ARGS_ASSERT_MG_FREE;
526 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
527 const MGVTBL* const vtbl = mg->mg_virtual;
528 moremagic = mg->mg_moremagic;
529 if (vtbl && vtbl->svt_free)
530 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
531 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
532 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
533 Safefree(mg->mg_ptr);
534 else if (mg->mg_len == HEf_SVKEY)
535 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
537 if (mg->mg_flags & MGf_REFCOUNTED)
538 SvREFCNT_dec(mg->mg_obj);
540 SvMAGIC_set(sv, moremagic);
542 SvMAGIC_set(sv, NULL);
550 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
555 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
558 register const REGEXP * const rx = PM_GETRE(PL_curpm);
560 if (mg->mg_obj) { /* @+ */
561 /* return the number possible */
562 return RX_NPARENS(rx);
564 I32 paren = RX_LASTPAREN(rx);
566 /* return the last filled */
568 && (RX_OFFS(rx)[paren].start == -1
569 || RX_OFFS(rx)[paren].end == -1) )
580 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
584 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
587 register const REGEXP * const rx = PM_GETRE(PL_curpm);
589 register const I32 paren = mg->mg_len;
594 if (paren <= (I32)RX_NPARENS(rx) &&
595 (s = RX_OFFS(rx)[paren].start) != -1 &&
596 (t = RX_OFFS(rx)[paren].end) != -1)
599 if (mg->mg_obj) /* @+ */
604 if (i > 0 && RX_MATCH_UTF8(rx)) {
605 const char * const b = RX_SUBBEG(rx);
607 i = utf8_length((U8*)b, (U8*)(b+i));
618 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
620 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
623 Perl_croak(aTHX_ "%s", PL_no_modify);
624 NORETURN_FUNCTION_END;
628 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
633 register const REGEXP * rx;
634 const char * const remaining = mg->mg_ptr + 1;
636 PERL_ARGS_ASSERT_MAGIC_LEN;
638 switch (*mg->mg_ptr) {
640 if (*remaining == '\0') { /* ^P */
642 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
644 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
648 case '\015': /* $^MATCH */
649 if (strEQ(remaining, "ATCH")) {
656 paren = RX_BUFF_IDX_PREMATCH;
660 paren = RX_BUFF_IDX_POSTMATCH;
664 paren = RX_BUFF_IDX_FULLMATCH;
666 case '1': case '2': case '3': case '4':
667 case '5': case '6': case '7': case '8': case '9':
668 paren = atoi(mg->mg_ptr);
670 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
672 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
675 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
678 if (ckWARN(WARN_UNINITIALIZED))
683 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
684 paren = RX_LASTPAREN(rx);
689 case '\016': /* ^N */
690 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
691 paren = RX_LASTCLOSEPAREN(rx);
698 if (!SvPOK(sv) && SvNIOK(sv)) {
706 #define SvRTRIM(sv) STMT_START { \
708 STRLEN len = SvCUR(sv); \
709 char * const p = SvPVX(sv); \
710 while (len > 0 && isSPACE(p[len-1])) \
712 SvCUR_set(sv, len); \
718 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
720 PERL_ARGS_ASSERT_EMULATE_COP_IO;
722 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
723 sv_setsv(sv, &PL_sv_undef);
727 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
728 SV *const value = Perl_refcounted_he_fetch(aTHX_
730 0, "open<", 5, 0, 0);
735 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
736 SV *const value = Perl_refcounted_he_fetch(aTHX_
738 0, "open>", 5, 0, 0);
746 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
750 register char *s = NULL;
752 const char * const remaining = mg->mg_ptr + 1;
753 const char nextchar = *remaining;
755 PERL_ARGS_ASSERT_MAGIC_GET;
757 switch (*mg->mg_ptr) {
758 case '\001': /* ^A */
759 sv_setsv(sv, PL_bodytarget);
761 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
762 if (nextchar == '\0') {
763 sv_setiv(sv, (IV)PL_minus_c);
765 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
766 sv_setiv(sv, (IV)STATUS_NATIVE);
770 case '\004': /* ^D */
771 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
773 case '\005': /* ^E */
774 if (nextchar == '\0') {
775 #if defined(MACOS_TRADITIONAL)
779 sv_setnv(sv,(double)gMacPerl_OSErr);
780 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
784 # include <descrip.h>
785 # include <starlet.h>
787 $DESCRIPTOR(msgdsc,msg);
788 sv_setnv(sv,(NV) vaxc$errno);
789 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
790 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
795 if (!(_emx_env & 0x200)) { /* Under DOS */
796 sv_setnv(sv, (NV)errno);
797 sv_setpv(sv, errno ? Strerror(errno) : "");
799 if (errno != errno_isOS2) {
800 const int tmp = _syserrno();
801 if (tmp) /* 2nd call to _syserrno() makes it 0 */
804 sv_setnv(sv, (NV)Perl_rc);
805 sv_setpv(sv, os2error(Perl_rc));
809 const DWORD dwErr = GetLastError();
810 sv_setnv(sv, (NV)dwErr);
812 PerlProc_GetOSError(sv, dwErr);
820 const int saveerrno = errno;
821 sv_setnv(sv, (NV)errno);
822 sv_setpv(sv, errno ? Strerror(errno) : "");
827 SvNOK_on(sv); /* what a wonderful hack! */
829 else if (strEQ(remaining, "NCODING"))
830 sv_setsv(sv, PL_encoding);
832 case '\006': /* ^F */
833 sv_setiv(sv, (IV)PL_maxsysfd);
835 case '\010': /* ^H */
836 sv_setiv(sv, (IV)PL_hints);
838 case '\011': /* ^I */ /* NOT \t in EBCDIC */
839 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
841 case '\017': /* ^O & ^OPEN */
842 if (nextchar == '\0') {
843 sv_setpv(sv, PL_osname);
846 else if (strEQ(remaining, "PEN")) {
847 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
851 if (nextchar == '\0') { /* ^P */
852 sv_setiv(sv, (IV)PL_perldb);
853 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
854 goto do_prematch_fetch;
855 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
856 goto do_postmatch_fetch;
859 case '\023': /* ^S */
860 if (nextchar == '\0') {
861 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
864 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
869 case '\024': /* ^T */
870 if (nextchar == '\0') {
872 sv_setnv(sv, PL_basetime);
874 sv_setiv(sv, (IV)PL_basetime);
877 else if (strEQ(remaining, "AINT"))
878 sv_setiv(sv, PL_tainting
879 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
882 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
883 if (strEQ(remaining, "NICODE"))
884 sv_setuv(sv, (UV) PL_unicode);
885 else if (strEQ(remaining, "TF8LOCALE"))
886 sv_setuv(sv, (UV) PL_utf8locale);
887 else if (strEQ(remaining, "TF8CACHE"))
888 sv_setiv(sv, (IV) PL_utf8cache);
890 case '\027': /* ^W & $^WARNING_BITS */
891 if (nextchar == '\0')
892 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
893 else if (strEQ(remaining, "ARNING_BITS")) {
894 if (PL_compiling.cop_warnings == pWARN_NONE) {
895 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
897 else if (PL_compiling.cop_warnings == pWARN_STD) {
900 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
904 else if (PL_compiling.cop_warnings == pWARN_ALL) {
905 /* Get the bit mask for $warnings::Bits{all}, because
906 * it could have been extended by warnings::register */
907 HV * const bits=get_hv("warnings::Bits", FALSE);
909 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
911 sv_setsv(sv, *bits_all);
914 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
918 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
919 *PL_compiling.cop_warnings);
924 case '\015': /* $^MATCH */
925 if (strEQ(remaining, "ATCH")) {
926 case '1': case '2': case '3': case '4':
927 case '5': case '6': case '7': case '8': case '9': case '&':
928 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
930 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
931 * XXX Does the new way break anything?
933 paren = atoi(mg->mg_ptr); /* $& is in [0] */
934 CALLREG_NUMBUF_FETCH(rx,paren,sv);
937 sv_setsv(sv,&PL_sv_undef);
941 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
942 if (RX_LASTPAREN(rx)) {
943 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
947 sv_setsv(sv,&PL_sv_undef);
949 case '\016': /* ^N */
950 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
951 if (RX_LASTCLOSEPAREN(rx)) {
952 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
957 sv_setsv(sv,&PL_sv_undef);
961 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
962 CALLREG_NUMBUF_FETCH(rx,-2,sv);
965 sv_setsv(sv,&PL_sv_undef);
969 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
970 CALLREG_NUMBUF_FETCH(rx,-1,sv);
973 sv_setsv(sv,&PL_sv_undef);
976 if (GvIO(PL_last_in_gv)) {
977 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
982 sv_setiv(sv, (IV)STATUS_CURRENT);
983 #ifdef COMPLEX_STATUS
984 LvTARGOFF(sv) = PL_statusvalue;
985 LvTARGLEN(sv) = PL_statusvalue_vms;
990 if (GvIOp(PL_defoutgv))
991 s = IoTOP_NAME(GvIOp(PL_defoutgv));
995 sv_setpv(sv,GvENAME(PL_defoutgv));
996 sv_catpvs(sv,"_TOP");
1000 if (GvIOp(PL_defoutgv))
1001 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1003 s = GvENAME(PL_defoutgv);
1007 if (GvIOp(PL_defoutgv))
1008 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1011 if (GvIOp(PL_defoutgv))
1012 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1015 if (GvIOp(PL_defoutgv))
1016 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1023 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1026 if (GvIOp(PL_defoutgv))
1027 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1033 sv_copypv(sv, PL_ors_sv);
1037 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1038 sv_setpv(sv, errno ? Strerror(errno) : "");
1041 const int saveerrno = errno;
1042 sv_setnv(sv, (NV)errno);
1044 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1045 sv_setpv(sv, os2error(Perl_rc));
1048 sv_setpv(sv, errno ? Strerror(errno) : "");
1053 SvNOK_on(sv); /* what a wonderful hack! */
1056 sv_setiv(sv, (IV)PL_uid);
1059 sv_setiv(sv, (IV)PL_euid);
1062 sv_setiv(sv, (IV)PL_gid);
1065 sv_setiv(sv, (IV)PL_egid);
1067 #ifdef HAS_GETGROUPS
1069 Groups_t *gary = NULL;
1070 I32 i, num_groups = getgroups(0, gary);
1071 Newx(gary, num_groups, Groups_t);
1072 num_groups = getgroups(num_groups, gary);
1073 for (i = 0; i < num_groups; i++)
1074 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1077 (void)SvIOK_on(sv); /* what a wonderful hack! */
1080 #ifndef MACOS_TRADITIONAL
1089 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1091 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1093 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1095 if (uf && uf->uf_val)
1096 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1101 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1104 STRLEN len = 0, klen;
1105 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1106 const char * const ptr = MgPV_const(mg,klen);
1109 PERL_ARGS_ASSERT_MAGIC_SETENV;
1111 #ifdef DYNAMIC_ENV_FETCH
1112 /* We just undefd an environment var. Is a replacement */
1113 /* waiting in the wings? */
1115 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1117 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1121 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1122 /* And you'll never guess what the dog had */
1123 /* in its mouth... */
1125 MgTAINTEDDIR_off(mg);
1127 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1128 char pathbuf[256], eltbuf[256], *cp, *elt;
1132 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1134 do { /* DCL$PATH may be a search list */
1135 while (1) { /* as may dev portion of any element */
1136 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1137 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1138 cando_by_name(S_IWUSR,0,elt) ) {
1139 MgTAINTEDDIR_on(mg);
1143 if ((cp = strchr(elt, ':')) != NULL)
1145 if (my_trnlnm(elt, eltbuf, j++))
1151 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1154 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1155 const char * const strend = s + len;
1157 while (s < strend) {
1161 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1162 const char path_sep = '|';
1164 const char path_sep = ':';
1166 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1167 s, strend, path_sep, &i);
1169 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1171 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1173 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1175 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1176 MgTAINTEDDIR_on(mg);
1182 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1188 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1190 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1191 PERL_UNUSED_ARG(sv);
1192 my_setenv(MgPV_nolen_const(mg),NULL);
1197 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1200 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1201 PERL_UNUSED_ARG(mg);
1203 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1205 if (PL_localizing) {
1208 hv_iterinit(MUTABLE_HV(sv));
1209 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1211 my_setenv(hv_iterkey(entry, &keylen),
1212 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1220 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1223 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1224 PERL_UNUSED_ARG(sv);
1225 PERL_UNUSED_ARG(mg);
1227 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1235 #ifdef HAS_SIGPROCMASK
1237 restore_sigmask(pTHX_ SV *save_sv)
1239 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1240 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1244 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1247 /* Are we fetching a signal entry? */
1248 const I32 i = whichsig(MgPV_nolen_const(mg));
1250 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1254 sv_setsv(sv,PL_psig_ptr[i]);
1256 Sighandler_t sigstate = rsignal_state(i);
1257 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1258 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1261 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1262 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1265 /* cache state so we don't fetch it again */
1266 if(sigstate == (Sighandler_t) SIG_IGN)
1267 sv_setpvs(sv,"IGNORE");
1269 sv_setsv(sv,&PL_sv_undef);
1270 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1277 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1279 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1280 * refactoring might be in order.
1283 register const char * const s = MgPV_nolen_const(mg);
1284 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1285 PERL_UNUSED_ARG(sv);
1288 if (strEQ(s,"__DIE__"))
1290 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1293 SV *const to_dec = *svp;
1295 SvREFCNT_dec(to_dec);
1299 /* Are we clearing a signal entry? */
1300 const I32 i = whichsig(s);
1302 #ifdef HAS_SIGPROCMASK
1305 /* Avoid having the signal arrive at a bad time, if possible. */
1308 sigprocmask(SIG_BLOCK, &set, &save);
1310 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1311 SAVEFREESV(save_sv);
1312 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1315 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1316 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1318 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319 PL_sig_defaulting[i] = 1;
1320 (void)rsignal(i, PL_csighandlerp);
1322 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1324 if(PL_psig_name[i]) {
1325 SvREFCNT_dec(PL_psig_name[i]);
1328 if(PL_psig_ptr[i]) {
1329 SV * const to_dec=PL_psig_ptr[i];
1332 SvREFCNT_dec(to_dec);
1342 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1343 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1345 Perl_csighandler(int sig)
1348 #ifdef PERL_GET_SIG_CONTEXT
1349 dTHXa(PERL_GET_SIG_CONTEXT);
1353 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1354 (void) rsignal(sig, PL_csighandlerp);
1355 if (PL_sig_ignoring[sig]) return;
1357 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1358 if (PL_sig_defaulting[sig])
1359 #ifdef KILL_BY_SIGPRC
1360 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1375 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1376 /* Call the perl level handler now--
1377 * with risk we may be in malloc() etc. */
1378 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1379 (*PL_sighandlerp)(sig, NULL, NULL);
1381 (*PL_sighandlerp)(sig);
1384 /* Set a flag to say this signal is pending, that is awaiting delivery after
1385 * the current Perl opcode completes */
1386 PL_psig_pend[sig]++;
1388 #ifndef SIG_PENDING_DIE_COUNT
1389 # define SIG_PENDING_DIE_COUNT 120
1391 /* And one to say _a_ signal is pending */
1392 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1393 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1394 (unsigned long)SIG_PENDING_DIE_COUNT);
1398 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1400 Perl_csighandler_init(void)
1403 if (PL_sig_handlers_initted) return;
1405 for (sig = 1; sig < SIG_SIZE; sig++) {
1406 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1408 PL_sig_defaulting[sig] = 1;
1409 (void) rsignal(sig, PL_csighandlerp);
1411 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1412 PL_sig_ignoring[sig] = 0;
1415 PL_sig_handlers_initted = 1;
1420 Perl_despatch_signals(pTHX)
1425 for (sig = 1; sig < SIG_SIZE; sig++) {
1426 if (PL_psig_pend[sig]) {
1427 PERL_BLOCKSIG_ADD(set, sig);
1428 PL_psig_pend[sig] = 0;
1429 PERL_BLOCKSIG_BLOCK(set);
1430 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1431 (*PL_sighandlerp)(sig, NULL, NULL);
1433 (*PL_sighandlerp)(sig);
1435 PERL_BLOCKSIG_UNBLOCK(set);
1441 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1446 /* Need to be careful with SvREFCNT_dec(), because that can have side
1447 * effects (due to closures). We must make sure that the new disposition
1448 * is in place before it is called.
1452 #ifdef HAS_SIGPROCMASK
1456 register const char *s = MgPV_const(mg,len);
1458 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1461 if (strEQ(s,"__DIE__"))
1463 else if (strEQ(s,"__WARN__"))
1466 Perl_croak(aTHX_ "No such hook: %s", s);
1469 if (*svp != PERL_WARNHOOK_FATAL)
1475 i = whichsig(s); /* ...no, a brick */
1477 if (ckWARN(WARN_SIGNAL))
1478 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1481 #ifdef HAS_SIGPROCMASK
1482 /* Avoid having the signal arrive at a bad time, if possible. */
1485 sigprocmask(SIG_BLOCK, &set, &save);
1487 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1488 SAVEFREESV(save_sv);
1489 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1492 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1493 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1495 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1496 PL_sig_ignoring[i] = 0;
1498 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1499 PL_sig_defaulting[i] = 0;
1501 SvREFCNT_dec(PL_psig_name[i]);
1502 to_dec = PL_psig_ptr[i];
1503 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1504 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1505 PL_psig_name[i] = newSVpvn(s, len);
1506 SvREADONLY_on(PL_psig_name[i]);
1508 if (isGV_with_GP(sv) || SvROK(sv)) {
1510 (void)rsignal(i, PL_csighandlerp);
1511 #ifdef HAS_SIGPROCMASK
1516 *svp = SvREFCNT_inc_simple_NN(sv);
1518 SvREFCNT_dec(to_dec);
1521 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1522 if (strEQ(s,"IGNORE")) {
1524 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1525 PL_sig_ignoring[i] = 1;
1526 (void)rsignal(i, PL_csighandlerp);
1528 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1532 else if (strEQ(s,"DEFAULT") || !*s) {
1534 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1536 PL_sig_defaulting[i] = 1;
1537 (void)rsignal(i, PL_csighandlerp);
1540 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1545 * We should warn if HINT_STRICT_REFS, but without
1546 * access to a known hint bit in a known OP, we can't
1547 * tell whether HINT_STRICT_REFS is in force or not.
1549 if (!strchr(s,':') && !strchr(s,'\''))
1550 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1553 (void)rsignal(i, PL_csighandlerp);
1555 *svp = SvREFCNT_inc_simple_NN(sv);
1557 #ifdef HAS_SIGPROCMASK
1562 SvREFCNT_dec(to_dec);
1565 #endif /* !PERL_MICRO */
1568 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1573 PERL_ARGS_ASSERT_MAGIC_SETISA;
1574 PERL_UNUSED_ARG(sv);
1576 /* Bail out if destruction is going on */
1577 if(PL_dirty) return 0;
1579 /* Skip _isaelem because _isa will handle it shortly */
1580 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1583 /* XXX Once it's possible, we need to
1584 detect that our @ISA is aliased in
1585 other stashes, and act on the stashes
1586 of all of the aliases */
1588 /* The first case occurs via setisa,
1589 the second via setisa_elem, which
1590 calls this same magic */
1592 SvTYPE(mg->mg_obj) == SVt_PVGV
1593 ? (const GV *)mg->mg_obj
1594 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1598 mro_isa_changed_in(stash);
1604 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1609 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1611 /* Bail out if destruction is going on */
1612 if(PL_dirty) return 0;
1614 av_clear(MUTABLE_AV(sv));
1616 /* XXX see comments in magic_setisa */
1618 SvTYPE(mg->mg_obj) == SVt_PVGV
1619 ? (const GV *)mg->mg_obj
1620 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1624 mro_isa_changed_in(stash);
1630 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1633 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1634 PERL_UNUSED_ARG(sv);
1635 PERL_UNUSED_ARG(mg);
1636 PL_amagic_generation++;
1642 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1644 HV * const hv = MUTABLE_HV(LvTARG(sv));
1647 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1648 PERL_UNUSED_ARG(mg);
1651 (void) hv_iterinit(hv);
1652 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1655 while (hv_iternext(hv))
1660 sv_setiv(sv, (IV)i);
1665 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1667 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1668 PERL_UNUSED_ARG(mg);
1670 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1675 /* caller is responsible for stack switching/cleanup */
1677 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1682 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1686 PUSHs(SvTIED_obj(sv, mg));
1689 if (mg->mg_len >= 0)
1690 mPUSHp(mg->mg_ptr, mg->mg_len);
1691 else if (mg->mg_len == HEf_SVKEY)
1692 PUSHs(MUTABLE_SV(mg->mg_ptr));
1694 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1703 return call_method(meth, flags);
1707 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1711 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1715 PUSHSTACKi(PERLSI_MAGIC);
1717 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1718 sv_setsv(sv, *PL_stack_sp--);
1728 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1730 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1733 mg->mg_flags |= MGf_GSKIP;
1734 magic_methpack(sv,mg,"FETCH");
1739 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1743 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1746 PUSHSTACKi(PERLSI_MAGIC);
1747 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1754 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1756 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1758 return magic_methpack(sv,mg,"DELETE");
1763 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1768 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1772 PUSHSTACKi(PERLSI_MAGIC);
1773 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1774 sv = *PL_stack_sp--;
1775 retval = SvIV(sv)-1;
1777 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1782 return (U32) retval;
1786 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1790 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1793 PUSHSTACKi(PERLSI_MAGIC);
1795 XPUSHs(SvTIED_obj(sv, mg));
1797 call_method("CLEAR", G_SCALAR|G_DISCARD);
1805 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1808 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1810 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1814 PUSHSTACKi(PERLSI_MAGIC);
1817 PUSHs(SvTIED_obj(sv, mg));
1822 if (call_method(meth, G_SCALAR))
1823 sv_setsv(key, *PL_stack_sp--);
1832 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1834 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1836 return magic_methpack(sv,mg,"EXISTS");
1840 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1844 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1845 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1847 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1849 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1851 if (HvEITER_get(hv))
1852 /* we are in an iteration so the hash cannot be empty */
1854 /* no xhv_eiter so now use FIRSTKEY */
1855 key = sv_newmortal();
1856 magic_nextpack(MUTABLE_SV(hv), mg, key);
1857 HvEITER_set(hv, NULL); /* need to reset iterator */
1858 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1861 /* there is a SCALAR method that we can call */
1863 PUSHSTACKi(PERLSI_MAGIC);
1869 if (call_method("SCALAR", G_SCALAR))
1870 retval = *PL_stack_sp--;
1872 retval = &PL_sv_undef;
1879 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1882 GV * const gv = PL_DBline;
1883 const I32 i = SvTRUE(sv);
1884 SV ** const svp = av_fetch(GvAV(gv),
1885 atoi(MgPV_nolen_const(mg)), FALSE);
1887 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1889 if (svp && SvIOKp(*svp)) {
1890 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1892 /* set or clear breakpoint in the relevant control op */
1894 o->op_flags |= OPf_SPECIAL;
1896 o->op_flags &= ~OPf_SPECIAL;
1903 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1906 AV * const obj = MUTABLE_AV(mg->mg_obj);
1908 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1911 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1919 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1922 AV * const obj = MUTABLE_AV(mg->mg_obj);
1924 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1927 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1929 if (ckWARN(WARN_MISC))
1930 Perl_warner(aTHX_ packWARN(WARN_MISC),
1931 "Attempt to set length of freed array");
1937 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1941 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1942 PERL_UNUSED_ARG(sv);
1944 /* during global destruction, mg_obj may already have been freed */
1945 if (PL_in_clean_all)
1948 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1951 /* arylen scalar holds a pointer back to the array, but doesn't own a
1952 reference. Hence the we (the array) are about to go away with it
1953 still pointing at us. Clear its pointer, else it would be pointing
1954 at free memory. See the comment in sv_magic about reference loops,
1955 and why it can't own a reference to us. */
1962 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1965 SV* const lsv = LvTARG(sv);
1967 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1968 PERL_UNUSED_ARG(mg);
1970 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1971 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1972 if (found && found->mg_len >= 0) {
1973 I32 i = found->mg_len;
1975 sv_pos_b2u(lsv, &i);
1976 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1985 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1988 SV* const lsv = LvTARG(sv);
1994 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1995 PERL_UNUSED_ARG(mg);
1997 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1998 found = mg_find(lsv, PERL_MAGIC_regex_global);
2004 #ifdef PERL_OLD_COPY_ON_WRITE
2006 sv_force_normal_flags(lsv, 0);
2008 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2011 else if (!SvOK(sv)) {
2015 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2017 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2020 ulen = sv_len_utf8(lsv);
2030 else if (pos > (SSize_t)len)
2035 sv_pos_u2b(lsv, &p, 0);
2039 found->mg_len = pos;
2040 found->mg_flags &= ~MGf_MINMATCH;
2046 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2049 SV * const lsv = LvTARG(sv);
2050 const char * const tmps = SvPV_const(lsv,len);
2051 I32 offs = LvTARGOFF(sv);
2052 I32 rem = LvTARGLEN(sv);
2054 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2055 PERL_UNUSED_ARG(mg);
2058 sv_pos_u2b(lsv, &offs, &rem);
2059 if (offs > (I32)len)
2061 if (rem + offs > (I32)len)
2063 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2070 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2074 const char * const tmps = SvPV_const(sv, len);
2075 SV * const lsv = LvTARG(sv);
2076 I32 lvoff = LvTARGOFF(sv);
2077 I32 lvlen = LvTARGLEN(sv);
2079 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2080 PERL_UNUSED_ARG(mg);
2083 sv_utf8_upgrade(lsv);
2084 sv_pos_u2b(lsv, &lvoff, &lvlen);
2085 sv_insert(lsv, lvoff, lvlen, tmps, len);
2086 LvTARGLEN(sv) = sv_len_utf8(sv);
2089 else if (lsv && SvUTF8(lsv)) {
2091 sv_pos_u2b(lsv, &lvoff, &lvlen);
2092 LvTARGLEN(sv) = len;
2093 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2094 sv_insert(lsv, lvoff, lvlen, utf8, len);
2098 sv_insert(lsv, lvoff, lvlen, tmps, len);
2099 LvTARGLEN(sv) = len;
2107 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2111 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2112 PERL_UNUSED_ARG(sv);
2114 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2119 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2123 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2124 PERL_UNUSED_ARG(sv);
2126 /* update taint status */
2135 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2137 SV * const lsv = LvTARG(sv);
2139 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2140 PERL_UNUSED_ARG(mg);
2143 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2151 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2153 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2154 PERL_UNUSED_ARG(mg);
2155 do_vecset(sv); /* XXX slurp this routine */
2160 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2165 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2167 if (LvTARGLEN(sv)) {
2169 SV * const ahv = LvTARG(sv);
2170 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2175 AV *const av = MUTABLE_AV(LvTARG(sv));
2176 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2177 targ = AvARRAY(av)[LvTARGOFF(sv)];
2179 if (targ && (targ != &PL_sv_undef)) {
2180 /* somebody else defined it for us */
2181 SvREFCNT_dec(LvTARG(sv));
2182 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2184 SvREFCNT_dec(mg->mg_obj);
2186 mg->mg_flags &= ~MGf_REFCOUNTED;
2191 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2196 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2198 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2199 PERL_UNUSED_ARG(mg);
2203 sv_setsv(LvTARG(sv), sv);
2204 SvSETMAGIC(LvTARG(sv));
2210 Perl_vivify_defelem(pTHX_ SV *sv)
2216 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2218 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2221 SV * const ahv = LvTARG(sv);
2222 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2225 if (!value || value == &PL_sv_undef)
2226 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2229 AV *const av = MUTABLE_AV(LvTARG(sv));
2230 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2231 LvTARG(sv) = NULL; /* array can't be extended */
2233 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2234 if (!svp || (value = *svp) == &PL_sv_undef)
2235 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2238 SvREFCNT_inc_simple_void(value);
2239 SvREFCNT_dec(LvTARG(sv));
2242 SvREFCNT_dec(mg->mg_obj);
2244 mg->mg_flags &= ~MGf_REFCOUNTED;
2248 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2250 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2251 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2255 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2257 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2258 PERL_UNUSED_CONTEXT;
2265 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2267 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2269 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2271 if (uf && uf->uf_set)
2272 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2277 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2279 const char type = mg->mg_type;
2281 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2283 if (type == PERL_MAGIC_qr) {
2284 } else if (type == PERL_MAGIC_bm) {
2288 assert(type == PERL_MAGIC_fm);
2291 return sv_unmagic(sv, type);
2294 #ifdef USE_LOCALE_COLLATE
2296 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2298 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2301 * RenE<eacute> Descartes said "I think not."
2302 * and vanished with a faint plop.
2304 PERL_UNUSED_CONTEXT;
2305 PERL_UNUSED_ARG(sv);
2307 Safefree(mg->mg_ptr);
2313 #endif /* USE_LOCALE_COLLATE */
2315 /* Just clear the UTF-8 cache data. */
2317 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2319 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2320 PERL_UNUSED_CONTEXT;
2321 PERL_UNUSED_ARG(sv);
2322 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2324 mg->mg_len = -1; /* The mg_len holds the len cache. */
2329 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2332 register const char *s;
2334 register const REGEXP * rx;
2335 const char * const remaining = mg->mg_ptr + 1;
2339 PERL_ARGS_ASSERT_MAGIC_SET;
2341 switch (*mg->mg_ptr) {
2342 case '\015': /* $^MATCH */
2343 if (strEQ(remaining, "ATCH"))
2345 case '`': /* ${^PREMATCH} caught below */
2347 paren = RX_BUFF_IDX_PREMATCH;
2349 case '\'': /* ${^POSTMATCH} caught below */
2351 paren = RX_BUFF_IDX_POSTMATCH;
2355 paren = RX_BUFF_IDX_FULLMATCH;
2357 case '1': case '2': case '3': case '4':
2358 case '5': case '6': case '7': case '8': case '9':
2359 paren = atoi(mg->mg_ptr);
2361 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2362 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2365 /* Croak with a READONLY error when a numbered match var is
2366 * set without a previous pattern match. Unless it's C<local $1>
2368 if (!PL_localizing) {
2369 Perl_croak(aTHX_ "%s", PL_no_modify);
2372 case '\001': /* ^A */
2373 sv_setsv(PL_bodytarget, sv);
2375 case '\003': /* ^C */
2376 PL_minus_c = (bool)SvIV(sv);
2379 case '\004': /* ^D */
2381 s = SvPV_nolen_const(sv);
2382 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2383 DEBUG_x(dump_all());
2385 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2388 case '\005': /* ^E */
2389 if (*(mg->mg_ptr+1) == '\0') {
2390 #ifdef MACOS_TRADITIONAL
2391 gMacPerl_OSErr = SvIV(sv);
2394 set_vaxc_errno(SvIV(sv));
2397 SetLastError( SvIV(sv) );
2400 os2_setsyserrno(SvIV(sv));
2402 /* will anyone ever use this? */
2403 SETERRNO(SvIV(sv), 4);
2409 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2411 SvREFCNT_dec(PL_encoding);
2412 if (SvOK(sv) || SvGMAGICAL(sv)) {
2413 PL_encoding = newSVsv(sv);
2420 case '\006': /* ^F */
2421 PL_maxsysfd = SvIV(sv);
2423 case '\010': /* ^H */
2424 PL_hints = SvIV(sv);
2426 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2427 Safefree(PL_inplace);
2428 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2430 case '\017': /* ^O */
2431 if (*(mg->mg_ptr+1) == '\0') {
2432 Safefree(PL_osname);
2435 TAINT_PROPER("assigning to $^O");
2436 PL_osname = savesvpv(sv);
2439 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2441 const char *const start = SvPV(sv, len);
2442 const char *out = (const char*)memchr(start, '\0', len);
2444 struct refcounted_he *tmp_he;
2447 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2449 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2451 /* Opening for input is more common than opening for output, so
2452 ensure that hints for input are sooner on linked list. */
2453 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2454 SVs_TEMP | SvUTF8(sv))
2455 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
2458 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2459 newSVpvs_flags("open>", SVs_TEMP),
2462 /* The UTF-8 setting is carried over */
2463 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2465 PL_compiling.cop_hints_hash
2466 = Perl_refcounted_he_new(aTHX_ tmp_he,
2467 newSVpvs_flags("open<", SVs_TEMP),
2471 case '\020': /* ^P */
2472 if (*remaining == '\0') { /* ^P */
2473 PL_perldb = SvIV(sv);
2474 if (PL_perldb && !PL_DBsingle)
2477 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2479 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2482 case '\024': /* ^T */
2484 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2486 PL_basetime = (Time_t)SvIV(sv);
2489 case '\025': /* ^UTF8CACHE */
2490 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2491 PL_utf8cache = (signed char) sv_2iv(sv);
2494 case '\027': /* ^W & $^WARNING_BITS */
2495 if (*(mg->mg_ptr+1) == '\0') {
2496 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2498 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2499 | (i ? G_WARN_ON : G_WARN_OFF) ;
2502 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2503 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2504 if (!SvPOK(sv) && PL_localizing) {
2505 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2506 PL_compiling.cop_warnings = pWARN_NONE;
2511 int accumulate = 0 ;
2512 int any_fatals = 0 ;
2513 const char * const ptr = SvPV_const(sv, len) ;
2514 for (i = 0 ; i < len ; ++i) {
2515 accumulate |= ptr[i] ;
2516 any_fatals |= (ptr[i] & 0xAA) ;
2519 if (!specialWARN(PL_compiling.cop_warnings))
2520 PerlMemShared_free(PL_compiling.cop_warnings);
2521 PL_compiling.cop_warnings = pWARN_NONE;
2523 /* Yuck. I can't see how to abstract this: */
2524 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2525 WARN_ALL) && !any_fatals) {
2526 if (!specialWARN(PL_compiling.cop_warnings))
2527 PerlMemShared_free(PL_compiling.cop_warnings);
2528 PL_compiling.cop_warnings = pWARN_ALL;
2529 PL_dowarn |= G_WARN_ONCE ;
2533 const char *const p = SvPV_const(sv, len);
2535 PL_compiling.cop_warnings
2536 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2539 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2540 PL_dowarn |= G_WARN_ONCE ;
2548 if (PL_localizing) {
2549 if (PL_localizing == 1)
2550 SAVESPTR(PL_last_in_gv);
2552 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2553 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2556 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2557 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2558 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2561 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2562 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2563 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2566 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2569 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2570 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2571 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2574 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2578 IO * const io = GvIOp(PL_defoutgv);
2581 if ((SvIV(sv)) == 0)
2582 IoFLAGS(io) &= ~IOf_FLUSH;
2584 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2585 PerlIO *ofp = IoOFP(io);
2587 (void)PerlIO_flush(ofp);
2588 IoFLAGS(io) |= IOf_FLUSH;
2594 SvREFCNT_dec(PL_rs);
2595 PL_rs = newSVsv(sv);
2599 SvREFCNT_dec(PL_ors_sv);
2600 if (SvOK(sv) || SvGMAGICAL(sv)) {
2601 PL_ors_sv = newSVsv(sv);
2609 SvREFCNT_dec(PL_ofs_sv);
2610 if (SvOK(sv) || SvGMAGICAL(sv)) {
2611 PL_ofs_sv = newSVsv(sv);
2618 CopARYBASE_set(&PL_compiling, SvIV(sv));
2621 #ifdef COMPLEX_STATUS
2622 if (PL_localizing == 2) {
2623 PL_statusvalue = LvTARGOFF(sv);
2624 PL_statusvalue_vms = LvTARGLEN(sv);
2628 #ifdef VMSISH_STATUS
2630 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2633 STATUS_UNIX_EXIT_SET(SvIV(sv));
2638 # define PERL_VMS_BANG vaxc$errno
2640 # define PERL_VMS_BANG 0
2642 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2643 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2648 if (PL_delaymagic) {
2649 PL_delaymagic |= DM_RUID;
2650 break; /* don't do magic till later */
2653 (void)setruid((Uid_t)PL_uid);
2656 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2658 #ifdef HAS_SETRESUID
2659 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2661 if (PL_uid == PL_euid) { /* special case $< = $> */
2663 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2664 if (PL_uid != 0 && PerlProc_getuid() == 0)
2665 (void)PerlProc_setuid(0);
2667 (void)PerlProc_setuid(PL_uid);
2669 PL_uid = PerlProc_getuid();
2670 Perl_croak(aTHX_ "setruid() not implemented");
2675 PL_uid = PerlProc_getuid();
2676 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2680 if (PL_delaymagic) {
2681 PL_delaymagic |= DM_EUID;
2682 break; /* don't do magic till later */
2685 (void)seteuid((Uid_t)PL_euid);
2688 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2690 #ifdef HAS_SETRESUID
2691 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2693 if (PL_euid == PL_uid) /* special case $> = $< */
2694 PerlProc_setuid(PL_euid);
2696 PL_euid = PerlProc_geteuid();
2697 Perl_croak(aTHX_ "seteuid() not implemented");
2702 PL_euid = PerlProc_geteuid();
2703 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2707 if (PL_delaymagic) {
2708 PL_delaymagic |= DM_RGID;
2709 break; /* don't do magic till later */
2712 (void)setrgid((Gid_t)PL_gid);
2715 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2717 #ifdef HAS_SETRESGID
2718 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2720 if (PL_gid == PL_egid) /* special case $( = $) */
2721 (void)PerlProc_setgid(PL_gid);
2723 PL_gid = PerlProc_getgid();
2724 Perl_croak(aTHX_ "setrgid() not implemented");
2729 PL_gid = PerlProc_getgid();
2730 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2733 #ifdef HAS_SETGROUPS
2735 const char *p = SvPV_const(sv, len);
2736 Groups_t *gary = NULL;
2741 for (i = 0; i < NGROUPS; ++i) {
2742 while (*p && !isSPACE(*p))
2749 Newx(gary, i + 1, Groups_t);
2751 Renew(gary, i + 1, Groups_t);
2755 (void)setgroups(i, gary);
2758 #else /* HAS_SETGROUPS */
2760 #endif /* HAS_SETGROUPS */
2761 if (PL_delaymagic) {
2762 PL_delaymagic |= DM_EGID;
2763 break; /* don't do magic till later */
2766 (void)setegid((Gid_t)PL_egid);
2769 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2771 #ifdef HAS_SETRESGID
2772 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2774 if (PL_egid == PL_gid) /* special case $) = $( */
2775 (void)PerlProc_setgid(PL_egid);
2777 PL_egid = PerlProc_getegid();
2778 Perl_croak(aTHX_ "setegid() not implemented");
2783 PL_egid = PerlProc_getegid();
2784 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2787 PL_chopset = SvPV_force(sv,len);
2789 #ifndef MACOS_TRADITIONAL
2791 LOCK_DOLLARZERO_MUTEX;
2792 #ifdef HAS_SETPROCTITLE
2793 /* The BSDs don't show the argv[] in ps(1) output, they
2794 * show a string from the process struct and provide
2795 * the setproctitle() routine to manipulate that. */
2796 if (PL_origalen != 1) {
2797 s = SvPV_const(sv, len);
2798 # if __FreeBSD_version > 410001
2799 /* The leading "-" removes the "perl: " prefix,
2800 * but not the "(perl) suffix from the ps(1)
2801 * output, because that's what ps(1) shows if the
2802 * argv[] is modified. */
2803 setproctitle("-%s", s);
2804 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2805 /* This doesn't really work if you assume that
2806 * $0 = 'foobar'; will wipe out 'perl' from the $0
2807 * because in ps(1) output the result will be like
2808 * sprintf("perl: %s (perl)", s)
2809 * I guess this is a security feature:
2810 * one (a user process) cannot get rid of the original name.
2812 setproctitle("%s", s);
2815 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2816 if (PL_origalen != 1) {
2818 s = SvPV_const(sv, len);
2819 un.pst_command = (char *)s;
2820 pstat(PSTAT_SETCMD, un, len, 0, 0);
2823 if (PL_origalen > 1) {
2824 /* PL_origalen is set in perl_parse(). */
2825 s = SvPV_force(sv,len);
2826 if (len >= (STRLEN)PL_origalen-1) {
2827 /* Longer than original, will be truncated. We assume that
2828 * PL_origalen bytes are available. */
2829 Copy(s, PL_origargv[0], PL_origalen-1, char);
2832 /* Shorter than original, will be padded. */
2834 /* Special case for Mac OS X: see [perl #38868] */
2837 /* Is the space counterintuitive? Yes.
2838 * (You were expecting \0?)
2839 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2841 const int pad = ' ';
2843 Copy(s, PL_origargv[0], len, char);
2844 PL_origargv[0][len] = 0;
2845 memset(PL_origargv[0] + len + 1,
2846 pad, PL_origalen - len - 1);
2848 PL_origargv[0][PL_origalen-1] = 0;
2849 for (i = 1; i < PL_origargc; i++)
2853 UNLOCK_DOLLARZERO_MUTEX;
2861 Perl_whichsig(pTHX_ const char *sig)
2863 register char* const* sigv;
2865 PERL_ARGS_ASSERT_WHICHSIG;
2866 PERL_UNUSED_CONTEXT;
2868 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2869 if (strEQ(sig,*sigv))
2870 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2872 if (strEQ(sig,"CHLD"))
2876 if (strEQ(sig,"CLD"))
2883 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2884 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2886 Perl_sighandler(int sig)
2889 #ifdef PERL_GET_SIG_CONTEXT
2890 dTHXa(PERL_GET_SIG_CONTEXT);
2897 SV * const tSv = PL_Sv;
2901 XPV * const tXpv = PL_Xpv;
2903 if (PL_savestack_ix + 15 <= PL_savestack_max)
2905 if (PL_markstack_ptr < PL_markstack_max - 2)
2907 if (PL_scopestack_ix < PL_scopestack_max - 3)
2910 if (!PL_psig_ptr[sig]) {
2911 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2916 /* Max number of items pushed there is 3*n or 4. We cannot fix
2917 infinity, so we fix 4 (in fact 5): */
2919 PL_savestack_ix += 5; /* Protect save in progress. */
2920 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2923 PL_markstack_ptr++; /* Protect mark. */
2925 PL_scopestack_ix += 1;
2926 /* sv_2cv is too complicated, try a simpler variant first: */
2927 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2928 || SvTYPE(cv) != SVt_PVCV) {
2930 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2933 if (!cv || !CvROOT(cv)) {
2934 if (ckWARN(WARN_SIGNAL))
2935 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2936 PL_sig_name[sig], (gv ? GvENAME(gv)
2943 if(PL_psig_name[sig]) {
2944 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2946 #if !defined(PERL_IMPLICIT_CONTEXT)
2950 sv = sv_newmortal();
2951 sv_setpv(sv,PL_sig_name[sig]);
2954 PUSHSTACKi(PERLSI_SIGNAL);
2957 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2959 struct sigaction oact;
2961 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2964 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2965 /* The siginfo fields signo, code, errno, pid, uid,
2966 * addr, status, and band are defined by POSIX/SUSv3. */
2967 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2968 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2969 #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. */
2970 hv_stores(sih, "errno", newSViv(sip->si_errno));
2971 hv_stores(sih, "status", newSViv(sip->si_status));
2972 hv_stores(sih, "uid", newSViv(sip->si_uid));
2973 hv_stores(sih, "pid", newSViv(sip->si_pid));
2974 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2975 hv_stores(sih, "band", newSViv(sip->si_band));
2979 mPUSHp((char *)sip, sizeof(*sip));
2987 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2990 if (SvTRUE(ERRSV)) {
2992 #ifdef HAS_SIGPROCMASK
2993 /* Handler "died", for example to get out of a restart-able read().
2994 * Before we re-do that on its behalf re-enable the signal which was
2995 * blocked by the system when we entered.
2999 sigaddset(&set,sig);
3000 sigprocmask(SIG_UNBLOCK, &set, NULL);
3002 /* Not clear if this will work */
3003 (void)rsignal(sig, SIG_IGN);
3004 (void)rsignal(sig, PL_csighandlerp);
3006 #endif /* !PERL_MICRO */
3007 Perl_die(aTHX_ NULL);
3011 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3015 PL_scopestack_ix -= 1;
3018 PL_op = myop; /* Apparently not needed... */
3020 PL_Sv = tSv; /* Restore global temporaries. */
3027 S_restore_magic(pTHX_ const void *p)
3030 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3031 SV* const sv = mgs->mgs_sv;
3036 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3038 #ifdef PERL_OLD_COPY_ON_WRITE
3039 /* While magic was saved (and off) sv_setsv may well have seen
3040 this SV as a prime candidate for COW. */
3042 sv_force_normal_flags(sv, 0);
3046 SvFLAGS(sv) |= mgs->mgs_flags;
3049 if (SvGMAGICAL(sv)) {
3050 /* downgrade public flags to private,
3051 and discard any other private flags */
3053 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3055 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3056 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3061 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3063 /* If we're still on top of the stack, pop us off. (That condition
3064 * will be satisfied if restore_magic was called explicitly, but *not*
3065 * if it's being called via leave_scope.)
3066 * The reason for doing this is that otherwise, things like sv_2cv()
3067 * may leave alloc gunk on the savestack, and some code
3068 * (e.g. sighandler) doesn't expect that...
3070 if (PL_savestack_ix == mgs->mgs_ss_ix)
3072 I32 popval = SSPOPINT;
3073 assert(popval == SAVEt_DESTRUCTOR_X);
3074 PL_savestack_ix -= 2;
3076 assert(popval == SAVEt_ALLOC);
3078 PL_savestack_ix -= popval;
3084 S_unwind_handler_stack(pTHX_ const void *p)
3087 const U32 flags = *(const U32*)p;
3089 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3092 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3093 #if !defined(PERL_IMPLICIT_CONTEXT)
3095 SvREFCNT_dec(PL_sig_sv);
3100 =for apidoc magic_sethint
3102 Triggered by a store to %^H, records the key/value pair to
3103 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3104 anything that would need a deep copy. Maybe we should warn if we find a
3110 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3113 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3114 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3116 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3118 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3119 an alternative leaf in there, with PL_compiling.cop_hints being used if
3120 it's NULL. If needed for threads, the alternative could lock a mutex,
3121 or take other more complex action. */
3123 /* Something changed in %^H, so it will need to be restored on scope exit.
3124 Doing this here saves a lot of doing it manually in perl code (and
3125 forgetting to do it, and consequent subtle errors. */
3126 PL_hints |= HINT_LOCALIZE_HH;
3127 PL_compiling.cop_hints_hash
3128 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3133 =for apidoc magic_clearhint
3135 Triggered by a delete from %^H, records the key to
3136 C<PL_compiling.cop_hints_hash>.
3141 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3145 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3146 PERL_UNUSED_ARG(sv);
3148 assert(mg->mg_len == HEf_SVKEY);
3150 PERL_UNUSED_ARG(sv);
3152 PL_hints |= HINT_LOCALIZE_HH;
3153 PL_compiling.cop_hints_hash
3154 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3155 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3161 * c-indentation-style: bsd
3163 * indent-tabs-mode: t
3166 * ex: set ts=8 sts=4 sw=4 noet: